SUBROUTINE DPLAB(IANS,IANSLC,IWIDTH,IHARG,IHARG2,NUMARG, CCCCC SUBROUTINE DPLAB(IANS,IWIDTH,IHARG,IHARG2,NUMARG, SEPT 1993 CCCCC SUBROUTINE DPLAB(IANS,IWIDTH,IHARG,NUMARG, CCCCC THE ABOVE LINE WAS AUGMENTED AUGUST 1992 CCCCC THE FOLLOWING 5 LINES WERE AUGMENTED AUGUST 1992 CCCCC1IX1LTE,NCX1LA, CCCCC1IX2LTE,NCX2LA, CCCCC1IX3LTE,NCX3LA, CCCCC1IY1LTE,NCY1LA, CCCCC1IY2LTE,NCY2LA, 1IX1LTE,NCX1LA,IX1AUT, 1IX2LTE,NCX2LA,IX2AUT, 1IX3LTE,NCX3LA,IX3AUT, 1IY1LTE,NCY1LA,IY1AUT, 1IY2LTE,NCY2LA,IY2AUT, 1IBUGP2,IFOUND,IERROR) C C PURPOSE--EXTRACT THE STRING TO BE USED AS ONE C ON THE 5 LABELS AVAILABLE AROUND A PLOT-- C 1 TO THE LEFT OF THE LEFT VERTICAL FRAME LINE; C 1 TO THE RIGHT OF THE RIGHT VERTICAL FRAME LINE; C 3 BELOW THE BOTTOM HORIZONTAL FRAME LINE. C INPUT ARGUMENTS--IANS (A CHARACTER VECTOR) C --IWIDTH C --IHARG (A CHARACTER VECTOR) C --IHARG2 (A CHARACTER VECTOR) C --NUMARG C OUTPUT ARGUMENTS--ILX1TE (A CHARACTER ARRAY C CONTAINING THE FIRST HORIZONTAL LABEL). C --NCX1LA (AN INTEGER VARIABLE C CONTAINING THE NUMBER OF CHARACTERS IN ILX1TE). C --ILX2TE (A CHARACTER ARRAY C CONTAINING THE SECOND HORIZONTAL LABEL). C --NCX2LA (AN INTEGER VARIABLE C CONTAINING THE NUMBER OF CHARACTERS IN ILX2TE). C --ILX3TE (A CHARACTER ARRAY C CONTAINING THE THIRD HORIZONTAL LABEL). C --NCX3LA (AN INTEGER VARIABLE C CONTAINING THE NUMBER OF CHARACTERS IN ILX3TE). C --ILY1TE (A CHARACTER ARRAY C CONTAINING THE FIRST VERTICAL LABEL). C --NCY1LA (AN INTEGER VARIABLE C CONTAINING THE NUMBER OF CHARACTERS IN ILY1TE). C --ILY2TE (A CHARACTER ARRAY C CONTAINING THE SECOND VERTICAL LABEL). C --NCY2LA (AN INTEGER VARIABLE C CONTAINING THE NUMBER OF CHARACTERS IN ILY2TE). C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JANUARY 1978. C UPDATED --JUNE 1978. C UPDATED --MARCH 1981. C UPDATED --MAY 1982. C UPDATED --AUGUST 1992. ADD SWITCHES FOR AUTOMATIC C UPDATED --SEPTEMBER 1993. ALLOW LOWER CASE C UPDATED --SEPTEMBER 1993. ACTIVATE LABEL AUTOMATIC C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IANS CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993 CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 CHARACTER*4 IANSLC CHARACTER*4 IHARG CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992 CHARACTER*4 IHARG2 C CHARACTER*4 IX1LTE CHARACTER*4 IX2LTE CHARACTER*4 IX3LTE CHARACTER*4 IY1LTE CHARACTER*4 IY2LTE C CCCCC FOLLOWING LINES ADDED AUGUST 1992. CHARACTER*4 IX1AUT CHARACTER*4 IX2AUT CHARACTER*4 IX3AUT CHARACTER*4 IY1AUT CHARACTER*4 IY2AUT C CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ILABT C C--------------------------------------------------------------------- C DIMENSION IANS(*) CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1993 CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 DIMENSION IANSLC(*) DIMENSION IHARG(*) CCCCC THE FOLLOWING LINE WAS ADDED AUGUST 1992 DIMENSION IHARG2(*) C DIMENSION IX1LTE(*) DIMENSION IX2LTE(*) DIMENSION IX3LTE(*) DIMENSION IY1LTE(*) DIMENSION IY2LTE(*) 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(IBUGP2.NE.'ON')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPLAB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)NCX1LA,NCX2LA,NCX3LA,NCY1LA,NCY2LA 53 FORMAT('NCX1LA,NCX2LA,NCX3LA,NCY1LA,NCY2LA = ',5I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,61)(IX1LTE(I),I=1,NCX1LA) 61 FORMAT('(IX1LTE(I),I=1,NCX1LA) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,62)(IX2LTE(I),I=1,NCX2LA) 62 FORMAT('(IX2LTE(I),I=1,NCX2LA) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,63)(IX3LTE(I),I=1,NCX3LA) 63 FORMAT('(IX3LTE(I),I=1,NCX3LA) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,64)(IY1LTE(I),I=1,NCY1LA) 64 FORMAT('(IY1LTE(I),I=1,NCY1LA) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,65)(IY2LTE(I),I=1,NCY2LA) 65 FORMAT('(IY2LTE(I),I=1,NCY2LA) = ',100A1) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************************* C ** STEP 1-- ** C ** DETERMINE THE COMMAND ** C ** ( YLABEL = Y1LABEL, Y2LABEL, ** C ** XLABEL = X1LABEL, X2LABEL, X3LABEL) ** C ********************************************* C IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'COLO')GOTO9000 IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'COLO')GOTO9000 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'SIZE')GOTO9000 IF(NUMARG.EQ.2.AND.IHARG(1).EQ.'SIZE')GOTO9000 C DO1000I=1,IWIDTH I2=I IP1=I+1 IP2=I+2 IP3=I+3 IP4=I+4 IP5=I+5 IP6=I+6 IF(IANS(I).EQ.'Y'.AND.IANS(IP1).EQ.'L' 1.AND.IANS(IP2).EQ.'A'.AND.IANS(IP3).EQ.'B' 1.AND.IANS(IP4).EQ.'E'.AND.IANS(IP5).EQ.'L' 1.AND.IANS(IP6).EQ.' ') 1GOTO110 IF(IANS(I).EQ.'Y'.AND.IANS(IP1).EQ.'1' 1.AND.IANS(IP2).EQ.'L'.AND.IANS(IP3).EQ.'A' 1.AND.IANS(IP4).EQ.'B'.AND.IANS(IP5).EQ.'E' 1.AND.IANS(IP6).EQ.'L') 1GOTO115 IF(IANS(I).EQ.'Y'.AND.IANS(IP1).EQ.'2' 1.AND.IANS(IP2).EQ.'L'.AND.IANS(IP3).EQ.'A' 1.AND.IANS(IP4).EQ.'B'.AND.IANS(IP5).EQ.'E' 1.AND.IANS(IP6).EQ.'L') 1GOTO125 IF(IANS(I).EQ.'X'.AND.IANS(IP1).EQ.'L' 1.AND.IANS(IP2).EQ.'A'.AND.IANS(IP3).EQ.'B' 1.AND.IANS(IP4).EQ.'E'.AND.IANS(IP5).EQ.'L' 1.AND.IANS(IP6).EQ.' ') 1GOTO210 IF(IANS(I).EQ.'X'.AND.IANS(IP1).EQ.'1' 1.AND.IANS(IP2).EQ.'L'.AND.IANS(IP3).EQ.'A' 1.AND.IANS(IP4).EQ.'B'.AND.IANS(IP5).EQ.'E' 1.AND.IANS(IP6).EQ.'L') 1GOTO215 IF(IANS(I).EQ.'X'.AND.IANS(IP1).EQ.'2' 1.AND.IANS(IP2).EQ.'L'.AND.IANS(IP3).EQ.'A' 1.AND.IANS(IP4).EQ.'B'.AND.IANS(IP5).EQ.'E' 1.AND.IANS(IP6).EQ.'L') 1GOTO225 IF(IANS(I).EQ.'X'.AND.IANS(IP1).EQ.'3' 1.AND.IANS(IP2).EQ.'L'.AND.IANS(IP3).EQ.'A' 1.AND.IANS(IP4).EQ.'B'.AND.IANS(IP5).EQ.'E' 1.AND.IANS(IP6).EQ.'L') 1GOTO235 C IF(IANS(I).EQ.'L'.AND.IANS(IP1).EQ.'A' 1.AND.IANS(IP2).EQ.'B'.AND.IANS(IP3).EQ.'E' 1.AND.IANS(IP4).EQ.'L'.AND.IANS(IP5).EQ.' ') 1GOTO240 IF(IANS(I).EQ.'L'.AND.IANS(IP1).EQ.'A' 1.AND.IANS(IP2).EQ.'B'.AND.IANS(IP3).EQ.'E' 1.AND.IANS(IP4).EQ.'L'.AND.IANS(IP5).EQ.'S') 1GOTO245 C 1000 CONTINUE WRITE(ICOUT,1001) 1001 FORMAT('***** ERROR IN DPLAB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1002) 1002 FORMAT(' NO MATCH FOR COMMAND.') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C ********************************************************** C ** STEP 2-- ** C ** DEFINE THE START POSITION (ISTART) FOR THE STRING. ** C ********************************************************** C 110 CONTINUE ISTART=I2+7 ILABT='Y' GOTO300 115 CONTINUE ISTART=I2+8 ILABT='Y1' GOTO300 125 CONTINUE ISTART=I2+8 ILABT='Y2' GOTO300 210 CONTINUE ISTART=I2+7 ILABT='X1' GOTO300 215 CONTINUE ISTART=I2+8 ILABT='X1' GOTO300 225 CONTINUE ISTART=I2+8 ILABT='X2' GOTO300 235 CONTINUE ISTART=I2+8 ILABT='X3' GOTO300 240 CONTINUE ISTART=I2+6 ILABT='ALL' GOTO300 245 CONTINUE ISTART=I2+7 ILABT='ALL' GOTO300 C C ******************************************************** C ** STEP 3-- ** C ** DEFINE THE STOP POSITION (ISTOP) FOR THE STRING. ** C ******************************************************** C 300 CONTINUE ISTOP=0 IF(ISTART.GT.IWIDTH)GOTO329 DO320I=ISTART,IWIDTH IREV=IWIDTH-I+ISTART IF(IANS(IREV).NE.' ')GOTO325 320 CONTINUE GOTO329 325 CONTINUE ISTOP=IREV 329 CONTINUE C C ***************************************** C ** STEP 4-- ** C ** COPY OVER THE STRING OF INTEREST. ** C ***************************************** C IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'ON')GOTO359 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'OFF')GOTO359 CCCCC IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'AUTO')GOTO359 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DEFA')GOTO359 IF(NUMARG.EQ.0)GOTO359 C IF(ISTART.GT.ISTOP)GOTO359 IF(ISTOP.EQ.0)GOTO359 J=0 DO350I=ISTART,ISTOP J=J+1 C CCCCC THE FOLLOWING LINES WERE CHANGED SEPTEMBER 1993 CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 CCCCC IF(ILABT.EQ.'Y1')IY1LTE(J)=IANS(I) CCCCC IF(ILABT.EQ.'Y2')IY2LTE(J)=IANS(I) CCCCC IF(ILABT.EQ.'X1')IX1LTE(J)=IANS(I) CCCCC IF(ILABT.EQ.'X2')IX2LTE(J)=IANS(I) CCCCC IF(ILABT.EQ.'X3')IX3LTE(J)=IANS(I) CCCCC IF(ILABT.EQ.'Y')IY1LTE(J)=IANS(I) CCCCC IF(ILABT.EQ.'Y')IY2LTE(J)=IANS(I) CCCCC IF(ILABT.EQ.'ALL')IY1LTE(J)=IANS(I) CCCCC IF(ILABT.EQ.'ALL')IY2LTE(J)=IANS(I) CCCCC IF(ILABT.EQ.'ALL')IX1LTE(J)=IANS(I) CCCCC IF(ILABT.EQ.'ALL')IX2LTE(J)=IANS(I) CCCCC IF(ILABT.EQ.'ALL')IX3LTE(J)=IANS(I) C IF(ILABT.EQ.'Y1')IY1LTE(J)=IANSLC(I) IF(ILABT.EQ.'Y2')IY2LTE(J)=IANSLC(I) IF(ILABT.EQ.'X1')IX1LTE(J)=IANSLC(I) IF(ILABT.EQ.'X2')IX2LTE(J)=IANSLC(I) IF(ILABT.EQ.'X3')IX3LTE(J)=IANSLC(I) IF(ILABT.EQ.'Y')IY1LTE(J)=IANSLC(I) IF(ILABT.EQ.'Y')IY2LTE(J)=IANSLC(I) IF(ILABT.EQ.'ALL')IY1LTE(J)=IANSLC(I) IF(ILABT.EQ.'ALL')IY2LTE(J)=IANSLC(I) IF(ILABT.EQ.'ALL')IX1LTE(J)=IANSLC(I) IF(ILABT.EQ.'ALL')IX2LTE(J)=IANSLC(I) IF(ILABT.EQ.'ALL')IX3LTE(J)=IANSLC(I) C 350 CONTINUE C IF(ILABT.EQ.'Y1')NCY1LA=J IF(ILABT.EQ.'Y2')NCY2LA=J IF(ILABT.EQ.'X1')NCX1LA=J IF(ILABT.EQ.'X2')NCX2LA=J IF(ILABT.EQ.'X3')NCX3LA=J IF(ILABT.EQ.'Y')NCY1LA=J IF(ILABT.EQ.'Y')NCY2LA=J IF(ILABT.EQ.'ALL')NCY1LA=J IF(ILABT.EQ.'ALL')NCY2LA=J IF(ILABT.EQ.'ALL')NCX1LA=J IF(ILABT.EQ.'ALL')NCX2LA=J IF(ILABT.EQ.'ALL')NCX3LA=J C GOTO800 359 CONTINUE C C ************************************ C ** STEP 5-- ** C ** TREAT THE EMPTY-STRING CASE. ** C ************************************ C IF(ILABT.EQ.'Y1')NCY1LA=0 IF(ILABT.EQ.'Y2')NCY2LA=0 IF(ILABT.EQ.'X1')NCX1LA=0 IF(ILABT.EQ.'X2')NCX2LA=0 IF(ILABT.EQ.'X3')NCX3LA=0 IF(ILABT.EQ.'Y')NCY1LA=0 IF(ILABT.EQ.'Y')NCY2LA=0 IF(ILABT.EQ.'ALL')NCY1LA=0 IF(ILABT.EQ.'ALL')NCY2LA=0 IF(ILABT.EQ.'ALL')NCX1LA=0 IF(ILABT.EQ.'ALL')NCX2LA=0 IF(ILABT.EQ.'ALL')NCX3LA=0 GOTO800 C C *************************** C ** STEP 6-- ** C ** PRINT OUT A MESSAGE ** C *************************** C 800 CONTINUE IF(ILABT.EQ.'Y1')GOTO810 IF(ILABT.EQ.'Y2')GOTO820 IF(ILABT.EQ.'X1')GOTO830 IF(ILABT.EQ.'X2')GOTO840 IF(ILABT.EQ.'X3')GOTO850 IF(ILABT.EQ.'Y')GOTO860 IF(ILABT.EQ.'ALL')GOTO870 C 810 CONTINUE IFOUND='YES' CCCCC THE FOLLOWING 6 LINES WERE ADDED AUGUST 1992 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'AUTO'.AND. 1IHARG2(1).EQ.'MATI')THEN IY1AUT='ON' ELSE IY1AUT='OFF' ENDIF IF(IFEEDB.EQ.'OFF')GOTO819 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811) 811 FORMAT('THE LEFT VERTICAL AXIS LABEL HAS JUST BEEN ', 1'SET TO') CALL DPWRST('XXX','BUG ') IF(NCY1LA.EQ.0)WRITE(ICOUT,999) IF(NCY1LA.EQ.0)CALL DPWRST('XXX','BUG ') IF(NCY1LA.GE.1)WRITE(ICOUT,812)(IY1LTE(I),I=1,NCY1LA) 812 FORMAT(11X,119A1) IF(NCY1LA.GE.1)CALL DPWRST('XXX','BUG ') 819 CONTINUE GOTO9000 C 820 CONTINUE IFOUND='YES' CCCCC THE FOLLOWING 6 LINES WERE ADDED AUGUST 1992 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'AUTO'.AND. 1IHARG2(1).EQ.'MATI')THEN IY2AUT='ON' ELSE IY2AUT='OFF' ENDIF IF(IFEEDB.EQ.'OFF')GOTO829 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,821) CALL DPWRST('XXX','BUG ') IF(NCY2LA.EQ.0)WRITE(ICOUT,999) IF(NCY2LA.EQ.0)CALL DPWRST('XXX','BUG ') IF(NCY2LA.GE.1)WRITE(ICOUT,822)(IY2LTE(I),I=1,NCY2LA) 821 FORMAT('THE RIGHT VERTICAL AXIS LABEL HAS JUST BEEN ', 1'SET TO') IF(NCY2LA.GE.1)CALL DPWRST('XXX','BUG ') 822 FORMAT(11X,119A1) 829 CONTINUE GOTO9000 C 830 CONTINUE IFOUND='YES' CCCCC THE FOLLOWING 6 LINES WERE ADDED AUGUST 1992 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'AUTO'.AND. 1IHARG2(1).EQ.'MATI')THEN IX1AUT='ON' ELSE IX1AUT='OFF' ENDIF IF(IFEEDB.EQ.'OFF')GOTO839 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,831) 831 FORMAT('THE FIRST HORIZONTAL AXIS LABEL HAS JUST BEEN ', 1'SET TO') CALL DPWRST('XXX','BUG ') IF(NCX1LA.EQ.0)WRITE(ICOUT,999) IF(NCX1LA.EQ.0)CALL DPWRST('XXX','BUG ') IF(NCX1LA.GE.1)WRITE(ICOUT,832)(IX1LTE(I),I=1,NCX1LA) 832 FORMAT(11X,119A1) IF(NCX1LA.GE.1)CALL DPWRST('XXX','BUG ') 839 CONTINUE GOTO9000 C 840 CONTINUE IFOUND='YES' CCCCC THE FOLLOWING 6 LINES WERE ADDED AUGUST 1992 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'AUTO'.AND. 1IHARG2(1).EQ.'MATI')THEN IX2AUT='ON' ELSE IX2AUT='OFF' ENDIF IF(IFEEDB.EQ.'OFF')GOTO849 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,841) 841 FORMAT('THE SECOND HORIZONTAL AXIS LABEL HAS JUST BEEN ', 1'SET TO') CALL DPWRST('XXX','BUG ') IF(NCX2LA.EQ.0)WRITE(ICOUT,999) IF(NCX2LA.EQ.0)CALL DPWRST('XXX','BUG ') IF(NCX2LA.GE.1)WRITE(ICOUT,842)(IX2LTE(I),I=1,NCX2LA) 842 FORMAT(11X,119A1) IF(NCX2LA.GE.1)CALL DPWRST('XXX','BUG ') 849 CONTINUE GOTO9000 C 850 CONTINUE IFOUND='YES' CCCCC THE FOLLOWING 6 LINES WERE ADDED AUGUST 1992 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'AUTO'.AND. 1IHARG2(1).EQ.'MATI')THEN IX3AUT='ON' ELSE IX3AUT='OFF' ENDIF IF(IFEEDB.EQ.'OFF')GOTO859 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,851) 851 FORMAT('THE THIRD HORIZONTAL AXIS LABEL HAS JUST BEEN ', 1'SET TO') CALL DPWRST('XXX','BUG ') IF(NCX3LA.EQ.0)WRITE(ICOUT,999) IF(NCX3LA.EQ.0)CALL DPWRST('XXX','BUG ') IF(NCX3LA.GE.1)WRITE(ICOUT,852)(IX3LTE(I),I=1,NCX3LA) 852 FORMAT(11X,119A1) IF(NCX3LA.GE.1)CALL DPWRST('XXX','BUG ') 859 CONTINUE GOTO9000 C 860 CONTINUE IFOUND='YES' CCCCC THE FOLLOWING 8 LINES WERE ADDED AUGUST 1992 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'AUTO'.AND. 1IHARG2(1).EQ.'MATI')THEN IY1AUT='ON' IY2AUT='ON' ELSE IY1AUT='OFF' IY2AUT='OFF' ENDIF IF(IFEEDB.EQ.'OFF')GOTO869 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,861) 861 FORMAT('THE LEFT AND RIGHT VERTICAL AXIS LABELS ', 1'HAVE JUST BEEN SET TO') CALL DPWRST('XXX','BUG ') IF(NCY1LA.EQ.0)WRITE(ICOUT,999) IF(NCY1LA.EQ.0)CALL DPWRST('XXX','BUG ') IF(NCY1LA.GE.1)WRITE(ICOUT,862)(IY1LTE(I),I=1,NCY1LA) 862 FORMAT(11X,119A1) IF(NCY1LA.GE.1)CALL DPWRST('XXX','BUG ') 869 CONTINUE GOTO9000 C 870 CONTINUE IFOUND='YES' CCCCC THE FOLLOWING 14 LINES WERE ADDED AUGUST 1992 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'AUTO'.AND. 1IHARG2(1).EQ.'MATI')THEN IY1AUT='ON' IY2AUT='ON' IX1AUT='ON' IX2AUT='ON' IX3AUT='ON' ELSE IY1AUT='OFF' IY2AUT='OFF' IX1AUT='OFF' IX2AUT='OFF' IX3AUT='OFF' ENDIF CCCCC THE FOLLOWING LINES WERE COMMENTED OUT SEPTEMBER 1993 CCCCC IY1AUT='OFF' CCCCC IY2AUT='OFF' CCCCC IX1AUT='OFF' CCCCC IX2AUT='OFF' CCCCC IX3AUT='OFF' IF(IFEEDB.EQ.'OFF')GOTO879 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,871) 871 FORMAT('ALL 5 LABELS (THE 2 VERTICAL AND THE 3 BOTTOM ', 1'HORIZONTAL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,872) 872 FORMAT('HAVE JUST BEEN SET TO') CALL DPWRST('XXX','BUG ') IF(NCY1LA.EQ.0)WRITE(ICOUT,999) IF(NCY1LA.EQ.0)CALL DPWRST('XXX','BUG ') IF(NCY1LA.GE.1)WRITE(ICOUT,873)(IY1LTE(I),I=1,NCY1LA) 873 FORMAT(11X,119A1) IF(NCY1LA.GE.1)CALL DPWRST('XXX','BUG ') 879 CONTINUE GOTO9000 C C **************** C ** STEP 90-- ** C ** EXIT ** C **************** C 9000 CONTINUE IF(IBUGP2.NE.'ON')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF DPLAB--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NCX1LA,NCX2LA,NCX3LA,NCY1LA,NCY2LA 9013 FORMAT('NCX1LA,NCX2LA,NCX3LA,NCY1LA,NCY2LA = ',5I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9021)(IX1LTE(I),I=1,NCX1LA) 9021 FORMAT('(IX1LTE(I),I=1,NCX1LA) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9022)(IX2LTE(I),I=1,NCX2LA) 9022 FORMAT('(IX2LTE(I),I=1,NCX2LA) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9023)(IX3LTE(I),I=1,NCX3LA) 9023 FORMAT('(IX3LTE(I),I=1,NCX3LA) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9024)(IY1LTE(I),I=1,NCY1LA) 9024 FORMAT('(IY1LTE(I),I=1,NCY1LA) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9025)(IY2LTE(I),I=1,NCY2LA) 9025 FORMAT('(IY2LTE(I),I=1,NCY2LA) = ',100A1) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPLAAN(ICOM,IHARG,IARGT,ARG,NUMARG, 1PDEFAN, 1PX1LAN,PX2LAN,PX3LAN,PY1LAN,PY2LAN, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE LABEL ANGLES C FOR ANY OF THE 5 LABELS. C THE LABEL ANGLE SWITCHES FOR THE LABELS C ARE CONTAINED IN THE VARIABLES-- C PX1LAN,PX2LAN,PX3LAN,PY1LAN,PY2LAN C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG C --PDEFAN (DEFAULT ANGLE) C OUTPUT ARGUMENTS--PX1LAN, C PX2LAN, C PX3LAN, C PY1LAN, C PY2LAN C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/11 C ORIGINAL VERSION--NOVEMBER 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM 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.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ANGL')GOTO1090 GOTO1900 1090 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE FIRST HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'XLAB')GOTO1100 IF(ICOM.EQ.'X1LA')GOTO1100 GOTO1199 C 1100 CONTINUE 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(IHARG(NUMARG).EQ.'ANGL')GOTO1150 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 IERROR='YES' GOTO9000 C 1150 CONTINUE HOLD1=PDEFAN GOTO1180 C 1160 CONTINUE HOLD1=ARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' PX1LAN=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE LABEL ANGLE (FOR THE FIRST HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)HOLD1 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE SECOND HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2LA')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'ANGL')GOTO1250 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1260 IERROR='YES' GOTO9000 C 1250 CONTINUE HOLD1=PDEFAN GOTO1280 C 1260 CONTINUE HOLD1=ARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' PX2LAN=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE LABEL ANGLE (FOR THE SECOND HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)HOLD1 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE THIRD HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X3LA')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'ANGL')GOTO1350 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1360 IERROR='YES' GOTO9000 C 1350 CONTINUE HOLD1=PDEFAN GOTO1380 C 1360 CONTINUE HOLD1=ARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' PX3LAN=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE LABEL ANGLE (FOR THE THIRD HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)HOLD1 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1LA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1450 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 IF(IHARG(NUMARG).EQ.'ANGL')GOTO1450 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1460 IERROR='YES' GOTO9000 C 1450 CONTINUE HOLD1=90.0 GOTO1480 C 1460 CONTINUE HOLD1=ARG(NUMARG) GOTO1480 C 1480 CONTINUE IFOUND='YES' PY1LAN=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO1489 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1481) 1481 FORMAT('THE LABEL ANGLE (FOR THE LEFT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1482)HOLD1 1482 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1489 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2LA')GOTO1500 GOTO1599 C 1500 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1550 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 IF(IHARG(NUMARG).EQ.'ANGL')GOTO1550 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1560 IERROR='YES' GOTO9000 C 1550 CONTINUE HOLD1=90.0 GOTO1580 C 1560 CONTINUE HOLD1=ARG(NUMARG) GOTO1580 C 1580 CONTINUE IFOUND='YES' PY2LAN=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO1589 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('THE LABEL ANGLE (FOR THE RIGHT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582)HOLD1 1582 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1589 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH VERTICAL AXIS LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'YLAB')GOTO1600 GOTO1699 C 1600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1650 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 IF(IHARG(NUMARG).EQ.'ANGL')GOTO1650 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1660 IERROR='YES' GOTO9000 C 1650 CONTINUE HOLD1=90.0 GOTO1680 C 1660 CONTINUE HOLD1=ARG(NUMARG) GOTO1680 C 1680 CONTINUE IFOUND='YES' PY1LAN=HOLD1 PY2LAN=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO1689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1681) 1681 FORMAT('THE LABEL ANGLE (FOR THE LEFT AND RIGHT VERTICAL ', 1'LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1682)HOLD1 1682 FORMAT('HAVE JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1689 CONTINUE GOTO1900 C 1699 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY ALL 5 LABELS ARE TO BE CHANGED ** C ************************************************************** C ************************************************************** C IF(ICOM.EQ.'LABE')GOTO1700 IF(ICOM.EQ.'XYLA')GOTO1700 IF(ICOM.EQ.'YXLA')GOTO1700 GOTO1799 C 1700 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1750 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 IF(IHARG(NUMARG).EQ.'ANGL')GOTO1750 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1760 IERROR='YES' GOTO9000 C 1750 CONTINUE HOLD1=PDEFAN HOLD2=90.0 GOTO1780 C 1760 CONTINUE HOLD1=ARG(NUMARG) HOLD2=ARG(NUMARG) GOTO1780 C 1780 CONTINUE IFOUND='YES' PX1LAN=HOLD1 PX2LAN=HOLD1 PX3LAN=HOLD1 PY1LAN=HOLD2 PY2LAN=HOLD2 C IF(IFEEDB.EQ.'OFF')GOTO1789 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1781) 1781 FORMAT('THE LABEL ANGLE FOR ALL 3 HORIZONTAL LABELS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)HOLD1 1782 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1786) 1786 FORMAT('THE LABEL ANGLE FOR BOTH VERTICAL LABELS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1787)HOLD2 1787 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1789 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE DPLACA(ICOM,IHARG,NUMARG, 1IDEFCA, 1IX1LCA,IX2LCA,IX3LCA,IY1LCA,IY2LCA, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE LABEL CASE SWITCHES C FOR ANY OF THE 5 LABELS. C SUCH LABEL CASE SWITCHES DEFINE THE CASE C FOR EACH OF THE 5 LABELS. C THE CONTENTS OF A LABEL CASE SWITCH ARE C A CASE. C THE LABEL CASE SWITCHES FOR THE 5 LABELS C ARE CONTAINED IN IX1LCA,IX2LCA,IX3LCA,IY1LCA,IY2LCA. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFCA C OUTPUT ARGUMENTS--IX1LCA (A HOLLERITH VARIABLE C DENOTING THE CASE OF THE FIRST HORIZ. LABEL C --IX2LCA (A HOLLERITH VARIABLE C DENOTING THE CASE OF THE SECOND HORIZ. LABEL C --IX3LCA (A HOLLERITH VARIABLE C DENOTING THE CASE OF THE THIRD HORIZ. LABEL C --IY1LCA (A HOLLERITH VARIABLE C DENOTING THE CASE OF THE FIRST VERT. LABEL C --IY2LCA (A HOLLERITH VARIABLE C DENOTING THE CASE OF THE SECOND VERT. LABEL C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--OCTOBER 1980. C UPDATED --MARCH 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG C CHARACTER*4 IDEFCA C CHARACTER*4 IX1LCA CHARACTER*4 IX2LCA CHARACTER*4 IX3LCA CHARACTER*4 IY1LCA CHARACTER*4 IY2LCA C CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CASE')GOTO1090 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 1IHARG(2).EQ.'CASE')GOTO1090 GOTO1900 1090 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE FIRST HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'XLAB')GOTO1100 IF(ICOM.EQ.'X1LA')GOTO1100 GOTO1199 C 1100 CONTINUE 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(IHARG(NUMARG).EQ.'CASE')GOTO1150 GOTO1160 C 1150 CONTINUE IHOLD=IDEFCA GOTO1180 C 1160 CONTINUE IHOLD=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IX1LCA=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE LABEL CASE (FOR THE FIRST HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)IHOLD 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE SECOND HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2LA')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'CASE')GOTO1250 GOTO1260 C 1250 CONTINUE IHOLD=IDEFCA GOTO1280 C 1260 CONTINUE IHOLD=IHARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' IX2LCA=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE LABEL CASE (FOR THE SECOND HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)IHOLD 1282 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE THIRD HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X3LA')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'CASE')GOTO1350 GOTO1360 C 1350 CONTINUE IHOLD=IDEFCA GOTO1380 C 1360 CONTINUE IHOLD=IHARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' IX3LCA=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE LABEL CASE (FOR THE THIRD HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)IHOLD 1382 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1LA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1450 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 IF(IHARG(NUMARG).EQ.'CASE')GOTO1450 GOTO1460 C 1450 CONTINUE IHOLD=IDEFCA GOTO1480 C 1460 CONTINUE IHOLD=IHARG(NUMARG) GOTO1480 C 1480 CONTINUE IFOUND='YES' IY1LCA=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1489 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1481) 1481 FORMAT('THE LABEL CASE (FOR THE LEFT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1482)IHOLD 1482 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1489 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2LA')GOTO1500 GOTO1599 C 1500 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1550 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 IF(IHARG(NUMARG).EQ.'CASE')GOTO1550 GOTO1560 C 1550 CONTINUE IHOLD=IDEFCA GOTO1580 C 1560 CONTINUE IHOLD=IHARG(NUMARG) GOTO1580 C 1580 CONTINUE IFOUND='YES' IY2LCA=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1589 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('THE LABEL CASE (FOR THE RIGHT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582)IHOLD 1582 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1589 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH LEFT AND RIGHT VERTICAL LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'YLAB')GOTO1600 GOTO1699 C 1600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1650 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 IF(IHARG(NUMARG).EQ.'CASE')GOTO1650 GOTO1660 C 1650 CONTINUE IHOLD=IDEFCA GOTO1680 C 1660 CONTINUE IHOLD=IHARG(NUMARG) GOTO1680 C 1680 CONTINUE IFOUND='YES' IY1LCA=IHOLD IY2LCA=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1681) 1681 FORMAT('THE LABEL CASE (FOR THE LEFT AND RIGHT VERTICAL ', 1'LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1682)IHOLD 1682 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1689 CONTINUE GOTO1900 C 1699 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY ALL 5 LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'LABE')GOTO1700 IF(ICOM.EQ.'XYLA')GOTO1700 IF(ICOM.EQ.'YXLA')GOTO1700 GOTO1799 C 1700 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1750 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 IF(IHARG(NUMARG).EQ.'CASE')GOTO1750 GOTO1760 C 1750 CONTINUE IHOLD=IDEFCA GOTO1780 C 1760 CONTINUE IHOLD=IHARG(NUMARG) GOTO1780 C 1780 CONTINUE IFOUND='YES' IY1LCA=IHOLD IY2LCA=IHOLD IX1LCA=IHOLD IX2LCA=IHOLD IX3LCA=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1789 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1781) 1781 FORMAT('THE LABEL CASE (FOR ALL 5 ', 1'LABELS--3 HORIZONTAL AND 2 VERTICAL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)IHOLD 1782 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1789 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPLACL(ICOM,IHARG,NUMARG, 1IDEFCO, 1IX1LCO,IX2LCO,IX3LCO,IY1LCO,IY2LCO, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE LABEL COLOR SWITCHES C FOR ANY OF THE 5 LABELS. C SUCH LABEL COLOR SWITCHES DEFINE THE COLOR C FOR EACH OF THE 5 LABELS. C THE CONTENTS OF A LABEL COLOR SWITCH ARE C A COLOR. C THE LABEL COLOR SWITCHES FOR THE 5 LABELS C ARE CONTAINED IN IX1LCO,IX2LCO,IX3LCO,IY1LCO,IY2LCO. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFCO C OUTPUT ARGUMENTS--IX1LCO (A HOLLERITH VARIABLE C DENOTING THE COLOR OF THE FIRST HORIZ. LABEL C --IX2LCO (A HOLLERITH VARIABLE C DENOTING THE COLOR OF THE SECOND HORIZ. LABEL C --IX3LCO (A HOLLERITH VARIABLE C DENOTING THE COLOR OF THE THIRD HORIZ. LABEL C --IY1LCO (A HOLLERITH VARIABLE C DENOTING THE COLOR OF THE FIRST VERT. LABEL C --IY2LCO (A HOLLERITH VARIABLE C DENOTING THE COLOR OF THE SECOND VERT. LABEL C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--OCTOBER 1980. C UPDATED --MARCH 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG C CHARACTER*4 IDEFCO C CHARACTER*4 IX1LCO CHARACTER*4 IX2LCO CHARACTER*4 IX3LCO CHARACTER*4 IY1LCO CHARACTER*4 IY2LCO C CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1090 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 1IHARG(2).EQ.'COLO')GOTO1090 GOTO1900 1090 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE FIRST HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'XLAB')GOTO1100 IF(ICOM.EQ.'X1LA')GOTO1100 GOTO1199 C 1100 CONTINUE 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(IHARG(NUMARG).EQ.'COLO')GOTO1150 GOTO1160 C 1150 CONTINUE IHOLD=IDEFCO GOTO1180 C 1160 CONTINUE IHOLD=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IX1LCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE LABEL COLOR (FOR THE FIRST HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)IHOLD 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE SECOND HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2LA')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'COLO')GOTO1250 GOTO1260 C 1250 CONTINUE IHOLD=IDEFCO GOTO1280 C 1260 CONTINUE IHOLD=IHARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' IX2LCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE LABEL COLOR (FOR THE SECOND HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)IHOLD 1282 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE THIRD HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X3LA')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'COLO')GOTO1350 GOTO1360 C 1350 CONTINUE IHOLD=IDEFCO GOTO1380 C 1360 CONTINUE IHOLD=IHARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' IX3LCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE LABEL COLOR (FOR THE THIRD HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)IHOLD 1382 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1LA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1450 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 IF(IHARG(NUMARG).EQ.'COLO')GOTO1450 GOTO1460 C 1450 CONTINUE IHOLD=IDEFCO GOTO1480 C 1460 CONTINUE IHOLD=IHARG(NUMARG) GOTO1480 C 1480 CONTINUE IFOUND='YES' IY1LCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1489 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1481) 1481 FORMAT('THE LABEL COLOR (FOR THE LEFT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1482)IHOLD 1482 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1489 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2LA')GOTO1500 GOTO1599 C 1500 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1550 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 IF(IHARG(NUMARG).EQ.'COLO')GOTO1550 GOTO1560 C 1550 CONTINUE IHOLD=IDEFCO GOTO1580 C 1560 CONTINUE IHOLD=IHARG(NUMARG) GOTO1580 C 1580 CONTINUE IFOUND='YES' IY2LCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1589 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('THE LABEL COLOR (FOR THE RIGHT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582)IHOLD 1582 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1589 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH LEFT AND RIGHT VERTICAL LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'YLAB')GOTO1600 GOTO1699 C 1600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1650 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 IF(IHARG(NUMARG).EQ.'COLO')GOTO1650 GOTO1660 C 1650 CONTINUE IHOLD=IDEFCO GOTO1680 C 1660 CONTINUE IHOLD=IHARG(NUMARG) GOTO1680 C 1680 CONTINUE IFOUND='YES' IY1LCO=IHOLD IY2LCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1681) 1681 FORMAT('THE LABEL COLOR (FOR THE LEFT AND RIGHT VERTICAL ', 1'LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1682)IHOLD 1682 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1689 CONTINUE GOTO1900 C 1699 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY ALL 5 LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'LABE')GOTO1700 IF(ICOM.EQ.'XYLA')GOTO1700 IF(ICOM.EQ.'YXLA')GOTO1700 GOTO1799 C 1700 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1750 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 IF(IHARG(NUMARG).EQ.'COLO')GOTO1750 GOTO1760 C 1750 CONTINUE IHOLD=IDEFCO GOTO1780 C 1760 CONTINUE IHOLD=IHARG(NUMARG) GOTO1780 C 1780 CONTINUE IFOUND='YES' IY1LCO=IHOLD IY2LCO=IHOLD IX1LCO=IHOLD IX2LCO=IHOLD IX3LCO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1789 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1781) 1781 FORMAT('THE LABEL COLOR (FOR ALL 5 ', 1'LABELS--3 HORIZONTAL AND 2 VERTICAL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)IHOLD 1782 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1789 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPLADI(ICOM,IHARG,NUMARG, 1IDEFDI, 1IX1LDI,IX2LDI,IX3LDI,IY1LDI,IY2LDI, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE LABEL DIRECTION SWITCHES C FOR ANY OF THE 5 LABELS. C SUCH LABEL DIRECTION SWITCHES DEFINE THE C DIRECTION FOR EACH OF THE 5 LABELS. C THE CONTENTS OF A LABEL DIRECTION SWITCH ARE C A DIRECTION. C THE LABEL DIRECTION SWITCHES FOR THE 5 LABELS C ARE CONTAINED IN IX1LDI,IX2LDI,IX3LDI,IY1LDI,IY2LDI. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFFO C OUTPUT ARGUMENTS--IX1LDI (A HOLLERITH VARIABLE C DENOTING THE DIRECTION OF THE FIRST HORIZ. LABEL C --IX2LDI (A HOLLERITH VARIABLE C DENOTING THE DIRECTION OF THE SECOND HORIZ. LABEL C --IX3LDI (A HOLLERITH VARIABLE C DENOTING THE DIRECTION OF THE THIRD HORIZ. LABEL C --IY1LDI (A HOLLERITH VARIABLE C DENOTING THE DIRECTION OF THE FIRST VERT. LABEL C --IY2LDI (A HOLLERITH VARIABLE C DENOTING THE DIRECTION OF THE SECOND VERT. LABEL C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/10 C ORIGINAL VERSION--OCTOBER 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG C CHARACTER*4 IDEFDI C CHARACTER*4 IX1LDI CHARACTER*4 IX2LDI CHARACTER*4 IX3LDI CHARACTER*4 IY1LDI CHARACTER*4 IY2LDI C CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD CHARACTER*4 IHOL2 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(NUMARG.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DIRE')GOTO1090 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 1IHARG(2).EQ.'DIRE')GOTO1090 GOTO1900 1090 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE FIRST HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'XLAB')GOTO1100 IF(ICOM.EQ.'X1LA')GOTO1100 GOTO1199 C 1100 CONTINUE 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(IHARG(NUMARG).EQ.'DIRE')GOTO1150 GOTO1160 C 1150 CONTINUE IHOLD=IDEFDI GOTO1180 C 1160 CONTINUE IHOLD=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IX1LDI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE LABEL DIRECTION (FOR THE FIRST HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)IHOLD 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE SECOND HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2LA')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1250 GOTO1260 C 1250 CONTINUE IHOLD=IDEFDI GOTO1280 C 1260 CONTINUE IHOLD=IHARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' IX2LDI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE LABEL DIRECTION (FOR THE SECOND HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)IHOLD 1282 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE THIRD HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X3LA')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1350 GOTO1360 C 1350 CONTINUE IHOLD=IDEFDI GOTO1380 C 1360 CONTINUE IHOLD=IHARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' IX3LDI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE LABEL DIRECTION (FOR THE THIRD HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)IHOLD 1382 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1LA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1450 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1450 GOTO1460 C 1450 CONTINUE IHOLD='VERT' GOTO1480 C 1460 CONTINUE IHOLD=IHARG(NUMARG) GOTO1480 C 1480 CONTINUE IFOUND='YES' IY1LDI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1489 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1481) 1481 FORMAT('THE LABEL DIRECTION (FOR THE LEFT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1482)IHOLD 1482 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1489 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2LA')GOTO1500 GOTO1599 C 1500 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1550 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1550 GOTO1560 C 1550 CONTINUE IHOLD='VERT' GOTO1580 C 1560 CONTINUE IHOLD=IHARG(NUMARG) GOTO1580 C 1580 CONTINUE IFOUND='YES' IY2LDI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1589 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('THE LABEL DIRECTION (FOR THE RIGHT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582)IHOLD 1582 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1589 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH LEFT AND RIGHT VERTICAL LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'YLAB')GOTO1600 GOTO1699 C 1600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1650 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1650 GOTO1660 C 1650 CONTINUE IHOLD='VERT' GOTO1680 C 1660 CONTINUE IHOLD=IHARG(NUMARG) GOTO1680 C 1680 CONTINUE IFOUND='YES' IY1LDI=IHOLD IY2LDI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1681) 1681 FORMAT('THE LABEL DIRECTION (FOR THE LEFT AND RIGHT ', 1'VERTICAL LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1682)IHOLD 1682 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1689 CONTINUE GOTO1900 C 1699 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY ALL 5 LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'LABE')GOTO1700 IF(ICOM.EQ.'XYLA')GOTO1700 IF(ICOM.EQ.'YXLA')GOTO1700 GOTO1799 C 1700 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1750 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 IF(IHARG(NUMARG).EQ.'DIRE')GOTO1750 GOTO1760 C 1750 CONTINUE IHOLD=IDEFDI IHOL2='VERT' GOTO1780 C 1760 CONTINUE IHOLD=IHARG(NUMARG) IHOL2=IHOLD GOTO1780 C 1780 CONTINUE IFOUND='YES' IY1LDI=IHOL2 IY2LDI=IHOL2 IX1LDI=IHOLD IX2LDI=IHOLD IX3LDI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1789 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1781) 1781 FORMAT('THE LABEL DIRECTION FOR ALL 3 ', 1'HORIZONTAL LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)IHOLD 1782 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1783) 1783 FORMAT('THE LABEL DIRECTION FOR BOTH ', 1'VERITCAL LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)IHOL2 CALL DPWRST('XXX','BUG ') 1789 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPLADS(ICOM,IHARG,ARG,NUMARG, 1PDEFDS, 1PX1LDS,PX2LDS,PX3LDS,PY1LDS,PY2LDS, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE LABEL DISPLACEMENT SWITCHES C FOR ANY OF THE 5 LABELS. C SUCH LABEL DISPLACEMENT SWITCHES DEFINE THE DISPLACEMENT C FOR EACH OF THE 5 LABELS. C THE CONTENTS OF A LABEL DISPLACEMENT SWITCH ARE C A DISPLACEMENT. C THE LABEL DISPLACEMENT SWITCHES FOR THE 5 LABELS C ARE CONTAINED IN PX1LDS,PX2LDS,PX3LDS,PY1LDS,PY2LDS. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --ARG (A REAL VECTOR) C --NUMARG C --PDEFDS C OUTPUT ARGUMENTS--PX1LDS (A REAL VARIABLE C DENOTING THE DISPLACEMENT OF THE FIRST HORIZ. LABEL C --PX2LDS (A REAL VARIABLE C DENOTING THE DISPLACEMENT OF THE SECOND HORIZ. LABEL C --PX3LDS (A REAL VARIABLE C DENOTING THE DISPLACEMENT OF THE THIRD HORIZ. LABEL C --PY1LDS (A REAL VARIABLE C DENOTING THE DISPLACEMENT OF THE FIRST VERT. LABEL C --PY2LDS (A REAL VARIABLE C DENOTING THE DISPLACEMENT OF THE SECOND VERT. LABEL C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY 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 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/8 C ORIGINAL VERSION--JULY 1989. C UPDATED --MAY 1992. FIX DEFAULT VALUES C UPDATED --DECEMBER 1992. FIX MESSAGE FOR DEFAULT VALUE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG C CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) 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.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DISP')GOTO1090 CCCCC LABEL OFFSET NOW REFERS TO HORIZONTAL POSITIONING. CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'OFFS')GOTO1090 GOTO1900 1090 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE FIRST HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'XLAB')GOTO1100 IF(ICOM.EQ.'X1LA')GOTO1100 GOTO1199 C 1100 CONTINUE 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(IHARG(NUMARG).EQ.'DISP')GOTO1150 IF(IHARG(NUMARG).EQ.'OFFS')GOTO1150 GOTO1160 C 1150 CONTINUE CCCCC THE FOLLOWING LINE WAS FIXED MAY 1992 (JJF) CCCCC PHOLD=PDEFDS PHOLD=2.0+2.0*PDEFDS GOTO1180 C 1160 CONTINUE PHOLD=ARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' PX1LDS=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE LABEL DISPLACEMENT (FOR THE FIRST HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)PHOLD 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE SECOND HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2LA')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'DISP')GOTO1250 IF(IHARG(NUMARG).EQ.'OFFS')GOTO1250 GOTO1260 C 1250 CONTINUE CCCCC THE FOLLOWING LINE WAS FIXED MAY 1992 (JJF) CCCCC PHOLD=PDEFDS PHOLD=2.0+3.0*PDEFDS GOTO1280 C 1260 CONTINUE PHOLD=ARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' PX2LDS=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE LABEL DISPLACEMENT (FOR THE SECOND HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)PHOLD 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE THIRD HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X3LA')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'DISP')GOTO1350 IF(IHARG(NUMARG).EQ.'OFFS')GOTO1350 GOTO1360 C 1350 CONTINUE CCCCC THE FOLLOWING LINE WAS FIXED MAY 1992 (JJF) CCCCC PHOLD=PDEFDS PHOLD=2.0+4.0*PDEFDS GOTO1380 C 1360 CONTINUE PHOLD=ARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' PX3LDS=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE LABEL DISPLACEMENT (FOR THE THIRD HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)PHOLD 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1LA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1450 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 IF(IHARG(NUMARG).EQ.'DISP')GOTO1450 IF(IHARG(NUMARG).EQ.'OFFS')GOTO1450 GOTO1460 C 1450 CONTINUE CCCCC THE FOLLOWING LINE WAS FIXED MAY 1992 (JJF) CCCCC PHOLD=PDEFDS PHOLD=2.0+2.0*PDEFDS GOTO1480 C 1460 CONTINUE PHOLD=ARG(NUMARG) GOTO1480 C 1480 CONTINUE IFOUND='YES' PY1LDS=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1489 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1481) 1481 FORMAT('THE LABEL DISPLACEMENT (FOR THE LEFT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1482)PHOLD 1482 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1489 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2LA')GOTO1500 GOTO1599 C 1500 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1550 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 IF(IHARG(NUMARG).EQ.'DISP')GOTO1550 IF(IHARG(NUMARG).EQ.'OFFS')GOTO1550 GOTO1560 C 1550 CONTINUE CCCCC THE FOLLOWING LINE WAS FIXED MAY 1992 (JJF) CCCCC PHOLD=PDEFDS PHOLD=2.0+2.0*PDEFDS GOTO1580 C 1560 CONTINUE PHOLD=ARG(NUMARG) GOTO1580 C 1580 CONTINUE IFOUND='YES' PY2LDS=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1589 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('THE LABEL DISPLACEMENT (FOR THE RIGHT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582)PHOLD 1582 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1589 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH LEFT AND RIGHT VERTICAL LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'YLAB')GOTO1600 GOTO1699 C 1600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1650 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 IF(IHARG(NUMARG).EQ.'DISP')GOTO1650 IF(IHARG(NUMARG).EQ.'OFFS')GOTO1650 GOTO1660 C 1650 CONTINUE CCCCC THE FOLLOWING LINE WAS FIXED MAY 1992 (JJF) CCCCC PHOLD=PDEFDS PHOLD=2.0+2.0*PDEFDS GOTO1680 C 1660 CONTINUE PHOLD=ARG(NUMARG) GOTO1680 C 1680 CONTINUE IFOUND='YES' PY1LDS=PHOLD PY2LDS=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1681) 1681 FORMAT('THE LABEL DISPLACEMENT (FOR THE LEFT AND RIGHT ', 1'VERTICAL LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1682)PHOLD 1682 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1689 CONTINUE GOTO1900 C 1699 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ALL 5 LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'LABE')GOTO1700 IF(ICOM.EQ.'XYLA')GOTO1700 IF(ICOM.EQ.'YXLA')GOTO1700 GOTO1799 C 1700 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1750 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 IF(IHARG(NUMARG).EQ.'DISP')GOTO1750 IF(IHARG(NUMARG).EQ.'OFFS')GOTO1750 GOTO1760 C 1750 CONTINUE CCCCC THE FOLLOWING LINE WAS FIXED MAY 1992 (JJF) CCCCC PHOLD=PDEFDS PX1LDS=2.0+2.0*PDEFDS PX2LDS=2.0+3.0*PDEFDS PX3LDS=2.0+4.0*PDEFDS PY1LDS=2.0+2.0*PDEFDS PY2LDS=2.0+2.0*PDEFDS GOTO1780 C 1760 CONTINUE PHOLD=ARG(NUMARG) CCCCC THE FOLLOWING 5 LINES WERE ADDED MAY 1992 (JJF) PX1LDS=PHOLD PX2LDS=PHOLD PX3LDS=PHOLD PY1LDS=PHOLD PY2LDS=PHOLD GOTO1780 C 1780 CONTINUE IFOUND='YES' CCCCC THE FOLLOWING 5 LINES WERE COMMENTED OUT MAY 1992 (JJF) CCCCC PY1LDS=PHOLD CCCCC PY2LDS=PHOLD CCCCC PX1LDS=PHOLD CCCCC PX2LDS=PHOLD CCCCC PX3LDS=PHOLD C CCCCC DECEMBER 1992. FIX MESSAGE. CCCCC IF(IFEEDB.EQ.'OFF')GOTO1789 IF(IFEEDB.EQ.'OFF')GOTO1798 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1781) C1781 FORMAT('THE LABEL DISPLACEMENT (FOR ALL 5 ', CCCCC1'LABELS--3 HORIZONTAL AND 2 VERTICAL)') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1782)PHOLD C1782 FORMAT('HAS JUST BEEN SET TO ',E15.7) CCCCC CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1781) 1781 FORMAT('THE LABEL DISPLACEMENT (FOR THE FIRST HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)PX1LDS 1782 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1783) 1783 FORMAT('THE LABEL DISPLACEMENT (FOR THE SECOND HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1784)PX2LDS 1784 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1786) 1786 FORMAT('THE LABEL DISPLACEMENT (FOR THE THIRD HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1787)PX3LDS 1787 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1796) 1796 FORMAT('THE LABEL DISPLACEMENT (FOR THE LEFT AND RIGHT ', 1'VERTICAL LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1797)PY1LDS 1797 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1798 CONTINUE CCCCC END CHANGE C1789 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPLAFI(ICOM,IHARG,NUMARG, 1IDEFFI, 1IX1LFI,IX2LFI,IX3LFI,IY1LFI,IY2LFI, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE LABEL FILL SWITCHES C FOR ANY OF THE 5 LABELS. C SUCH LABEL FILL SWITCHES DEFINE THE FILL C FOR EACH OF THE 5 LABELS. C THE CONTENTS OF A LABEL FILL SWITCH ARE C A FILL. C THE LABEL FILL SWITCHES FOR THE 5 LABELS C ARE CONTAINED IN IX1LFI,IX2LFI,IX3LFI,IY1LFI,IY2LFI. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFFI C OUTPUT ARGUMENTS--IX1LFI (A HOLLERITH VARIABLE C DENOTING THE FILL OF THE FIRST HORIZ. LABEL C --IX2LFI (A HOLLERITH VARIABLE C DENOTING THE FILL OF THE SECOND HORIZ. LABEL C --IX3LFI (A HOLLERITH VARIABLE C DENOTING THE FILL OF THE THIRD HORIZ. LABEL C --IY1LFI (A HOLLERITH VARIABLE C DENOTING THE FILL OF THE FIRST VERT. LABEL C --IY2LFI (A HOLLERITH VARIABLE C DENOTING THE FILL OF THE SECOND VERT. LABEL C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--OCTOBER 1980. C UPDATED --MARCH 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG C CHARACTER*4 IDEFFI C CHARACTER*4 IX1LFI CHARACTER*4 IX2LFI CHARACTER*4 IX3LFI CHARACTER*4 IY1LFI CHARACTER*4 IY2LFI C CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FILL')GOTO1090 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 1IHARG(2).EQ.'FILL')GOTO1090 GOTO1900 1090 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE FIRST HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'XLAB')GOTO1100 IF(ICOM.EQ.'X1LA')GOTO1100 GOTO1199 C 1100 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1140 IF(IHARG(NUMARG).EQ.'OFF')GOTO1150 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150 IF(IHARG(NUMARG).EQ.'FILL')GOTO1150 GOTO1160 C 1140 CONTINUE IHOLD='SOLI' GOTO1180 C 1150 CONTINUE IHOLD=IDEFFI GOTO1180 C 1160 CONTINUE IHOLD=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IX1LFI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE LABEL FILL (FOR THE FIRST HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)IHOLD 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE SECOND HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2LA')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1240 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'FILL')GOTO1250 GOTO1260 C 1240 CONTINUE IHOLD='SOLI' GOTO1280 C 1250 CONTINUE IHOLD=IDEFFI GOTO1280 C 1260 CONTINUE IHOLD=IHARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' IX2LFI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE LABEL FILL (FOR THE SECOND HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)IHOLD 1282 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE THIRD HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X3LA')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1340 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'FILL')GOTO1350 GOTO1360 C 1340 CONTINUE IHOLD='SOLI' GOTO1380 C 1350 CONTINUE IHOLD=IDEFFI GOTO1380 C 1360 CONTINUE IHOLD=IHARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' IX3LFI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE LABEL FILL (FOR THE THIRD HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)IHOLD 1382 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1LA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1440 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 IF(IHARG(NUMARG).EQ.'FILL')GOTO1450 GOTO1460 C 1440 CONTINUE IHOLD='SOLI' GOTO1480 C 1450 CONTINUE IHOLD=IDEFFI GOTO1480 C 1460 CONTINUE IHOLD=IHARG(NUMARG) GOTO1480 C 1480 CONTINUE IFOUND='YES' IY1LFI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1489 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1481) 1481 FORMAT('THE LABEL FILL (FOR THE LEFT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1482)IHOLD 1482 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1489 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2LA')GOTO1500 GOTO1599 C 1500 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1540 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 IF(IHARG(NUMARG).EQ.'FILL')GOTO1550 GOTO1560 C 1540 CONTINUE IHOLD='SOLI' GOTO1580 C 1550 CONTINUE IHOLD=IDEFFI GOTO1580 C 1560 CONTINUE IHOLD=IHARG(NUMARG) GOTO1580 C 1580 CONTINUE IFOUND='YES' IY2LFI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1589 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('THE LABEL FILL (FOR THE RIGHT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582)IHOLD 1582 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1589 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH LEFT AND RIGHT VERTICAL LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'YLAB')GOTO1600 GOTO1699 C 1600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1640 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 IF(IHARG(NUMARG).EQ.'FILL')GOTO1650 GOTO1660 C 1640 CONTINUE IHOLD='SOLI' GOTO1680 C 1650 CONTINUE IHOLD=IDEFFI GOTO1680 C 1660 CONTINUE IHOLD=IHARG(NUMARG) GOTO1680 C 1680 CONTINUE IFOUND='YES' IY1LFI=IHOLD IY2LFI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1681) 1681 FORMAT('THE LABEL FILL (FOR THE LEFT AND RIGHT VERTICAL ', 1'LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1682)IHOLD 1682 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1689 CONTINUE GOTO1900 C 1699 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY ALL 5 LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'LABE')GOTO1700 IF(ICOM.EQ.'XYLA')GOTO1700 IF(ICOM.EQ.'YXLA')GOTO1700 GOTO1799 C 1700 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1740 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 IF(IHARG(NUMARG).EQ.'FILL')GOTO1750 GOTO1760 C 1740 CONTINUE IHOLD='SOLI' GOTO1780 C 1750 CONTINUE IHOLD=IDEFFI GOTO1780 C 1760 CONTINUE IHOLD=IHARG(NUMARG) GOTO1780 C 1780 CONTINUE IFOUND='YES' IY1LFI=IHOLD IY2LFI=IHOLD IX1LFI=IHOLD IX2LFI=IHOLD IX3LFI=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1789 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1781) 1781 FORMAT('THE LABEL FILL (FOR ALL 5 ', 1'LABELS--3 HORIZONTAL AND 2 VERTICAL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)IHOLD 1782 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1789 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPLAFO(ICOM,IHARG,NUMARG, 1IDEFFO, 1IX1LFO,IX2LFO,IX3LJU,IY1LFO,IY2LJU, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE LABEL FONT SWITCHES C FOR ANY OF THE 5 LABELS. C SUCH LABEL FONT SWITCHES DEFINE THE FONT C FOR EACH OF THE 5 LABELS. C THE CONTENTS OF A LABEL FONT SWITCH ARE C A FONT. C THE LABEL FONT SWITCHES FOR THE 5 LABELS C ARE CONTAINED IN IX1LFO,IX2LFO,IX3LJU,IY1LFO,IY2LJU. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFFO C OUTPUT ARGUMENTS--IX1LFO (A HOLLERITH VARIABLE C DENOTING THE FONT OF THE FIRST HORIZ. LABEL C --IX2LFO (A HOLLERITH VARIABLE C DENOTING THE FONT OF THE SECOND HORIZ. LABEL C --IX3LJU (A HOLLERITH VARIABLE C DENOTING THE FONT OF THE THIRD HORIZ. LABEL C --IY1LFO (A HOLLERITH VARIABLE C DENOTING THE FONT OF THE FIRST VERT. LABEL C --IY2LJU (A HOLLERITH VARIABLE C DENOTING THE FONT OF THE SECOND VERT. LABEL C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--OCTOBER 1980. C UPDATED --MARCH 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG C CHARACTER*4 IDEFFO C CHARACTER*4 IX1LFO CHARACTER*4 IX2LFO CHARACTER*4 IX3LJU CHARACTER*4 IY1LFO CHARACTER*4 IY2LJU C CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C IF(NUMARG.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FONT')GOTO1090 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 1IHARG(2).EQ.'FONT')GOTO1090 GOTO1900 1090 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE FIRST HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'XLAB')GOTO1100 IF(ICOM.EQ.'X1LA')GOTO1100 GOTO1199 C 1100 CONTINUE 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(IHARG(NUMARG).EQ.'FONT')GOTO1150 GOTO1160 C 1150 CONTINUE IHOLD=IDEFFO GOTO1180 C 1160 CONTINUE IHOLD=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IX1LFO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE LABEL FONT (FOR THE FIRST HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)IHOLD 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE SECOND HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2LA')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'FONT')GOTO1250 GOTO1260 C 1250 CONTINUE IHOLD=IDEFFO GOTO1280 C 1260 CONTINUE IHOLD=IHARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' IX2LFO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE LABEL FONT (FOR THE SECOND HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)IHOLD 1282 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE THIRD HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X3LA')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'FONT')GOTO1350 GOTO1360 C 1350 CONTINUE IHOLD=IDEFFO GOTO1380 C 1360 CONTINUE IHOLD=IHARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' IX3LJU=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE LABEL FONT (FOR THE THIRD HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)IHOLD 1382 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1LA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1450 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 IF(IHARG(NUMARG).EQ.'FONT')GOTO1450 GOTO1460 C 1450 CONTINUE IHOLD=IDEFFO GOTO1480 C 1460 CONTINUE IHOLD=IHARG(NUMARG) GOTO1480 C 1480 CONTINUE IFOUND='YES' IY1LFO=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1489 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1481) 1481 FORMAT('THE LABEL FONT (FOR THE LEFT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1482)IHOLD 1482 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1489 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2LA')GOTO1500 GOTO1599 C 1500 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1550 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 IF(IHARG(NUMARG).EQ.'FONT')GOTO1550 GOTO1560 C 1550 CONTINUE IHOLD=IDEFFO GOTO1580 C 1560 CONTINUE IHOLD=IHARG(NUMARG) GOTO1580 C 1580 CONTINUE IFOUND='YES' IY2LJU=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1589 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('THE LABEL FONT (FOR THE RIGHT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582)IHOLD 1582 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1589 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH LEFT AND RIGHT VERTICAL LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'YLAB')GOTO1600 GOTO1699 C 1600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1650 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 IF(IHARG(NUMARG).EQ.'FONT')GOTO1650 GOTO1660 C 1650 CONTINUE IHOLD=IDEFFO GOTO1680 C 1660 CONTINUE IHOLD=IHARG(NUMARG) GOTO1680 C 1680 CONTINUE IFOUND='YES' IY1LFO=IHOLD IY2LJU=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1681) 1681 FORMAT('THE LABEL FONT (FOR THE LEFT AND RIGHT VERTICAL ', 1'LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1682)IHOLD 1682 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1689 CONTINUE GOTO1900 C 1699 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY ALL 5 LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'LABE')GOTO1700 IF(ICOM.EQ.'XYLA')GOTO1700 IF(ICOM.EQ.'YXLA')GOTO1700 GOTO1799 C 1700 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1750 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 IF(IHARG(NUMARG).EQ.'FONT')GOTO1750 GOTO1760 C 1750 CONTINUE IHOLD=IDEFFO GOTO1780 C 1760 CONTINUE IHOLD=IHARG(NUMARG) GOTO1780 C 1780 CONTINUE IFOUND='YES' IY1LFO=IHOLD IY2LJU=IHOLD IX1LFO=IHOLD IX2LFO=IHOLD IX3LJU=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1789 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1781) 1781 FORMAT('THE LABEL FONT (FOR ALL 5 ', 1'LABELS--3 HORIZONTAL AND 2 VERTICAL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)IHOLD 1782 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1789 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPLAG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2, 1IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR) C C PURPOSE--GENERATE THE FOLLOWING PLOT-- C A LAG PLOT; C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1978. C UPDATED --JUNE 1978. C UPDATED --JULY 1978. C UPDATED --OCTOBER 1978. C UPDATED --APRIL 1979. C UPDATED --JANUARY 1981. C UPDATED --DECEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JUNE 1990. TEMPORARY ARRAYS TO GARBAGE COMMON C UPDATED --AUGUST 1993. FIX FORMAT STATEMENT 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 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASQ CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHVA21 CHARACTER*4 IHVA22 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C--------------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION Y2(MAXOBV) CCCCC FOLLOWING LINES ADDED JUNE, 1990 INCLUDE 'DPCOZZ.INC' EQUIVALENCE (GARBAG(IGARB1),Y1(1)) EQUIVALENCE (GARBAG(IGARB2),Y2(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 IFOUND='NO' IERROR='NO' C ISUBN1='DPLA' ISUBN2='G ' 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 C ******************************* C ** TREAT THE LAG PLOT CASE ** C ******************************* C IF(IBUGG2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPLAG--') 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)NUMARG CCCCC AUGUST 1993. FIX FORMAT STATEMENT CCC54 FORMAT('NUMARG = 'I8) 54 FORMAT('NUMARG = ',I8) CALL DPWRST('XXX','BUG ') IF(NUMARG.LE.0)GOTO69 DO61I=1,NUMARG WRITE(ICOUT,62)I,IHARG(I),IARGT(I) 62 FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 61 CONTINUE 69 CONTINUE 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 IF(NUMARG.GE.2.AND. 1ICOM.EQ.'LAG'.AND.IARGT(1).EQ.'NUMB'.AND.IHARG(2).EQ.'PLOT') 1GOTO112 IF(NUMARG.GE.1.AND. 1ICOM.EQ.'LAG'.AND.IHARG(1).EQ.'PLOT') 1GOTO111 C IFOUND='NO' GOTO9000 C 111 CONTINUE LAG=1 ILASTC=1 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 112 CONTINUE LAG=IARG(1) ILASTC=2 CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG) GOTO180 C 180 CONTINUE IFOUND='YES' GOTO190 C 190 CONTINUE C C C ******************************************************* C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS. ** C ******************************************************* C ISTEPN='2' 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 ******************************************** C ** STEP 3-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE RESPONSE VARIABLE) ** C ******************************************** C ISTEPN='3' 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) C C *********************************************************** C ** STEP 4-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS POSITIVE. ** C *********************************************************** C ISTEPN='4' IF(IBUGG2.EQ.'ON')CALL 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 DPLAG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312)IHLEFT,IHLEF2 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS ', 1'IN VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313) 313 FORMAT(' (FOR WHICH A LAG PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,314) 314 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316) 316 FORMAT(' 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)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH) 318 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 390 CONTINUE C C ***************************************** C ** STEP 5-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='5' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO490 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 ICASQ='SUBS' ILOCQ=J1 GOTO490 420 CONTINUE ICASQ='FOR' ILOCQ=J1 GOTO490 490 CONTINUE IF(IBUGG2.EQ.'OFF')GOTO495 WRITE(ICOUT,491)NUMARG,ILOCQ 491 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') 495 CONTINUE C C *********************************************** C ** STEP 6-- ** C ** CHECK FOR A VALID NUMBER ** C ** OF VARIABLES ** C ** (EITHER 1 OR 2) ** C ** ALSO, FOR THE 2-VARIABLE CASE, ** C ** CHECK THE VALIDITY ** C ** OF THE SECOND VARIABLE. ** C ** DOES THE NAME EXIST IN THE TABLE? ** C ** DOES THE NUMBER OF ELEMENTS ** C ** IN THE SECOND VARIABLE ** C ** AGREE WITH THE NUMBER OF ELEMENTS ** C ** IN THE FIRST VARIABLE? ** C *********************************************** C ISTEPN='6' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMV2=ILOCQ-1 IF(1.LE.NUMV2.AND.NUMV2.LE.MAXV2)GOTO509 GOTO550 C 509 CONTINUE ICASPL=' ' IF(NUMV2.EQ.1)ICASPL='LAG1' IF(NUMV2.EQ.2)ICASPL='LAG2' IF(NUMV2.LE.1)GOTO590 IHVA21=IHARG(2) IHVA22=IHARG2(2) IHWUSE='V' MESSAG='YES' CALL CHECKN(IHVA21,IHVA22,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ICOLV2=IVALUE(ILOCV) NVAR2=IN(ILOCV) IF(IBUGG2.EQ.'ON')WRITE(ICOUT,511)IHVA21,IHVA22,ICOLV2,NVAR2 511 FORMAT('IHVA21,IHVA22,ICOLV2,NVAR2 = ',A4,2X,A4,I8,I8) IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ') 510 CONTINUE C IF(NVAR2.NE.NLEFT)GOTO570 GOTO590 C 550 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,551) 551 FORMAT('***** ERROR IN DPLAG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552) 552 FORMAT(' FOR A 2-VARIABLE LAG PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,553) 553 FORMAT(' THE NUMBER OF VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,554) 554 FORMAT(' MUST BE EXACTLY 2 ;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,555) 555 FORMAT(' SUCH WAS NOT THE CASE HERE;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,556) 556 FORMAT(' THE SPECIFIED NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557)NUMV2 557 FORMAT(' OF VARIABLES WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,558) 558 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,559)(IANS(I),I=1,IWIDTH) 559 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 570 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,571) 571 FORMAT('***** ERROR IN DPLAG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,572) 572 FORMAT(' FOR A 2-VARIABLE LAG PLOT, ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,573) 573 FORMAT(' THE NUMBER OF ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,574) 574 FORMAT(' IN THE 2 VARIABLES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,575) 575 FORMAT(' MUST BE THE SAME; ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,576) 576 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,577)IHLEFT,IHLEF2,NLEFT 577 FORMAT(' THE FIRST VARIABLE ', 1'(',A4,A4,') HAS ',I8, 'ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,578)IHVA21,IHVA22,NVAR2 578 FORMAT(' THE SECOND VARIABLE ', 1'(',A4,A4,') HAS ',I8, 'ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,579) 579 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,580)(IANS(I),I=1,IWIDTH) 580 FORMAT(80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 590 CONTINUE C C ********************************************** C ** STEP 7-- ** C ** FORM THE VARIABLE Y1(.) ** C ** WHICH WILL CONTAIN THE FIRST VARIABLE; ** C ** ALSO, FOR A 2-VARIABLE LAG PLOT, ** C ** FORM THE VARIABLE Y2(.) ** C ** WHICH WILL CONTAIN THE SECOND VARIABLE. ** C ** FORM THESE VARIABLES BY ** C ** BRANCHING TO THE APPROPRIATE SUBCASE ** C ** (FULL, SUBSET, OR FOR). ** C ********************************************** C ISTEPN='7' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASQ.EQ.'FULL')GOTO610 IF(ICASQ.EQ.'SUBS')GOTO620 IF(ICASQ.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 IF(NQ.GE.MINN2)GOTO660 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,651) 651 FORMAT('***** ERROR IN DPLAG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,652) 652 FORMAT(' AFTER THE APPROPRIATE SUBSET HAS BEEN ', 1'EXTRACTED,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,653)IHLEFT,IHLEF2 653 FORMAT(' THE NUMBER OF OBSERVATIONS REMAINING', 1'FROM VARIABLE ',A4,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,654) 654 FORMAT(' (FOR WHICH AN AUTO OR 2-VARIABLE LAG PLOT ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,655) 655 FORMAT(' IS TO BE FORMED)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,656)MINN2 656 FORMAT(' MUST BE ',I8,' OR LARGER;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,657) 657 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,658) 658 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,659)(IANS(I),I=1,IWIDTH) 659 FORMAT(' ',80A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C 660 CONTINUE J=0 IMAX=NLEFT IF(NQ.LT.NLEFT)IMAX=NQ DO670I=1,IMAX IF(ISUB(I).EQ.0)GOTO670 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) CCCCC IF(MAXV2.LE.1)GOTO670 IF(NUMV2.LE.1)GOTO670 C IJ=MAXN*(ICOLV2-1)+I IF(ICOLV2.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOLV2.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOLV2.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOLV2.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOLV2.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOLV2.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOLV2.EQ.MAXCP6)Y2(J)=TAGPLO(I) C 670 CONTINUE NS=J C C **************************************************************** C ** STEP 9-- * C ** FORM THE VERTICAL AND HORIZONTAL AXIS * C ** VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR THE PLOT. * C ** FORM THE CURVE DESIGNATION VARIABLE D(.) . * C ** THIS WILL BE BOTH ONES FOR BOTH CASES * C ** DEFINE THE NUMBER OF PLOT POINTS (NPLOTP). * C ** DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV). * C **************************************************************** C ISTEPN='9' IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL DPLAG2(Y1,Y2,NS,ICASPL,LAG, 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 DPLAG--') 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)LAG 9014 FORMAT('LAG = ',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 IF(NUMARG.LE.0)GOTO9029 DO9021I=1,NUMARG WRITE(ICOUT,9022)I,IHARG(I),IARGT(I) 9022 FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9021 CONTINUE 9029 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPLAG2(Y1,Y2,N,ICASPL,LAG, 1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR) C C PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS C THAT WILL DEFINE C 1) A 1-VARIABLE LAG PLOT C 2) A 2-VARIABLE LAG PLOT C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1978. C UPDATED --MAY 1978. C UPDATED --JUNE 1978. C UPDATED --OCTOBER 1978. C UPDATED --MARCH 1979. C UPDATED --APRIL 1979. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICASPL CHARACTER*4 IBUGG3 CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION Y1(*) DIMENSION Y2(*) 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='DPLA' ISUBN2='G2 ' C IERROR='NO' C IF(IBUGG3.EQ.'OFF')GOTO80 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,70) 70 FORMAT('***** AT THE BEGINNING OF DPLAG2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,71)N,ICASPL,LAG 71 FORMAT('N,ICASPL,LAG = ',I8,2X,A4,I8) CALL DPWRST('XXX','BUG ') DO73I=1,N WRITE(ICOUT,74)I,Y1(I),Y2(I) 74 FORMAT('I, Y1(I), Y2(I) = ',I8,2E15.7) CALL DPWRST('XXX','BUG ') 73 CONTINUE 80 CONTINUE C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(N.GE.1)GOTO39 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31) 31 FORMAT('***** ERROR IN DPLAG2--') 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 DPLAG2--') 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 C C ******************************************************** C ** STEP 2-- ** C ** CHECK THAT THE SPECIFIED LAG IS ** C ** STRICTLY SMALLER THAN THE NUMBER OF OBSERVATIONS ** C ******************************************************** C LAG2=LAG IF(LAG.LT.0)LAG2=-LAG C IF(LAG2.LT.N)GOTO190 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,111) 111 FORMAT('***** ERROR IN DPLAG2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,112) 112 FORMAT(' THE SPECIFIED LAG EXCEEDS ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,113) 113 FORMAT(' THE NUMBER OF OBSERVATIONS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,114)LAG 114 FORMAT(' THE SPECIFIED LAG = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,115)N 115 FORMAT(' THE NUMBER OF OBSERVATIONS N = ',I8) CALL DPWRST('XXX','BUG ') GOTO9000 190 CONTINUE C C ************************************** C ** STEP 3-- ** C ** BRANCH TO THE APPROPRIATE CASE ** C ** AND DETERMINE PLOT COORDINATES ** C ************************************** C IF(ICASPL.EQ.'LAG1')GOTO1100 IF(ICASPL.EQ.'LAG2')GOTO1200 C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) 1011 FORMAT('***** INTERNAL ERROR IN DPLAG2 ', 1'AT BRANCH POINT 1011--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1012) 1012 FORMAT(' ICASPL SHOULD BE EITHER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1013) 1013 FORMAT(' LAG1 OR LAG2, BUT IS NEITHER.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1014)ICASPL 1014 FORMAT(' ICASPL = ',A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C ************************************ C ** STEP 4.1-- ** C ** FORM THE 1-VARIABLE LAG PLOT ** C ************************************ C 1100 CONTINUE IMIN=1 IMAX=N-LAG2 IF(LAG.LT.0)IMIN=1+LAG2 IF(LAG.LT.0)IMAX=N J=0 DO1110I=IMIN,IMAX J=J+1 IPLAG=I+LAG Y(J)=Y1(I) X(J)=Y1(IPLAG) D(J)=1.0 1110 CONTINUE NPLOTP=J NPLOTV=2 GOTO9000 C C ************************************ C ** STEP 4.2-- ** C ** FORM THE 2-VARIABLE LAG PLOT ** C ************************************ C 1200 CONTINUE IMIN=1 IMAX=N-LAG2 IF(LAG.LT.0)IMIN=1+LAG2 IF(LAG.LT.0)IMAX=N J=0 DO1210I=IMIN,IMAX J=J+1 IPLAG=I+LAG Y(J)=Y1(I) X(J)=Y2(IPLAG) D(J)=1.0 1210 CONTINUE NPLOTP=J 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 DPLAG2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ICASPL,LAG,N,NPLOTP,IERROR 9012 FORMAT('ICASPL,LAG,N,NPLOTP,IERROR = ',A4,3I8,2X,A4) CALL DPWRST('XXX','BUG ') DO9015I=1,NPLOTP WRITE(ICOUT,9016)I,Y(I),X(I),D(I) 9016 FORMAT('I,Y(I),X(I),D(I) = ',I8,2E15.7,F9.2) CALL DPWRST('XXX','BUG ') 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPLAJU(ICOM,IHARG,NUMARG, 1IDEFJU, 1IX1LJU,IX2LJU,IX3LJU,IY1LJU,IY2LJU, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE LABEL JUSTIFICATION SWITCHES C FOR ANY OF THE 5 LABELS. C SUCH LABEL JUSTIFICATION SWITCHES DEFINE THE C JUSTIFICATION FOR EACH OF THE 5 LABELS. C THE CONTENTS OF A LABEL JUSTIFICATION SWITCH ARE C A JUSTIFICATION. C THE LABEL JUSTIFICATION SWITCHES FOR THE 5 LABELS C ARE CONTAINED IN IX1LJU,IX2LJU,IX3LJU,IY1LJU,IY2LJU. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFFO C OUTPUT ARGUMENTS--IX1LJU (A HOLLERITH VARIABLE C DENOTING THE JUSTIFICATION OF THE FIRST HORIZ. LABEL C --IX2LJU (A HOLLERITH VARIABLE C DENOTING THE JUSTIFICATION OF THE SECOND HORIZ. LABEL C --IX3LJU (A HOLLERITH VARIABLE C DENOTING THE JUSTIFICATION OF THE THIRD HORIZ. LABEL C --IY1LJU (A HOLLERITH VARIABLE C DENOTING THE JUSTIFICATION OF THE FIRST VERT. LABEL C --IY2LJU (A HOLLERITH VARIABLE C DENOTING THE JUSTIFICATION OF THE SECOND VERT. LABEL C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/10 C ORIGINAL VERSION--OCTOBER 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG C CHARACTER*4 IDEFJU C CHARACTER*4 IX1LJU CHARACTER*4 IX2LJU CHARACTER*4 IX3LJU CHARACTER*4 IY1LJU CHARACTER*4 IY2LJU C CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD CHARACTER*4 IHOL2 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(NUMARG.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'JUST')GOTO1090 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 1IHARG(2).EQ.'JUST')GOTO1090 GOTO1900 1090 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE FIRST HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'XLAB')GOTO1100 IF(ICOM.EQ.'X1LA')GOTO1100 GOTO1199 C 1100 CONTINUE 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(IHARG(NUMARG).EQ.'JUST')GOTO1150 GOTO1160 C 1150 CONTINUE IHOLD='CEBO' GOTO1180 C 1160 CONTINUE IHOLD=IHARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' IX1LJU=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE LABEL JUSTIFICATION (FOR THE FIRST HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)IHOLD 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE SECOND HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2LA')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'JUST')GOTO1250 GOTO1260 C 1250 CONTINUE IHOLD='CEBO' GOTO1280 C 1260 CONTINUE IHOLD=IHARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' IX2LJU=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE LABEL JUSTIFICATION (FOR THE SECOND HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)IHOLD 1282 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE THIRD HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X3LA')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'JUST')GOTO1350 GOTO1360 C 1350 CONTINUE IHOLD='CEBO' GOTO1380 C 1360 CONTINUE IHOLD=IHARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' IX3LJU=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE LABEL JUSTIFICATION (FOR THE THIRD HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)IHOLD 1382 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1LA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1450 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 IF(IHARG(NUMARG).EQ.'JUST')GOTO1450 GOTO1460 C 1450 CONTINUE IHOLD='CECE' GOTO1480 C 1460 CONTINUE IHOLD=IHARG(NUMARG) GOTO1480 C 1480 CONTINUE IFOUND='YES' IY1LJU=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1489 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1481) 1481 FORMAT('THE LABEL JUSTIFICATION (FOR THE LEFT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1482)IHOLD 1482 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1489 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2LA')GOTO1500 GOTO1599 C 1500 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1550 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 IF(IHARG(NUMARG).EQ.'JUST')GOTO1550 GOTO1560 C 1550 CONTINUE IHOLD='CECE' GOTO1580 C 1560 CONTINUE IHOLD=IHARG(NUMARG) GOTO1580 C 1580 CONTINUE IFOUND='YES' IY2LJU=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1589 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('THE LABEL JUSTIFICATION (FOR THE RIGHT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582)IHOLD 1582 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1589 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH LEFT AND RIGHT VERTICAL LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'YLAB')GOTO1600 GOTO1699 C 1600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1650 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 IF(IHARG(NUMARG).EQ.'JUST')GOTO1650 GOTO1660 C 1650 CONTINUE IHOLD='CECE' GOTO1680 C 1660 CONTINUE IHOLD=IHARG(NUMARG) GOTO1680 C 1680 CONTINUE IFOUND='YES' IY1LJU=IHOLD IY2LJU=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1681) 1681 FORMAT('THE LABEL JUSTIFICATION (FOR THE LEFT AND RIGHT ', 1'VERTICAL LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1682)IHOLD 1682 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1689 CONTINUE GOTO1900 C 1699 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY ALL 5 LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'LABE')GOTO1700 IF(ICOM.EQ.'XYLA')GOTO1700 IF(ICOM.EQ.'YXLA')GOTO1700 GOTO1799 C 1700 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1750 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 IF(IHARG(NUMARG).EQ.'JUST')GOTO1750 GOTO1760 C 1750 CONTINUE IHOLD='CEBO' IHOL2='CECE' GOTO1780 C 1760 CONTINUE IHOLD=IHARG(NUMARG) IHOL2=IHOLD GOTO1780 C 1780 CONTINUE IFOUND='YES' IY1LJU=IHOL2 IY2LJU=IHOL2 IX1LJU=IHOLD IX2LJU=IHOLD IX3LJU=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1789 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1781) 1781 FORMAT('THE LABEL JUSTIFICATION FOR ALL 3 ', 1'HORIZONTAL LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)IHOLD 1782 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1783) 1783 FORMAT('THE LABEL JUSTIFICATION FOR BOTH ', 1'VERITCAL LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)IHOL2 CALL DPWRST('XXX','BUG ') 1789 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPLAOF(ICOM,IHARG,IARGT,ARG,NUMARG, 1PDEFOF, 1PX1LOF,PX2LOF,PX3LOF,PY1LOF,PY2LOF, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE LABEL OFFSETS C FOR ANY OF THE 5 LABELS. C THE LABEL OFFSET SWITCHES FOR THE LABELS C ARE CONTAINED IN THE VARIABLES-- C PX1LOF,PX2LOF,PX3LOF,PY1LOF,PY2LOF C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG C --PDEFOF (DEFAULT OFFSET) C OUTPUT ARGUMENTS-- C PX1LOF, C PX2LOF, C PX3LOF, C PY1LOF, C PY2LOF C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/10 C ORIGINAL VERSION--OCTOBER 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM 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.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'OFFS')GOTO1090 GOTO1900 1090 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE FIRST HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X1LA')GOTO1100 GOTO1199 C 1100 CONTINUE 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(IHARG(NUMARG).EQ.'OFFS')GOTO1150 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 IERROR='YES' GOTO9000 C 1150 CONTINUE HOLD1=PDEFOF GOTO1180 C 1160 CONTINUE HOLD1=ARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' PX1LOF=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE LABEL OFFSET (FOR THE FIRST HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)HOLD1 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE SECOND HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2LA')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'OFFS')GOTO1250 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1260 IERROR='YES' GOTO9000 C 1250 CONTINUE HOLD1=PDEFOF GOTO1280 C 1260 CONTINUE HOLD1=ARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' PX2LOF=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE LABEL OFFSET (FOR THE SECOND HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)HOLD1 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE THIRD HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X3LA')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'OFFS')GOTO1350 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1360 IERROR='YES' GOTO9000 C 1350 CONTINUE HOLD1=PDEFOF GOTO1380 C 1360 CONTINUE HOLD1=ARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' PX3LOF=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE LABEL OFFSET (FOR THE THIRD HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)HOLD1 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C C ***************************************************** C ** TREAT THE CASE WHEN ALL 3 ** C ** HORIZONTAL AXIS LABELS ARE TO BE CHANGED ** C ***************************************************** C IF(ICOM.EQ.'XLAB')GOTO2600 GOTO2699 C 2600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO2650 IF(IHARG(NUMARG).EQ.'OFF')GOTO2650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO2650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO2650 IF(IHARG(NUMARG).EQ.'OFFS')GOTO2650 IF(IARGT(NUMARG).EQ.'NUMB')GOTO2660 IERROR='YES' GOTO9000 C 2650 CONTINUE HOLD1=PDEFOF GOTO2680 C 2660 CONTINUE HOLD1=ARG(NUMARG) GOTO2680 C 2680 CONTINUE IFOUND='YES' PX1LOF=HOLD1 PX2LOF=HOLD1 PX3LOF=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO2689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2681) 2681 FORMAT('THE LABEL OFFSET (FOR ALL 3 HORIZONTAL AXIS LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2682)HOLD1 2682 FORMAT('HAVE JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 2689 CONTINUE GOTO1900 C 2699 CONTINUE C C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1LA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1450 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 IF(IHARG(NUMARG).EQ.'OFFS')GOTO1450 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1460 IERROR='YES' GOTO9000 C 1450 CONTINUE HOLD1=PDEFOF GOTO1480 C 1460 CONTINUE HOLD1=ARG(NUMARG) GOTO1480 C 1480 CONTINUE IFOUND='YES' PY1LOF=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO1489 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1481) 1481 FORMAT('THE LABEL OFFSET (FOR THE LEFT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1482)HOLD1 1482 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1489 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2LA')GOTO1500 GOTO1599 C 1500 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1550 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 IF(IHARG(NUMARG).EQ.'OFFS')GOTO1550 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1560 IERROR='YES' GOTO9000 C 1550 CONTINUE HOLD1=PDEFOF GOTO1580 C 1560 CONTINUE HOLD1=ARG(NUMARG) GOTO1580 C 1580 CONTINUE IFOUND='YES' PY2LOF=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO1589 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('THE LABEL OFFSET (FOR THE RIGHT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582)HOLD1 1582 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1589 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH VERTICAL AXIS LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'YLAB')GOTO1600 GOTO1699 C 1600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1650 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 IF(IHARG(NUMARG).EQ.'OFFS')GOTO1650 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1660 IERROR='YES' GOTO9000 C 1650 CONTINUE HOLD1=PDEFOF GOTO1680 C 1660 CONTINUE HOLD1=ARG(NUMARG) GOTO1680 C 1680 CONTINUE IFOUND='YES' PY1LOF=HOLD1 PY2LOF=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO1689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1681) 1681 FORMAT('THE LABEL OFFSET (FOR THE LEFT AND RIGHT VERTICAL ', 1'LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1682)HOLD1 1682 FORMAT('HAVE JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1689 CONTINUE GOTO1900 C 1699 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY ALL 5 LABELS ARE TO BE CHANGED ** C ************************************************************** C ************************************************************** C IF(ICOM.EQ.'LABE')GOTO1700 IF(ICOM.EQ.'XYLA')GOTO1700 IF(ICOM.EQ.'YXLA')GOTO1700 GOTO1799 C 1700 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1750 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 IF(IHARG(NUMARG).EQ.'OFFS')GOTO1750 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1760 IERROR='YES' GOTO9000 C 1750 CONTINUE HOLD1=PDEFOF GOTO1780 C 1760 CONTINUE HOLD1=ARG(NUMARG) GOTO1780 C 1780 CONTINUE IFOUND='YES' PX1LOF=HOLD1 PX2LOF=HOLD1 PX3LOF=HOLD1 PY1LOF=HOLD1 PY2LOF=HOLD1 C IF(IFEEDB.EQ.'OFF')GOTO1789 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1781) 1781 FORMAT('THE LABEL OFFSET (FOR ALL 5 ', 1'LABELS--3 HORIZONTAL AND 2 VERTICAL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)HOLD1 1782 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1789 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE C 9000 CONTINUE RETURN END SUBROUTINE DPLASZ(ICOM,IHARG,IARGT,ARG,NUMARG, 1PDEFHE,PDEFWI, 1PX1LHE,PX1LWI,PX1LVG,PX1LHG, 1PX2LHE,PX2LWI,PX2LVG,PX2LHG, 1PX3LHE,PX3LWI,PX3LVG,PX3LHG, 1PY1LHE,PY1LWI,PY1LVG,PY1LHG, 1PY2LHE,PY2LWI,PY2LVG,PY2LHG, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE LABEL SIZES C FOR ANY OF THE 5 LABELS. C THE LABEL SIZE SWITCHES FOR THE LABELS C ARE CONTAINED IN THE VARIABLES-- C PX1LHE,PX1LWI,PX1LVG,PX1LHG, C PX2LHE,PX2LWI,PX2LVG,PX2LHG, C PX3LHE,PX3LWI,PX3LVG,PX3LHG, C PY1LHE,PY1LWI,PY1LVG,PY1LHG, C PY2LHE,PY2LWI,PY2LVG,PY2LHG, C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG C --PDEFHE C OUTPUT ARGUMENTS-- C PX1LHE,PX1LWI,PX1LVG,PX1LHG, C PX2LHE,PX2LWI,PX2LVG,PX2LHG, C PX3LHE,PX3LWI,PX3LVG,PX3LHG, C PY1LHE,PY1LWI,PY1LVG,PY1LHG, C PY2LHE,PY2LWI,PY2LVG,PY2LHG, C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--OCTOBER 1980. C UPDATED --MARCH 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM 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.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SIZE')GOTO1090 GOTO1900 1090 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE FIRST HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'XLAB')GOTO1100 IF(ICOM.EQ.'X1LA')GOTO1100 GOTO1199 C 1100 CONTINUE 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(IHARG(NUMARG).EQ.'SIZE')GOTO1150 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160 IERROR='YES' GOTO9000 C 1150 CONTINUE HOLD1=PDEFHE HOLD2=PDEFWI GOTO1180 C 1160 CONTINUE HOLD1=ARG(NUMARG) HOLD2=HOLD1*0.5 GOTO1180 C 1180 CONTINUE IFOUND='YES' PX1LHE=HOLD1 PX1LWI=HOLD2 C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE LABEL SIZE (FOR THE FIRST HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)HOLD1 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE SECOND HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2LA')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1250 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1260 IERROR='YES' GOTO9000 C 1250 CONTINUE HOLD1=PDEFHE HOLD2=PDEFWI GOTO1280 C 1260 CONTINUE HOLD1=ARG(NUMARG) HOLD2=HOLD1*0.5 GOTO1280 C 1280 CONTINUE IFOUND='YES' PX2LHE=HOLD1 PX2LWI=HOLD2 C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE LABEL SIZE (FOR THE SECOND HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)HOLD1 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE THIRD HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X3LA')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1350 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1360 IERROR='YES' GOTO9000 C 1350 CONTINUE HOLD1=PDEFHE HOLD2=PDEFWI GOTO1380 C 1360 CONTINUE HOLD1=ARG(NUMARG) HOLD2=HOLD1*0.5 GOTO1380 C 1380 CONTINUE IFOUND='YES' PX3LHE=HOLD1 PX3LWI=HOLD2 C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE LABEL SIZE (FOR THE THIRD HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)HOLD1 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1LA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1450 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1450 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1460 IERROR='YES' GOTO9000 C 1450 CONTINUE HOLD1=PDEFHE HOLD2=PDEFWI GOTO1480 C 1460 CONTINUE HOLD1=ARG(NUMARG) HOLD2=HOLD1*0.5 GOTO1480 C 1480 CONTINUE IFOUND='YES' PY1LHE=HOLD1 PY1LWI=HOLD2 C IF(IFEEDB.EQ.'OFF')GOTO1489 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1481) 1481 FORMAT('THE LABEL SIZE (FOR THE LEFT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1482)HOLD1 1482 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1489 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2LA')GOTO1500 GOTO1599 C 1500 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1550 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1550 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1560 IERROR='YES' GOTO9000 C 1550 CONTINUE HOLD1=PDEFHE HOLD2=PDEFWI GOTO1580 C 1560 CONTINUE HOLD1=ARG(NUMARG) HOLD2=HOLD1*0.5 GOTO1580 C 1580 CONTINUE IFOUND='YES' PY2LHE=HOLD1 PY2LWI=HOLD2 C IF(IFEEDB.EQ.'OFF')GOTO1589 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('THE LABEL SIZE (FOR THE RIGHT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582)HOLD1 1582 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1589 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH VERTICAL AXIS LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'YLAB')GOTO1600 GOTO1699 C 1600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1650 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1650 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1660 IERROR='YES' GOTO9000 C 1650 CONTINUE HOLD1=PDEFHE HOLD2=PDEFWI GOTO1680 C 1660 CONTINUE HOLD1=ARG(NUMARG) HOLD2=HOLD1*0.5 GOTO1680 C 1680 CONTINUE IFOUND='YES' PY1LHE=HOLD1 PY2LHE=HOLD1 PY1LWI=HOLD2 PY2LWI=HOLD2 C IF(IFEEDB.EQ.'OFF')GOTO1689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1681) 1681 FORMAT('THE LABEL SIZE (FOR THE LEFT AND RIGHT VERTICAL ', 1'LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1682)HOLD1 1682 FORMAT('HAVE JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1689 CONTINUE GOTO1900 C 1699 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY ALL 5 LABELS ARE TO BE CHANGED ** C ************************************************************** C ************************************************************** C IF(ICOM.EQ.'LABE')GOTO1700 IF(ICOM.EQ.'XYLA')GOTO1700 IF(ICOM.EQ.'YXLA')GOTO1700 GOTO1799 C 1700 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1750 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 IF(IHARG(NUMARG).EQ.'SIZE')GOTO1750 IF(IARGT(NUMARG).EQ.'NUMB')GOTO1760 IERROR='YES' GOTO9000 C 1750 CONTINUE HOLD1=PDEFHE HOLD2=PDEFWI GOTO1780 C 1760 CONTINUE HOLD1=ARG(NUMARG) HOLD2=HOLD1*0.5 GOTO1780 C 1780 CONTINUE IFOUND='YES' PY1LHE=HOLD1 PY2LHE=HOLD1 PX1LHE=HOLD1 PX2LHE=HOLD1 PX3LHE=HOLD1 PY1LWI=HOLD2 PY2LWI=HOLD2 PX1LWI=HOLD2 PX2LWI=HOLD2 PX3LWI=HOLD2 C IF(IFEEDB.EQ.'OFF')GOTO1789 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1781) 1781 FORMAT('THE LABEL SIZE (FOR ALL 5 ', 1'LABELS--3 HORIZONTAL AND 2 VERTICAL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)HOLD1 1782 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1789 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE C PX1LVG=PX1LHE*0.375 PX2LVG=PX2LHE*0.375 PX3LVG=PX3LHE*0.375 PY1LVG=PY1LHE*0.375 PY2LVG=PY2LHE*0.375 C PX1LHG=PX1LHE*0.125 PX2LHG=PX2LHE*0.125 PX3LHG=PX3LHE*0.125 PY1LHG=PY1LHE*0.125 PY2LHG=PY2LHE*0.125 C 9000 CONTINUE RETURN END SUBROUTINE DPLAT1(IHEAD,NHEAD,CAPTN,NCAP,IFLAG1) C C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING C LATEK OUTPUT. THIS ROUTINE IS USED TO INITIATE C THE LATEK OUTPUT AND STARTS THE FIRST TABLE. C THE ONLY OPTIONAL ELEMENT IS THE CAPTION. C INPUT ARGUMENTS--IHEAD = THE CHARACTER STRING CONTAINING C THE TEXT FOR THE HEADER C --NHEAD = THE INTEGER NUMBER THAT SPECIFIES C THE NUMBER OF CHARACTERS IN THE C HEADER. C --CAPTN = THE CHARACTER STRING CONTAINING C THE CAPTION. C --NCAP = THE INTEGER NUMBER THAT SPECIFIES C THE NUMBER OF CHARACTERS IN THE C CAPTION. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY 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 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--2005/2 C ORIGINAL VERSION--FEBRUARY 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*(*) CAPTN CHARACTER*(*) IHEAD C LOGICAL IFLAG1 C CHARACTER*1 IBASLC CHARACTER*10 IFORMT C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C STEP 1: END ASIS MODE AND WRITE A HEADER C CALL DPCONA(92,IBASLC) 999 FORMAT(1X) 8003 FORMAT(A1,'begin{table}') 8007 FORMAT('$ ',A1,1X,A1,' $ ',A1,A1,' ') 8009 FORMAT(A1,'begin{center}') 8013 FORMAT(A1,'end{center}') C IF(IFLAG1)THEN WRITE(ICOUT,8003)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ENDIF C IF(NHEAD.GE.1)THEN WRITE(ICOUT,8009)IBASLC CALL DPWRST('XXX','WRIT') IFORMT=' ' IFORMT(1:5)='(A )' WRITE(IFORMT(3:4),'(I2)')NHEAD WRITE(ICOUT,8005)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8006) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8013)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ENDIF C C STEP 2: START TABLE AND DEFINE A CAPTION C 8005 FORMAT('{',A1,'bf ') 8006 FORMAT(' }') 8011 FORMAT('{',A1,'bf ') 8015 FORMAT('} ',A1,A1) C IF(NCAP.GT.0)THEN WRITE(ICOUT,8009)IBASLC CALL DPWRST('XXX','WRIT') IFORMT=' ' IFORMT(1:5)='(A )' WRITE(IFORMT(3:4),'(I2)')NCAP WRITE(ICOUT,8011)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,IFORMT)CAPTN(1:NCAP) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8006) 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,8013)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ENDIF C RETURN END SUBROUTINE DPLATZ(IFLAG1,IFLAG2,IFLAG3,NHEAD) C C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING C LATEK OUTPUT. THIS ROUTINE IS USED TO CLOSE THE C CURRENT TABLE AND TERMINATE THE LATEK OUTPUT. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY 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 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--2005/2 C ORIGINAL VERSION--FEBRUARY 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C LOGICAL IFLAG1 LOGICAL IFLAG2 LOGICAL IFLAG3 C CHARACTER*1 IBASLC C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C STEP 1: END THE CURRENT TABLE C 999 FORMAT(1X) 8091 FORMAT(A1,'end{tabular}') 8092 FORMAT(A1,'end{center}') 8093 FORMAT(A1,'end{table}') CALL DPCONA(92,IBASLC) IF(IFLAG1)THEN WRITE(ICOUT,8091)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8092)IBASLC CALL DPWRST('XXX','WRIT') ENDIF IF(IFLAG3)THEN WRITE(ICOUT,8093)IBASLC CALL DPWRST('XXX','WRIT') ENDIF C C STEP 2: RESET "ASIS" MODE C 8099 FORMAT(A1,'begin{verbatim}') IF(IFLAG2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8099)IBASLC CALL DPWRST('XXX','WRIT') ENDIF C RETURN END SUBROUTINE DPLAT4(IVALUE,NCHAR,NHEAD,IFLAG1,IFLAG2,IFLAG3) C C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING C LATEK OUTPUT. THIS ROUTINE IS USED TO GENERATE C A HEADER ROW FOR A TABLE. YOU CAN ALSO OPTIONALLY C ADD A RULE LINE BEFORE OR AFTER THE HEADER. C C INPUT ARGUMENTS--IVALUE = THE CHARACTER STRING ARRAY C CONTAINING THE TEXT FOR THE C HEADER VALUES. C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES C THE NUMBER OF CHARACTERS IN THE C HEADER VALUES. C --NHEAD = THE INTEGER VALUE THAT SPECIFIES C THE NUMBER OF HEADER VALUES. C --IFLAG1 = A LOGICAL VALUE THAT SPECIFIES C WHETHER A RULE LINE IS DRAWN BEFORE C THE HEADER. C --IFLAG2 = A LOGICAL VALUE THAT SPECIFIES C WHETHER A RULE LINE IS DRAWN AFTER C THE HEADER. C --IFLAG3 = A LOGICAL VALUE THAT SPECIFIES C WHETHER THE "CENTER" AND "TABULAR" C FIELDS ARE WRITTEN (SET TO FALSE FOR C SECOND AND GREATER LINES OF MULIT-LINE C HEADERS. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY 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 C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*(*) IVALUE(NHEAD) INTEGER NCHAR(NHEAD) C PARAMETER (MAXHED=50) INTEGER IWIDTH(MAXHED) INTEGER NUMDIG(MAXHED) CHARACTER*8 ALIGN(MAXHED) CHARACTER*8 VALIGN(MAXHED) COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN C LOGICAL IFLAG1 LOGICAL IFLAG2 LOGICAL IFLAG3 C CHARACTER*1 IBASLC CHARACTER*1 IAMP CHARACTER*1 IQUOTE CHARACTER*20 IFORMT 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 999 FORMAT(1X) CALL DPCONA(92,IBASLC) CALL DPCONA(39,IQUOTE) IAMP='&' C C STEP 2: GENERATE THE HEADER ROW C 8020 FORMAT(A1,'begin{center}') 8021 FORMAT(A1,'begin{tabular}') 8040 FORMAT(A1,'hline') 8050 FORMAT(2X,A1,A1) 8060 FORMAT(2X,A1) IF(NHEAD.GE.1)THEN IF(IFLAG3)THEN WRITE(ICOUT,8020)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8021)IBASLC CALL DPWRST('XXX','WRIT') IFORMT=' ' IFORMT(1:3)='( {' IFORMT(2:2)=IQUOTE ICNT=3 DO8110I=1,NHEAD ICNT=ICNT+1 IFORMT(ICNT:ICNT)=ALIGN(I)(1:1) 8110 CONTINUE IFORMT(ICNT+1:ICNT+3)='} )' IFORMT(ICNT+2:ICNT+2)=IQUOTE WRITE(ICOUT,IFORMT) CALL DPWRST('XXX','WRIT') ENDIF C IF(IFLAG1)THEN WRITE(ICOUT,8040)IBASLC CALL DPWRST('XXX','WRIT') ENDIF C DO8120I=1,NHEAD IFORMT=' ' IF(I.LT.NHEAD)THEN IF(NCHAR(I).LE.0)THEN CCCCC WRITE(ICOUT,8060)IAMP CCCCC CALL DPWRST('XXX','WRIT') ELSE IFORMT(1:11)='(A ,1X,A1)' WRITE(IFORMT(3:4),'(I2)')NCHAR(I) WRITE(ICOUT,IFORMT)IVALUE(I)(1:NCHAR(I)),IAMP CALL DPWRST('XXX','WRIT') ENDIF ELSE IF(NCHAR(I).GT.0)THEN IFORMT(1:14)='(A ,2X,A1,A1)' WRITE(IFORMT(3:4),'(I2)')NCHAR(I) WRITE(ICOUT,IFORMT)IVALUE(I)(1:NCHAR(I)),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSE CCCCC WRITE(ICOUT,8050)IBASLC,IBASLC CCCCC CALL DPWRST('XXX','WRIT') ENDIF ENDIF 8120 CONTINUE IF(IFLAG2)THEN WRITE(ICOUT,8040)IBASLC CALL DPWRST('XXX','WRIT') ENDIF ENDIF C RETURN END SUBROUTINE DPLAT5(IVALUE,NCHAR,AVALUE,NHEAD,IFLAG1) C C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING C LATEX OUTPUT. THIS ROUTINE IS USED TO GENERATE C A DATA ROW FOR A TABLE. THE FIRST FIELD CAN C BE A TEXT VALUE (FOR A ROW LABEL). C C INPUT ARGUMENTS--IVALUE = THE CHARACTER STRING CONTAINING C THE TEXT FOR THE FIRST COLUMN. C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES C THE NUMBER OF CHARACTERS IN THE C FIRST TEXT FIELD. C --AVALUE = A REAL ARRAY CONTAINING THE DATA C TO BE GENERATED. C --NHEAD = THE INTEGER VALUE THAT SPECIFIES C THE NUMBER OF NUMERIC VALUES. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY 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 C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*(*) IVALUE REAL AVALUE(NHEAD) INTEGER NCHAR C LOGICAL IFLAG1 C PARAMETER (MAXHED=50) INTEGER IWIDTH(MAXHED) INTEGER NUMDIG(MAXHED) CHARACTER*8 ALIGN(MAXHED) CHARACTER*8 VALIGN(MAXHED) COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN C CHARACTER*20 IFORMT CHARACTER*1 IBASLC CHARACTER*1 IAMP C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C STEP 3: DEFINE A DATA ROW C CALL DPCONA(92,IBASLC) IAMP='&' C C STEP 1: FIRST COLUMN MAY BE A ROW LABEL C IF(NCHAR.GT.0)THEN IFORMT=' ' IFORMT(1:11)='(A ,A1)' WRITE(IFORMT(3:4),'(I2)')NCHAR WRITE(ICOUT,IFORMT)IVALUE(1:NCHAR),IAMP CALL DPWRST('XXX','WRIT') ENDIF C 8031 FORMAT(G15.7,' & ') 8033 FORMAT(I12,' & ') 8035 FORMAT(' & ') 8131 FORMAT(G15.7,2X,A1,A1) 8231 FORMAT(2X,A1,A1) 8133 FORMAT(I12,2X,A1,A1) 8135 FORMAT(' ',2X,A1,A1) 8235 FORMAT(' & ') 8040 FORMAT(A1,'hline') IF(NHEAD.GE.1)THEN DO100I=1,NHEAD IFORMT=' ' IF(I.LT.NHEAD)THEN IF(NUMDIG(I).GT.0)THEN IFORMT(1:13)='(F15. ,1X,A1)' WRITE(IFORMT(6:6),'(I1)')MIN(NUMDIG(I),9) WRITE(ICOUT,IFORMT)AVALUE(I),IAMP CALL DPWRST('XXX','WRIT') ELSEIF(NUMDIG(I).EQ.0)THEN WRITE(ICOUT,8033)INT(AVALUE(I)+0.5) CALL DPWRST('XXX','WRIT') ELSEIF(NUMDIG(I).EQ.-1)THEN WRITE(ICOUT,8035) CALL DPWRST('XXX','WRIT') ELSEIF(NUMDIG(I).EQ.-2)THEN WRITE(ICOUT,8031)AVALUE(I) CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,8235)IAMP CALL DPWRST('XXX','WRIT') ENDIF ELSE IF(NUMDIG(I).GT.0)THEN IFORMT(1:16)='(F15. ,2X,A1,A1)' WRITE(IFORMT(6:6),'(I1)')MIN(NUMDIG(I),9) WRITE(ICOUT,IFORMT)AVALUE(I),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSEIF(NUMDIG(I).EQ.0)THEN WRITE(ICOUT,8133)INT(AVALUE(I)+0.5),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSEIF(NUMDIG(I).EQ.-1)THEN WRITE(ICOUT,8135)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSEIF(NUMDIG(I).EQ.-2)THEN WRITE(ICOUT,8131)AVALUE(I),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,8231)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ENDIF END IF 100 CONTINUE C IF(IFLAG1)THEN WRITE(ICOUT,8040)IBASLC CALL DPWRST('XXX','WRIT') ENDIF C ENDIF C RETURN END SUBROUTINE DPLAT6(IFLAG1,IFLAG2,IFLAG3) C C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING C LATEK OUTPUT. THIS ROUTINE IS USED TO EITHER C INITIATE OR END A TABLE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY 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 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--2005/2 C ORIGINAL VERSION--FEBRUARY 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C C--------------------------------------------------------------------- C LOGICAL IFLAG1 LOGICAL IFLAG2 LOGICAL IFLAG3 C CHARACTER*1 IBASLC C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C FOLLOWING ADDS A RULE LINE C 8001 FORMAT(A1,'end{verbatim}') 8020 FORMAT(A1,'begin{table}') 8040 FORMAT(A1,'end{table}') CALL DPCONA(92,IBASLC) C IF(IFLAG3)THEN WRITE(ICOUT,8001)IBASLC CALL DPWRST('XXX','WRIT') ENDIF IF(IFLAG1)THEN WRITE(ICOUT,8020)IBASLC CALL DPWRST('XXX','WRIT') ENDIF IF(IFLAG2)THEN WRITE(ICOUT,8040)IBASLC CALL DPWRST('XXX','WRIT') ENDIF C RETURN END SUBROUTINE DPLAT7(IHEAD,NHEAD,AVAL) C C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING C LATEK OUTPUT. THIS ROUTINE IS USED TO WRITE A C A SINGLE LINE OF OUTPUT. C INPUT ARGUMENTS--IHEAD = THE CHARACTER STRING CONTAINING C THE TEXT FOR THE LINE C --NHEAD = THE INTEGER NUMBER THAT SPECIFIES C THE NUMBER OF CHARACTERS IN THE C LINE. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY 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 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--2005/2 C ORIGINAL VERSION--FEBRUARY 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*(*) IHEAD C CHARACTER*1 IBASLC CHARACTER*25 IFORMT C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C STEP 1: END ASIS MODE AND WRITE A HEADER C 999 FORMAT(1X) CALL DPCONA(92,IBASLC) C C STEP 2: START TABLE AND DEFINE A CAPTION C 8005 FORMAT('{',A1,'bf ') 8006 FORMAT(' }',2X,A1,A1) C IF(NHEAD.GE.1)THEN IFORMT=' ' IF(AVAL.NE.CPUMIN)THEN IFORMT(1:23)='(A ,2X,F12.5,2X,A1,A1)' WRITE(IFORMT(3:4),'(I2)')NHEAD WRITE(ICOUT,8005)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD),AVAL CALL DPWRST('XXX','WRIT') ELSE IFORMT(1:14)='(A ,2X,A1,A1)' WRITE(IFORMT(3:4),'(I2)')NHEAD WRITE(ICOUT,8005)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD) CALL DPWRST('XXX','WRIT') ENDIF WRITE(ICOUT,8006)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ENDIF C RETURN END SUBROUTINE DPLAT8(IHEAD,NHEAD,IFLAG1,IFLAG2) C C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING C LATEK OUTPUT. THIS ROUTINE IS USED TO INITIATE C THE LATEK OUTPUT AND GENERATE AN OVERALL TITLE. C INPUT ARGUMENTS--IHEAD = THE CHARACTER STRING CONTAINING C THE TEXT FOR THE HEADER C --NHEAD = THE INTEGER NUMBER THAT SPECIFIES C THE NUMBER OF CHARACTERS IN THE C HEADER. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY 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 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--2005/2 C ORIGINAL VERSION--FEBRUARY 2005. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C LOGICAL IFLAG1 LOGICAL IFLAG2 C CHARACTER*(*) IHEAD C CHARACTER*1 IBASLC CHARACTER*10 IFORMT C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C STEP 1: END ASIS MODE AND WRITE A HEADER C CALL DPCONA(92,IBASLC) 999 FORMAT(1X) 8001 FORMAT(A1,'end{verbatim}') 8005 FORMAT('{',A1,'bf ') 8006 FORMAT(' }') 8007 FORMAT('$ ',A1,1X,A1,' $ ',A1,A1,' ') 8009 FORMAT(A1,'begin{center}') 8013 FORMAT(A1,'end{center}') IF(IFLAG1)THEN WRITE(ICOUT,8001)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ENDIF C IF(NHEAD.GE.1)THEN WRITE(ICOUT,8009)IBASLC CALL DPWRST('XXX','WRIT') IFORMT=' ' IFORMT(1:5)='(A )' WRITE(IFORMT(3:4),'(I2)')NHEAD WRITE(ICOUT,8005)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,IFORMT)IHEAD(1:NHEAD) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,8006) 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,8013)IBASLC CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') ENDIF C RETURN END SUBROUTINE DPLAT9(IVALUE,NCHAR,AVALUE,NHEAD,IFLAG1,IVAL2,NCHAR2) C C PURPOSE--THIS ROUTINE IS A UTILUTY ROUTINE FOR CREATING C LATEX OUTPUT. THIS ROUTINE IS USED TO GENERATE C A DATA ROW FOR A TABLE. THE FIRST FIELD CAN C BE A TEXT VALUE (FOR A ROW LABEL). C C INPUT ARGUMENTS--IVALUE = THE CHARACTER STRING CONTAINING C THE TEXT FOR THE FIRST COLUMN. C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES C THE NUMBER OF CHARACTERS IN THE C FIRST TEXT FIELD. C --AVALUE = A REAL ARRAY CONTAINING THE DATA C TO BE GENERATED. C --NHEAD = THE INTEGER VALUE THAT SPECIFIES C THE NUMBER OF NUMERIC VALUES. C --IVAL2 = THE CHARACTER STRING CONTAINING C THE TEXT FOR THE LAST COLUMN. C --NCHAR = THE INTEGER ARRAY THAT SPECIFIES C THE NUMBER OF CHARACTERS IN THE C LAST TEXT FIELD. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY 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--2006/11 C ORIGINAL VERSION--NOVEMBER 2006. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*(*) IVALUE CHARACTER*(*) IVAL2 REAL AVALUE(NHEAD) INTEGER NCHAR INTEGER NCHAR2 C LOGICAL IFLAG1 C PARAMETER (MAXHED=50) INTEGER IWIDTH(MAXHED) INTEGER NUMDIG(MAXHED) CHARACTER*8 ALIGN(MAXHED) CHARACTER*8 VALIGN(MAXHED) COMMON/HTML4/IWIDTH,NUMDIG,ALIGN,VALIGN C CHARACTER*20 IFORMT CHARACTER*1 IBASLC CHARACTER*1 IAMP C C--------------------------------------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C C STEP 3: DEFINE A DATA ROW C CALL DPCONA(92,IBASLC) IAMP='&' C C STEP 1: FIRST COLUMN MAY BE A ROW LABEL C IF(NCHAR.GT.0)THEN IFORMT=' ' IFORMT(1:11)='(A ,A1)' WRITE(IFORMT(3:4),'(I2)')NCHAR WRITE(ICOUT,IFORMT)IVALUE(1:NCHAR),IAMP CALL DPWRST('XXX','WRIT') ENDIF C 8031 FORMAT(G15.7,' & ') 8033 FORMAT(I12,' & ') 8035 FORMAT(' & ') 8131 FORMAT(G15.7,2X,A1,A1) 8231 FORMAT(2X,A1,A1) 8133 FORMAT(I12,2X,A1,A1) 8135 FORMAT(' ',2X,A1,A1) 8235 FORMAT(' & ') 8040 FORMAT(A1,'hline') IF(NHEAD.GE.1)THEN DO100I=1,NHEAD IFORMT=' ' IF(I.LE.NHEAD)THEN IF(NUMDIG(I).GT.0)THEN IFORMT(1:13)='(F15. ,1X,A1)' WRITE(IFORMT(6:6),'(I1)')MIN(NUMDIG(I),9) WRITE(ICOUT,IFORMT)AVALUE(I),IAMP CALL DPWRST('XXX','WRIT') ELSEIF(NUMDIG(I).EQ.0)THEN WRITE(ICOUT,8033)INT(AVALUE(I)+0.5) CALL DPWRST('XXX','WRIT') ELSEIF(NUMDIG(I).EQ.-1)THEN WRITE(ICOUT,8035) CALL DPWRST('XXX','WRIT') ELSEIF(NUMDIG(I).EQ.-2)THEN WRITE(ICOUT,8031)AVALUE(I) CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,8235)IAMP CALL DPWRST('XXX','WRIT') ENDIF ELSE IF(NUMDIG(I).GT.0)THEN IFORMT(1:16)='(F15. ,2X,A1,A1)' WRITE(IFORMT(6:6),'(I1)')MIN(NUMDIG(I),9) WRITE(ICOUT,IFORMT)AVALUE(I),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSEIF(NUMDIG(I).EQ.0)THEN WRITE(ICOUT,8133)INT(AVALUE(I)+0.5),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSEIF(NUMDIG(I).EQ.-1)THEN WRITE(ICOUT,8135)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSEIF(NUMDIG(I).EQ.-2)THEN WRITE(ICOUT,8131)AVALUE(I),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ELSE WRITE(ICOUT,8231)IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ENDIF END IF 100 CONTINUE C IF(NCHAR2.GT.0)THEN IFORMT=' ' IFORMT(1:11)='(A ,A1,A1)' WRITE(IFORMT(3:4),'(I2)')NCHAR2 WRITE(ICOUT,IFORMT)IVAL2(1:NCHAR2),IBASLC,IBASLC CALL DPWRST('XXX','WRIT') ENDIF C IF(IFLAG1)THEN WRITE(ICOUT,8040)IBASLC CALL DPWRST('XXX','WRIT') ENDIF C ENDIF C RETURN END SUBROUTINE DPLATH(ICOM,IHARG,ARG,NUMARG, 1PDEFTH, 1PX1LTH,PX2LTH,PX3LTH,PY1LTH,PY2LTH, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE LABEL THICKNESS SWITCHES C FOR ANY OF THE 5 LABELS. C SUCH LABEL THICKNESS SWITCHES DEFINE THE THICKNESS C FOR EACH OF THE 5 LABELS. C THE CONTENTS OF A LABEL THICKNESS SWITCH ARE C A THICKNESS. C THE LABEL THICKNESS SWITCHES FOR THE 5 LABELS C ARE CONTAINED IN PX1LTH,PX2LTH,PX3LTH,PY1LTH,PY2LTH. C INPUT ARGUMENTS--ICOM C --IHARG (A HOLLERITH VECTOR) C --ARG (A REAL VECTOR) C --NUMARG C --PDEFTH C OUTPUT ARGUMENTS--PX1LTH (A REAL VARIABLE C DENOTING THE THICKNESS OF THE FIRST HORIZ. LABEL C --PX2LTH (A REAL VARIABLE C DENOTING THE THICKNESS OF THE SECOND HORIZ. LABEL C --PX3LTH (A REAL VARIABLE C DENOTING THE THICKNESS OF THE THIRD HORIZ. LABEL C --PY1LTH (A REAL VARIABLE C DENOTING THE THICKNESS OF THE FIRST VERT. LABEL C --PY2LTH (A REAL VARIABLE C DENOTING THE THICKNESS OF THE SECOND VERT. LABEL C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/2 C ORIGINAL VERSION--JANUARY 1989. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ICOM CHARACTER*4 IHARG C CHARACTER*4 IFOUND CHARACTER*4 IERROR C C--------------------------------------------------------------------- C DIMENSION IHARG(*) 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.LE.0)GOTO1900 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'THIC')GOTO1090 IF(NUMARG.GE.2.AND.IHARG(1).EQ.'MARK'.AND. 1IHARG(2).EQ.'THIC')GOTO1090 GOTO1900 1090 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE FIRST HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'XLAB')GOTO1100 IF(ICOM.EQ.'X1LA')GOTO1100 GOTO1199 C 1100 CONTINUE 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(IHARG(NUMARG).EQ.'THIC')GOTO1150 GOTO1160 C 1150 CONTINUE PHOLD=PDEFTH GOTO1180 C 1160 CONTINUE PHOLD=ARG(NUMARG) GOTO1180 C 1180 CONTINUE IFOUND='YES' PX1LTH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE LABEL THICKNESS (FOR THE FIRST HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)PHOLD 1182 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1900 C 1199 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE SECOND HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X2LA')GOTO1200 GOTO1299 C 1200 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1250 IF(IHARG(NUMARG).EQ.'OFF')GOTO1250 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1250 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1250 IF(IHARG(NUMARG).EQ.'THIC')GOTO1250 GOTO1260 C 1250 CONTINUE PHOLD=PDEFTH GOTO1280 C 1260 CONTINUE PHOLD=ARG(NUMARG) GOTO1280 C 1280 CONTINUE IFOUND='YES' PX2LTH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1289 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1281) 1281 FORMAT('THE LABEL THICKNESS (FOR THE SECOND HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1282)PHOLD 1282 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1289 CONTINUE GOTO1900 C 1299 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE THIRD HORIZONTAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'X3LA')GOTO1300 GOTO1399 C 1300 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1350 IF(IHARG(NUMARG).EQ.'OFF')GOTO1350 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1350 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1350 IF(IHARG(NUMARG).EQ.'THIC')GOTO1350 GOTO1360 C 1350 CONTINUE PHOLD=PDEFTH GOTO1380 C 1360 CONTINUE PHOLD=ARG(NUMARG) GOTO1380 C 1380 CONTINUE IFOUND='YES' PX3LTH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1389 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1381) 1381 FORMAT('THE LABEL THICKNESS (FOR THE THIRD HORIZONTAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1382)PHOLD 1382 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1389 CONTINUE GOTO1900 C 1399 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE LEFT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y1LA')GOTO1400 GOTO1499 C 1400 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1450 IF(IHARG(NUMARG).EQ.'OFF')GOTO1450 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1450 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1450 IF(IHARG(NUMARG).EQ.'THIC')GOTO1450 GOTO1460 C 1450 CONTINUE PHOLD=PDEFTH GOTO1480 C 1460 CONTINUE PHOLD=ARG(NUMARG) GOTO1480 C 1480 CONTINUE IFOUND='YES' PY1LTH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1489 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1481) 1481 FORMAT('THE LABEL THICKNESS (FOR THE LEFT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1482)PHOLD 1482 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1489 CONTINUE GOTO1900 C 1499 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY THE RIGHT VERTICAL LABEL IS TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'Y2LA')GOTO1500 GOTO1599 C 1500 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1550 IF(IHARG(NUMARG).EQ.'OFF')GOTO1550 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1550 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1550 IF(IHARG(NUMARG).EQ.'THIC')GOTO1550 GOTO1560 C 1550 CONTINUE PHOLD=PDEFTH GOTO1580 C 1560 CONTINUE PHOLD=ARG(NUMARG) GOTO1580 C 1580 CONTINUE IFOUND='YES' PY2LTH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1589 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1581) 1581 FORMAT('THE LABEL THICKNESS (FOR THE RIGHT VERTICAL ', 1'LABEL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1582)PHOLD 1582 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1589 CONTINUE GOTO1900 C 1599 CONTINUE C C ************************************************************** C ** TREAT THE CASE WHEN ** C ** BOTH LEFT AND RIGHT VERTICAL LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'YLAB')GOTO1600 GOTO1699 C 1600 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1650 IF(IHARG(NUMARG).EQ.'OFF')GOTO1650 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1650 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1650 IF(IHARG(NUMARG).EQ.'THIC')GOTO1650 GOTO1660 C 1650 CONTINUE PHOLD=PDEFTH GOTO1680 C 1660 CONTINUE PHOLD=ARG(NUMARG) GOTO1680 C 1680 CONTINUE IFOUND='YES' PY1LTH=PHOLD PY2LTH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1689 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1681) 1681 FORMAT('THE LABEL THICKNESS (FOR THE LEFT AND RIGHT VERTICAL ', 1'LABELS)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1682)PHOLD 1682 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1689 CONTINUE GOTO1900 C 1699 CONTINUE C ************************************************************** C ** TREAT THE CASE WHEN ** C ** ONLY ALL 5 LABELS ARE TO BE CHANGED ** C ************************************************************** C IF(ICOM.EQ.'LABE')GOTO1700 IF(ICOM.EQ.'XYLA')GOTO1700 IF(ICOM.EQ.'YXLA')GOTO1700 GOTO1799 C 1700 CONTINUE IF(IHARG(NUMARG).EQ.'ON')GOTO1750 IF(IHARG(NUMARG).EQ.'OFF')GOTO1750 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1750 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1750 IF(IHARG(NUMARG).EQ.'THIC')GOTO1750 GOTO1760 C 1750 CONTINUE PHOLD=PDEFTH GOTO1780 C 1760 CONTINUE PHOLD=ARG(NUMARG) GOTO1780 C 1780 CONTINUE IFOUND='YES' PY1LTH=PHOLD PY2LTH=PHOLD PX1LTH=PHOLD PX2LTH=PHOLD PX3LTH=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1789 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1781) 1781 FORMAT('THE LABEL THICKNESS (FOR ALL 5 ', 1'LABELS--3 HORIZONTAL AND 2 VERTICAL)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1782)PHOLD 1782 FORMAT('HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1789 CONTINUE GOTO1900 C 1799 CONTINUE C 1900 CONTINUE RETURN END SUBROUTINE DPLATT(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 LATTICES 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 VERTICES C OF THE LOWER LEFT CORNER OF THE LATTICE, C THE X AND Y INCREMENTS OF THE LATTICE C AND THE UPPER RIGHT CORNER OF THE LATTICE. C LATTICE X1 Y1 XINC YINC X2 Y2 C NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 3 C AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*3 = 6. C NOTE-- THE FOLLOWING GENERALIZATIONS AND COMMENTS NEED CORRECTING 5/5/87 C NOTE--IF 4 NUMBERS ARE PROVIDED, C THEN THE DRAWN LATTICE WILL GO C FROM THE LAST CURSOR POSITION C (ASSUMED TO BE AT VERTEX 1) C THROUGH THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE FIRST AND SECOND NUMBERS C (ASSUMED TO BE AT VERTEX 2) C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE THIRD AND FOURTH NUMBERS C (ASSUMED TO BE AT VERTEX 3) C AND CONTINUING BACK THE START POINT TO CLOSE THE LATTICE. C NOTE--IF 6 NUMBERS ARE PROVIDED, C THEN THE DRAWN LATTICE WILL GO C FROM THE ABSOLUTE (X,Y) POSITION C AS RESULTING FORM THE FIRST AND SECOND NUMBERS C (ASSUMED TO BE AT VERTEX 1) C THROUGH THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE THIRD AND FOURTH NUMBERS C (ASSUMED TO BE AT VERTEX 2) C TO THE (X,Y) POINT C (EITHER ABSOLUTE OR RELATIVE) C AS DEFINED BY THE FIFTH AND SIXTH NUMBERS C (ASSUMED TO BE AT VERTEX 3) C AND THEN CONTINUING BACK THE START POINT TO CLOSE THE LATTICE. C NOTE--AND SO FORTH FOR 10, 14, 18, ... NUMBERS. C INPUT ARGUMENTS--IHARG C --IARGT C --ARG C --NUMARG C --PXSTAR C --PYSTAR C OUTPUT ARGUMENTS--PXEND C --PYEND C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1987. 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 CHARACTER*4 IDCOLO CCCCC ADD FOLLOWING LINE MARCH 1997. CHARACTER*4 IDFONT CCCCC ADD FOLLOWING LINE JULY 1997. CHARACTER*4 UNITSW C CHARACTER*4 IFOUND CHARACTER*4 IBUGD2 CHARACTER*4 IERROR CHARACTER*4 ISUBRO C CHARACTER*4 IFIG CHARACTER*4 IBELSW CHARACTER*4 IERASW CHARACTER*4 IBACCO CHARACTER*4 ICOPSW CHARACTER*4 ITYPEO C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION ARG(*) C DIMENSION ILINPA(*) DIMENSION ILINCO(*) DIMENSION PLINTH(*) C DIMENSION AREGBA(*) DIMENSION IREBLI(*) DIMENSION IREBCO(*) DIMENSION PREBTH(*) DIMENSION IREFSW(*) DIMENSION IREFCO(*) DIMENSION IREPTY(*) DIMENSION IREPLI(*) DIMENSION IREPCO(*) DIMENSION PREPTH(*) DIMENSION PREPSP(*) C DIMENSION IDMANU(*) DIMENSION IDMODE(*) DIMENSION IDMOD2(*) DIMENSION IDMOD3(*) DIMENSION IDPOWE(*) DIMENSION IDCONT(*) DIMENSION IDCOLO(*) CCCCC ADD FOLLOWING LINE MARCH 1997. DIMENSION IDFONT(*) DIMENSION IDNVPP(*) DIMENSION IDNHPP(*) DIMENSION IDUNIT(*) C DIMENSION IDNVOF(*) DIMENSION IDNHOF(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' IERRG4=IERROR CCCCC IBUGG4=IBUGD2 CCCCC ISUBG4=ISUBRO C ILOCFN=0 NUMNUM=0 C X1=0.0 Y1=0.0 X2=0.0 Y2=0.0 C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'LATT')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPLATT--') 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='LATT' NUMPT=3 NUMPT2=2*NUMPT C C ******************************** C ** STEP 0-- ** C ** STEP THROUGH EACH DEVICE ** C ******************************** C IF(NUMDEV.LE.0)GOTO9000 DO8000IDEVIC=1,NUMDEV C IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000 C IMANUF=IDMANU(IDEVIC) IMODEL=IDMODE(IDEVIC) IMODE2=IDMOD2(IDEVIC) IMODE3=IDMOD3(IDEVIC) IGCONT=IDCONT(IDEVIC) IGCOLO=IDCOLO(IDEVIC) CCCCC ADD FOLLOWING LINE MARCH 1997. IGFONT=IDFONT(IDEVIC) NUMVPP=IDNVPP(IDEVIC) NUMHPP=IDNHPP(IDEVIC) ANUMVP=NUMVPP ANUMHP=NUMHPP C AUGUST 1988. ADD OFFSET VARIABLE IOFFSV=IDNVOF(IDEVIC) IOFFSH=IDNHOF(IDEVIC) C IGUNIT=IDUNIT(IDEVIC) C C ************************************ C ** STEP 1-- ** C ** CARRY OUT OPENING OPERATIONS ** C ** ON THE GRAPHICS DEVICES ** C ************************************ C CALL DPOPDE C IBELSW='OFF' NUMRIN=0 IERASW='OFF' IBACCO='JUNK' C CALL DPOPPL(IGRASW, 1IBELSW,NUMRIN,IERASW, 1IBACCO) C C ***************************************** C ** STEP 2-- ** C ** SEARCH FOR COMMAND SPECIFICATIONS ** C ***************************************** C IF(NUMARG.GE.2.AND. 1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB') 1GOTO1111 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1112 IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND. 1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB') 1GOTO1113 GOTO1130 C 1111 CONTINUE ITYPEO='ABSO' ILOCFN=1 GOTO1119 C 1112 CONTINUE ITYPEO='ABSO' ILOCFN=2 GOTO1119 C 1113 CONTINUE ITYPEO='RELA' ILOCFN=2 GOTO1119 1119 CONTINUE C IF(ILOCFN.GT.NUMARG)GOTO1129 DO1120I=ILOCFN,NUMARG IF(IARGT(I).EQ.'NUMB')GOTO1120 GOTO1129 1120 CONTINUE IFOUND='YES' GOTO1149 1129 CONTINUE GOTO1130 C 1130 CONTINUE IERRG4='YES' WRITE(ICOUT,1131) 1131 FORMAT('***** ERROR IN DPLATT--') 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 LATTICE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT(' WITH VERTICES (20,20), (50,20), (35,40)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT(' THEN ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' LATTICE 20 20 50 20 35 40') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' LATTICE ABSOLUTE 20 20 50 20 35 40') CALL DPWRST('XXX','BUG ') GOTO9000 1149 CONTINUE C C **************************** C ** STEP 3-- ** C ** DRAW OUT THE LINE(S) ** C **************************** C NUMNUM=NUMARG-ILOCFN+1 IF(NUMNUM.LT.NUMPT2)GOTO1151 GOTO1152 C 1151 CONTINUE J=ILOCFN-1 X1=PXSTAR Y1=PYSTAR GOTO1159 C 1152 CONTINUE J=ILOCFN IF(J.GT.NUMARG)GOTO1190 X1=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR) J=J+1 IF(J.GT.NUMARG)GOTO1190 Y1=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR) GOTO1159 1159 CONTINUE C 1160 CONTINUE J=J+1 IF(J.GT.NUMARG)GOTO1190 X2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')X2=X1+X2 J=J+1 IF(J.GT.NUMARG)GOTO1190 Y2=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2 C 1170 CONTINUE J=J+1 IF(J.GT.NUMARG)GOTO1190 X3=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X3,X3,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')X3=X2+X3 J=J+1 IF(J.GT.NUMARG)GOTO1190 Y3=ARG(J) CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997 IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y3,Y3,IBUGD2,ISUBRO,IERROR) IF(ITYPEO.EQ.'RELA')Y3=Y2+Y3 C CALL DPLAT2(X1,Y1,X2,Y2,X3,Y3, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C X1=X3 Y1=Y3 C GOTO1160 1190 CONTINUE C PXEND=X3 PYEND=Y3 C C ************************************ C ** STEP 4-- ** C ** CARRY OUT CLOSING OPERATIONS ** C ** ON THE GRAPHICS DEVICES ** C ************************************ C ICOPSW='OFF' NUMCOP=0 CALL DPCLPL(ICOPSW,NUMCOP, 1PGRAXF,PGRAYF, 1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2, 1PDIAHE,PDIAWI,PDIAVG,PDIAHG) C CALL DPCLDE C 8000 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'LATT')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPLATT--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)ILOCFN,NUMNUM 9012 FORMAT('ILOCFN,NUMNUM = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)X1,Y1,X2,Y2,X3,Y3 9013 FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)PXSTAR,PYSTAR 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)PXEND,PYEND 9016 FORMAT('PXEND,PYEND = ',2E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IFIG 9017 FORMAT('IFIG = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9027)IFOUND 9027 FORMAT('IFOUND = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9029)IBUGD2,IERROR 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPLAT2(X1,Y1,X2,Y2,X3,Y3, 1IFIG, 1ILINPA,ILINCO,PLINTH, 1AREGBA, 1IREBLI,IREBCO,PREBTH, 1IREFSW,IREFCO, 1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP, 1PTEXHE,PTEXWI,PTEXVG,PTEXHG) C C PURPOSE--DRAW A LATTICE C WITH ONE CORNER AT (X1,Y1), C WITH GRID LINES SPACED AT DISTANCES OF X2 AND Y2, C AND WITH THE OPPOSING CORNER AT (X3,Y3). C NOTE--IF THE SPACING IS SET TO 0, THEN NO INTERMEDIATE C GRID LINES WILL RESULT. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--87/6 C ORIGINAL VERSION--MAY 1987. C UPDATED --JANUARY 1989. MODIFY CALLS TO DPDRPL (ALAN) C UPDATED --JANUARY 1989. MODIFY CALL TO DPFIRE (ALAN) C C-----NON-COMMON VARIABLES------------------------------------- C CHARACTER*4 IFIG CHARACTER*4 IPATT2 C CHARACTER*4 ILINPA CHARACTER*4 ILINCO C CHARACTER*4 IREBLI CHARACTER*4 IREBCO CHARACTER*4 IREFSW CHARACTER*4 IREFCO CHARACTER*4 IREPTY CHARACTER*4 IREPLI CHARACTER*4 IREPCO C CHARACTER*4 IPATT CHARACTER*4 ICOLF CHARACTER*4 ICOLP CHARACTER*4 ICOL CHARACTER*4 IFLAG C DIMENSION PX(10) DIMENSION PY(10) CCCCC DIMENSION PX3(10) CCCCC DIMENSION PY3(10) C DIMENSION ILINPA(*) DIMENSION ILINCO(*) DIMENSION PLINTH(*) C DIMENSION AREGBA(*) DIMENSION IREBLI(*) DIMENSION IREBCO(*) DIMENSION PREBTH(*) DIMENSION IREFSW(*) DIMENSION IREFCO(*) DIMENSION IREPTY(*) DIMENSION IREPLI(*) DIMENSION IREPCO(*) DIMENSION PREPTH(*) DIMENSION PREPSP(*) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOGR.INC' INCLUDE 'DPCOBE.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C CHARACTER*4 IFEEDB CHARACTER*4 IPRINT CHARACTER*240 ICOUT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW COMMON /PRINT/IFEEDB,IPRINT COMMON /TEXTOU/ICOUT,NCOUT,ILOUT C PX31=(-999) PY31=(-999) C PXINC=(-999) PYINC=(-999) C C-----START POINT----------------------------------------------------- C IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRI2')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPLAT2--') 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)X3,Y3 55 FORMAT('X3,Y3 = ',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 11-- ** C ** DETERMINE THE COORDINATES ** C ** AND ** C ** FILL THE FIGURE ** C ** (IF CALLED FOR) ** C ********************************* C IF(IREFSW(1).EQ.'OFF')GOTO1190 C PX(1)=X1 PY(1)=Y1 C PX(2)=X3 PY(2)=Y1 C PX(3)=X3 PY(3)=Y3 C PX(4)=X1 PY(4)=Y3 C PX(5)=X1 PY(5)=Y1 C NP=5 C IPATT=IREPTY(1) IPATT2='SOLI' PTHICK=PREPTH(1) PXGAP=PREPSP(1) PYGAP=PREPSP(1) ICOLF=IREFCO(1) ICOLP=IREPCO(1) IFIG='BOX' CALL DPFIRE(PX,PY,NP, 1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2) IFIG='LATT' C 1190 CONTINUE C C ********************************* C ** STEP 20-- ** C ** DETERMINE THE COORDINATES ** C ** FOR THE LATTICE ** C ** AND ** C ** DRAW OUT THE FIGURE ** C ********************************* C IPATT=ILINPA(1) PTHICK=PLINTH(1) ICOL=ILINCO(1) NP=2 C C *********************************** C ** STEP 21-- ** C ** DRAW OUT THE VERTICAL LINES ** C *********************************** C IF(X2.EQ.0.0)GOTO2100 GOTO2200 C 2100 CONTINUE PX(1)=X1 PY(1)=Y1 PX(2)=X1 PY(2)=Y3 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) PX(1)=X3 PY(1)=Y1 PX(2)=X3 PY(2)=Y3 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) GOTO2900 C 2200 CONTINUE PX31=X3-X1 PXINC=X2 IF(PX31.GT.0.0.AND.X2.LT.0.0)PXINC=(-X2) IF(PX31.LT.0.0.AND.X2.GT.0.0)PXINC=(-X2) IF(PX31.GT.0.0)PXCUT=X3+0.001 IF(PX31.LT.0.0)PXCUT=X3-0.001 NLOOP=ABS(PX31/PXINC) NLOOP=NLOOP+5 DO2210I=1,NLOOP IM1=I-1 AIM1=IM1 PXNEW=X1+AIM1*PXINC PX(1)=PXNEW PY(1)=Y1 PX(2)=PXNEW PY(2)=Y3 IF(PX31.GT.0.0.AND.PXNEW.GT.PXCUT)GOTO2290 IF(PX31.LT.0.0.AND.PXNEW.LT.PXCUT)GOTO2290 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) 2210 CONTINUE 2290 CONTINUE GOTO2900 C 2900 CONTINUE C C ************************************* C ** STEP 31-- ** C ** DRAW OUT THE HORIZONTAL LINES ** C ************************************* C IF(Y2.EQ.0.0)GOTO3100 GOTO3200 C 3100 CONTINUE PX(1)=X1 PY(1)=Y1 PX(2)=X3 PY(2)=Y1 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) PX(1)=X1 PY(1)=Y3 PX(2)=X3 PY(2)=Y3 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) GOTO3900 C 3200 CONTINUE PY31=Y3-Y1 PYINC=Y2 IF(PY31.GT.0.0.AND.Y2.LT.0.0)PYINC=(-Y2) IF(PY31.LT.0.0.AND.Y2.GT.0.0)PYINC=(-Y2) IF(PY31.GT.0.0)PYCUT=Y3+0.001 IF(PY31.LT.0.0)PYCUT=Y3-0.001 NLOOP=ABS(PY31/PYINC) NLOOP=NLOOP+5 DO3210I=1,NLOOP IM1=I-1 AIM1=IM1 PYNEW=Y1+AIM1*PYINC PX(1)=X1 PY(1)=PYNEW PX(2)=X3 PY(2)=PYNEW IF(PY31.GT.0.0.AND.PYNEW.GT.PYCUT)GOTO3290 IF(PY31.LT.0.0.AND.PYNEW.LT.PYCUT)GOTO3290 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) 3210 CONTINUE 3290 CONTINUE GOTO3900 C 3900 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'TRI2')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPLAT2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)NP 9013 FORMAT('NP = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)X1,Y1,X2,Y2,X3,Y3 9014 FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6E15.7) 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,9018)PX31,PY31,PXINC,PYINC 9018 FORMAT('PX31,PY31,PXINC,PYINC = ',4E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPLEAN(IHARG,IARGT,IARG,ARG,NUMARG,PDEFAN, 1MAXLEG,PLEGAN,IFOUND,IERROR) C C PURPOSE--DEFINE THE ANGLE FOR A LEGEND. C THE ANGLE FOR LEGEND I WILL BE PLACED C IN THE I-TH ELEMENT OF THE REAL C VECTOR PLEGAN(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --ARG (A REAL VECTOR) C --NUMARG C --PDEFAN C --MAXLEG C OUTPUT ARGUMENTS--PLEGAN (A REAL VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C ANGLE FOR LEGEND I. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/2 C ORIGINAL VERSION--JANUARY 1989. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION PLEGAN(*) 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)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'ANGL')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'ANGL')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE PHOLD=PDEFAN GOTO1130 C 1125 CONTINUE PHOLD=ARG(2) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXLEG PLEGAN(I)=PHOLD 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)PLEGAN(I) 1136 FORMAT('ALL LEGEND ANGLES HAVE JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPLEAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE LEGEND ... ANGLE COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE LEGEND IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' LEGEND 3 ANGLE 45 ') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXLEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPLEAN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE LEGEND ... ANGLE COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF LEGENDS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXLEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'LEGEND.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE PHOLD=PDEFAN GOTO1180 C 1175 CONTINUE PHOLD=ARG(3) GOTO1180 C 1180 CONTINUE IFOUND='YES' PLEGAN(I)=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,PLEGAN(I) 1186 FORMAT('THE ANGLE FOR LEGEND ',I8, 1' HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPLECA(IHARG,IARGT,IARG,NUMARG,IDEFCA, 1MAXLEG,ILEGCA,IFOUND,IERROR) C C PURPOSE--DEFINE THE CASE FOR A LEGEND. C THE CASE FOR LEGEND I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ILEGCA(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFCA C --MAXLEG C OUTPUT ARGUMENTS--ILEGCA (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C CASE FOR LEGEND I. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/2 C ORIGINAL VERSION--JANUARY 1989. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IDEFCA CHARACTER*4 ILEGCA CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION ILEGCA(*) 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)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CASE')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'CASE')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFCA GOTO1130 C 1125 CONTINUE IHOLD=IHARG(2) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXLEG ILEGCA(I)=IHOLD 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)ILEGCA(I) 1136 FORMAT('ALL LEGEND CASES HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPLECA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE LEGEND ... CASE COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE LEGEND IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' LEGEND 3 CASE UPPER') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXLEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPLECA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE LEGEND ... CASE COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF LEGENDS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXLEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'LEGEND.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFCA GOTO1180 C 1175 CONTINUE IHOLD=IHARG(3) GOTO1180 C 1180 CONTINUE IFOUND='YES' ILEGCA(I)=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,ILEGCA(I) 1186 FORMAT('THE CASE FOR LEGEND ',I8, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPLECL(IHARG,IARGT,IARG,NUMARG,IDEFCO, 1MAXLEG,ILEGCO,IFOUND,IERROR) C C PURPOSE--DEFINE THE COLOR FOR A LEGEND. C THE COLOR FOR LEGEND I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ILEGCO(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFCO C --MAXLEG C OUTPUT ARGUMENTS--ILEGCO (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C COLOR FOR LEGEND I. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--SEPTEMBER 1980. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IDEFCO CHARACTER*4 ILEGCO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION ILEGCO(*) 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)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COLO')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFCO GOTO1130 C 1125 CONTINUE IHOLD=IHARG(2) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXLEG ILEGCO(I)=IHOLD 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)ILEGCO(I) 1136 FORMAT('ALL LEGEND COLORS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPLECL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE LEGEND ... COLOR COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE LEGEND IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' LEGEND 3 COLOR GREEN') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXLEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPLECL--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE LEGEND ... COLOR COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF LEGENDS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXLEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'LEGEND.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFCO GOTO1180 C 1175 CONTINUE IHOLD=IHARG(3) GOTO1180 C 1180 CONTINUE IFOUND='YES' ILEGCO(I)=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,ILEGCO(I) 1186 FORMAT('THE COLOR FOR LEGEND ',I8, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPLECO(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH, 1MAXLEG,PLEGXC,PLEGYC,IBUGP2,IFOUND,IERROR) C C PURPOSE--DEFINE THE (X,Y) COORDINATES FOR A LEGEND. C THE (X,Y) COORDINATES WILL BE PLACED IN THE C I-TH ELEMENT OF PLEGXC(.) AND PLEGYC(.) RESPECTIVELY. C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --ARG (A HOLLERITH VECTOR) C --NUMARG C --MAXLEG C OUTPUT ARGUMENTS--PLEGXC (A FLOATING POINT VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C X COORDINATE FOR LEGEND I. C --PLEGYC (A FLOATING POINT VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C Y COORDINATE FOR LEGEND I. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--SEPTEMBER 1980. C UPDATED --MARCH 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IHARG2 CHARACTER*4 IARGT CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE CHARACTER*4 IANS CHARACTER*4 IBUGP2 CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASE CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 IHWORD CHARACTER*4 IHWOR2 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IHARG2(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IN(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) DIMENSION IANS(*) C DIMENSION PLEGXC(*) DIMENSION PLEGYC(*) 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='DPLE' ISUBN2='CO ' C IFOUND='NO' IERROR='NO' C HOLD1=0.0 HOLD2=0.0 C IF(NUMARG.EQ.0)GOTO9000 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COOR')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COOR')GOTO1140 GOTO9000 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 IF(NUMARG.GE.3)GOTO1125 C IERROR='YES' WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPLECO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' IN THE LEGEND ... COORDINATES COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' THE COORDINATES ARE SPECIFIED BY 2 NUMBERS, ', 1'AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) 1114 FORMAT(' LEGEND 3 COORDINATES 30 80') CALL DPWRST('XXX','BUG ') GOTO9000 C 1120 CONTINUE ICASE='AUTO' GOTO1130 C 1125 CONTINUE ICASE='NORM' DO1126J=2,3 IF(IARGT(J).EQ.'NUMB')GOTO1127 GOTO1128 1127 CONTINUE IF(J.EQ.2)HOLD1=ARG(J) IF(J.EQ.3)HOLD2=ARG(J) GOTO1126 1128 CONTINUE IHWORD=IHARG(J) IHWOR2=IHARG2(J) IHWUSE='P' MESSAG='YES' CALL CHECKN(IHWORD,IHWOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(J.EQ.2)HOLD1=VALUE(ILOC) IF(J.EQ.3)HOLD2=VALUE(ILOC) 1126 CONTINUE GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1131I=1,MAXLEG AI=I DEL=(AI-1.0)*4.0 IF(ICASE.EQ.'AUTO')PLEGXC(I)=20.0 IF(ICASE.EQ.'AUTO')PLEGYC(I)=84.0-DEL IF(ICASE.NE.'AUTO')PLEGXC(I)=HOLD1 IF(ICASE.NE.'AUTO')PLEGYC(I)=HOLD2 1131 CONTINUE IF(ICASE.EQ.'AUTO')GOTO1135 C IF(IFEEDB.EQ.'OFF')GOTO1134 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1132) 1132 FORMAT('ALL LEGEND COORDINATES HAVE JUST BEEN SET TO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133)PLEGXC(I),PLEGYC(I) 1133 FORMAT(' X = ',E15.7,' Y = ',E15.7) CALL DPWRST('XXX','BUG ') 1134 CONTINUE GOTO9000 C 1135 CONTINUE IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1136) 1136 FORMAT('ALL LEGEND COORDINATES HAVE BEEN AUTOMATICALLY SET ', 1'AS FOLLOWS--') CALL DPWRST('XXX','BUG ') DO1137I=1,4 WRITE(ICOUT,1186)I CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133)PLEGXC(I),PLEGYC(I) CALL DPWRST('XXX','BUG ') 1137 CONTINUE WRITE(ICOUT,1138)MAXLEG 1138 FORMAT(' ... AND SO ON FOR ALL ',I8,' LEGENDS') CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO9000 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPLECO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE LEGEND ... COORDINATES COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE LEGEND IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' LEGEND 3 COORDINATES 30 80') CALL DPWRST('XXX','BUG ') GOTO9000 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXLEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPLECO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE LEGEND ... COORDINATES COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF LEGENDS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXLEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'LEGEND.') CALL DPWRST('XXX','BUG ') GOTO9000 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 IF(NUMARG.GE.4)GOTO1175 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) CALL DPWRST('XXX','BUG ') GOTO9000 C 1170 CONTINUE AI=I DEL=(AI-1.0)*4.0 HOLD1=20.0 HOLD2=84.0-DEL GOTO1180 C 1175 CONTINUE DO1176J=3,4 IF(IARGT(J).EQ.'NUMB')GOTO1177 GOTO1178 1177 CONTINUE IF(J.EQ.3)HOLD1=ARG(J) IF(J.EQ.4)HOLD2=ARG(J) GOTO1176 1178 CONTINUE IHWORD=IHARG(J) IHWOR2=IHARG2(J) IHWUSE='P' MESSAG='YES' CALL CHECKN(IHWORD,IHWOR2,IHWUSE, 1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR) IF(IERROR.EQ.'YES')GOTO9000 IF(J.EQ.3)HOLD1=VALUE(ILOC) IF(J.EQ.4)HOLD2=VALUE(ILOC) 1176 CONTINUE GOTO1180 C 1180 CONTINUE IFOUND='YES' PLEGXC(I)=HOLD1 PLEGYC(I)=HOLD2 C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I 1186 FORMAT('THE COORDINATES FOR LEGEND ',I8, 1' HAVE JUST BEEN SET TO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1133)PLEGXC(I),PLEGYC(I) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPLECO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IFOUND,IERROR 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPLEDI(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFDI, 1MAXLEG,ILEGDI,IFOUND,IERROR) CCCCC THE FOLLOWING LINE WAS FIXED (SEE ABOVE) FEBRUARY 1992 CCCCC SUBROUTINE DPLEDI(IHARG,IARGT,IARG,NUMARG,IDEFDI, C C PURPOSE--DEFINE THE DIRECTION FOR A LEGEND. C THE DIRECTION FOR LEGEND I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ILEGDI(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IHARG2 (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFDI C --MAXLEG C OUTPUT ARGUMENTS--ILEGDI (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C DIRECTION FOR LEGEND I. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/2 C ORIGINAL VERSION--JANUARY 1989. C UPDATED --FEBRUARY 1992 FIX CONFLICT WITH LITERAL C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1992 CHARACTER*4 IHARG2 CHARACTER*4 IARGT CHARACTER*4 IDEFDI CHARACTER*4 ILEGDI CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) CCCCC THE FOLLOWING LINE WAS ADDED FEBRAURY 1992 DIMENSION IHARG2(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION ILEGDI(*) 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)GOTO1199 CCCCC THE FOLLOWING LINE WAS FIXED FEBRUARY 1992 CCCCC IF(NUMARG.GE.1.AND.IHARG(1).EQ.'DIRE')GOTO1110 IF(NUMARG.GE.1.AND. 1 IHARG(1).EQ.'DIRE'.AND.IHARG2(1).EQ.'CTIO'.AND. 1 NUMARG.EQ.2)GOTO1110 CCCCC THE FOLLOWING LINE WAS FIXED FEBRUARY 1992 CCCCC IF(NUMARG.GE.2.AND.IHARG(2).EQ.'DIRE')GOTO1140 IF(NUMARG.GE.2.AND. 1 IHARG(2).EQ.'DIRE'.AND.IHARG2(2).EQ.'CTIO'.AND. 1 NUMARG.EQ.3)GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFDI GOTO1130 C 1125 CONTINUE IHOLD=IHARG(2) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXLEG ILEGDI(I)=IHOLD 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)ILEGDI(I) 1136 FORMAT('ALL LEGEND DIRECTIONS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPLEDI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE LEGEND ... DIRECTION COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE LEGEND IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' LEGEND 3 DIRECTION HORIZONTAL') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXLEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPLEDI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE LEGEND ... DIRECTION COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF LEGENDS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXLEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'LEGEND.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFDI GOTO1180 C 1175 CONTINUE IHOLD=IHARG(3) GOTO1180 C 1180 CONTINUE IFOUND='YES' ILEGDI(I)=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,ILEGDI(I) 1186 FORMAT('THE DIRECTION FOR LEGEND ',I8, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPLEFI(IHARG,IARGT,IARG,NUMARG,IDEFFI, 1MAXLEG,ILEGFI,IFOUND,IERROR) C C PURPOSE--DEFINE THE FILL FOR A LEGEND. C THE FILL FOR LEGEND I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ILEGFI(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFFI C --MAXLEG C OUTPUT ARGUMENTS--ILEGFI (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C FILL FOR LEGEND I. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/2 C ORIGINAL VERSION--JANUARY 1989. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IDEFFI CHARACTER*4 ILEGFI CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION ILEGFI(*) 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)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FILL')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'FILL')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFFI GOTO1130 C 1125 CONTINUE IHOLD=IHARG(2) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXLEG ILEGFI(I)=IHOLD 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)ILEGFI(I) 1136 FORMAT('ALL LEGEND FILLS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPLEFI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE LEGEND ... FILL COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE LEGEND IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' LEGEND 3 FILL ON') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXLEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPLEFI--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE LEGEND ... FILL COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF LEGENDS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXLEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'LEGEND.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFFI GOTO1180 C 1175 CONTINUE IHOLD=IHARG(3) GOTO1180 C 1180 CONTINUE IFOUND='YES' ILEGFI(I)=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,ILEGFI(I) 1186 FORMAT('THE FILL FOR LEGEND ',I8, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPLEFO(IHARG,IARGT,IARG,NUMARG,IDEFFO, 1MAXLEG,ILEGFO,IFOUND,IERROR) C C PURPOSE--DEFINE THE FONT FOR A LEGEND. C THE FONT FOR LEGEND I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ILEGFO(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFFO C --MAXLEG C OUTPUT ARGUMENTS--ILEGFO (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C FONT FOR LEGEND I. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/2 C ORIGINAL VERSION--JANUARY 1989. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IDEFFO CHARACTER*4 ILEGFO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION ILEGFO(*) 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)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'FONT')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'FONT')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFFO GOTO1130 C 1125 CONTINUE IHOLD=IHARG(2) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXLEG ILEGFO(I)=IHOLD 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)ILEGFO(I) 1136 FORMAT('ALL LEGEND FONTS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPLEFO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE LEGEND ... FONT COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE LEGEND IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' LEGEND 3 FONT SIMPLEX') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXLEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPLEFO--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE LEGEND ... FONT COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF LEGENDS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXLEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'LEGEND.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFFO GOTO1180 C 1175 CONTINUE IHOLD=IHARG(3) GOTO1180 C 1180 CONTINUE IFOUND='YES' ILEGFO(I)=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,ILEGFO(I) 1186 FORMAT('THE FONT FOR LEGEND ',I8, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPLEG(IHARG,IARG,ARG,IARGT,NUMARG,IANS,IANSLC, 1IWIDTH, CCCCC SUBROUTINE DPLEG(IHARG,IARG,ARG,IARGT,NUMARG,IANS,IWIDTH, CCCCC THE ABOVE LINE WAS COMMENTED OUT SEPTEMBER 1993 CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 1ILEGNA,ILEGST,ILEGSP,NUMLEG,MAXLEG, 1ILEGTE,NCLEG,MXCLEG,IFOUND,IERROR,IBUGP2) C C PURPOSE--DETERMINE THE LEGEND. C CONVERT A STRING TO BE USED AS A LEGEND C ON A TEKTRONIX (OR EQUIVALENT) PLOT INTO THE PROPER FORM C (ASCII INTEGER REPRESENTATION) FOR USE C BY THE TEKTRONIX (OR EQUIVALENT) SOFTWARE. C ALSO SAVE THE ORIGINAL STRING FOR USE C ON PRINTER PLOTS. C OUTPUT ARGUMENTS--ILEGNA (A CHARACTER VECTOR) C --ILEGST (AN INTEGER VECTOR) C --ILEGSP (AN INTEGER VECTOR) C --ILEGTE (A CHARACTER VECTOR) C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--MARCH 1979. C UPDATED --JULY 1980. C UPDATED --SEPTEMBER 1980. C UPDATED --DECEMBER 1981. C UPDATED --MAY 1982. C UPDATED --SEPTEMBER 1993. ALLOW LOWER CASE C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IANS CCCCC THE FOLLOWING LINE WAS ADDED SEPTEMBER 1993 CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 CHARACTER*4 IANSLC CHARACTER*4 ILEGNA CHARACTER*4 ILEGTE CHARACTER*4 IFOUND CHARACTER*4 IERROR CHARACTER*4 IBUGP2 C CHARACTER*4 ICASLE CHARACTER*4 ISTH CHARACTER*4 ILEGN2 C C--------------------------------------------------------------------- C DIMENSION IANS(*) CCCCC THE FOLLOWING LINE WAS ADDED SEPTEBMER 1993 CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 DIMENSION IANSLC(*) C DIMENSION IHARG(*) DIMENSION IARG(*) DIMENSION ARG(*) DIMENSION IARGT(*) C DIMENSION ILEGNA(*) DIMENSION ILEGST(*) DIMENSION ILEGSP(*) C DIMENSION ILEGTE(*) C DIMENSION ISTH(1000) 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 ILEGNU=(-999) C IF(IBUGP2.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPLEG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)N2,NCLEG,MXCLEG 52 FORMAT('N2,NCLEG,MXCLEG = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)(ILEGTE(I),I=1,NCLEG) 55 FORMAT('ILEGTE(.) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)NUMLEG,MAXLEG 56 FORMAT('NUMLEG,MAXLEG = ',2I8) CALL DPWRST('XXX','BUG ') DO60I=1,NUMLEG WRITE(ICOUT,61)I,ILEGNA(I),ILEGST(I),ILEGSP(I) 61 FORMAT('I,ILEGNA(I),ILEGST(I),ILEGSP(I) = ',I4,3X,A4,I8,I8) CALL DPWRST('XXX','BUG ') 60 CONTINUE 90 CONTINUE C IF(NUMARG.EQ.0)GOTO105 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')GOTO9000 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'COOR')GOTO9000 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SIZE')GOTO9000 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'HW')GOTO9000 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COLO')GOTO9000 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COOR')GOTO9000 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'SIZE')GOTO9000 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'HW')GOTO9000 GOTO105 C 105 CONTINUE C C ********************************************************** C ** STEP 1-- ** C ** DETERMINE THE LOCATION OF THE WORD LEGEND . ** C ********************************************************** C ICASLE='1' IF(NUMARG.EQ.0)GOTO110 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'ON')GOTO110 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'OFF')GOTO110 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'AUTO')GOTO110 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'DEFA')GOTO110 GOTO150 C 110 CONTINUE ICASLE='ALL' NUMLEG=0 DO120I=1,MAXLEG ILEGNA(I)=' ' ILEGST(I)=0 ILEGSP(I)=0 120 CONTINUE NCLEG=0 DO130I=1,MXCLEG ILEGTE(I)=' ' 130 CONTINUE GOTO800 C 150 CONTINUE DO160I=1,IWIDTH I2=I IP1=I+1 IP2=I+2 IP3=I+3 IP4=I+4 IP5=I+5 IF(IP5.GT.IWIDTH)GOTO169 IF(IANS(I).EQ.'L'.AND.IANS(IP1).EQ.'E' 1.AND.IANS(IP2).EQ.'G'.AND.IANS(IP3).EQ.'E' 1.AND.IANS(IP4).EQ.'N'.AND.IANS(IP5).EQ.'D') 1GOTO180 160 CONTINUE 169 CONTINUE C WRITE(ICOUT,171) 171 FORMAT('***** ERROR IN DPLEG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,172) 172 FORMAT(' THE WORD LEGEND NOT FOUND.') CALL DPWRST('XXX','BUG ') GOTO9000 C 180 CONTINUE ISTOPL=IP5 C C ********************************************** C ** STEP 2-- ** C ** DETERMINE THE NAME ASSOCIATED WITH ** C ** THE LEGEND PRESENTLY BEING DEFINED. ** C ********************************************** C ISTART=ISTOPL+1 IF(ISTART.GT.IWIDTH)GOTO209 DO200I=ISTART,IWIDTH I2=I IF(IANS(I).NE.' ')GOTO220 200 CONTINUE 209 CONTINUE C WRITE(ICOUT,211) 211 FORMAT('***** ERROR IN DPLEG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,212) 212 FORMAT(' NO NAME (E.G., 1, 2, 3, ...) FOUND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,213) 213 FORMAT(' FOR THE CURRENT LEGEND BEING DEFINED.') CALL DPWRST('XXX','BUG ') GOTO9000 C 220 CONTINUE ISTARN=I2 C DO230I=ISTARN,IWIDTH I2=I IF(IANS(I).EQ.' ')GOTO240 230 CONTINUE I2=I2+1 240 CONTINUE ISTOPN=I2-1 C CCCCC CALL DP1H4H(ISTARN,ISTOPN,IANS, CCCCC1IWORD1,IWORD2,IWORD3,NUMWD,NUMCH,IBUGP2,IERROR) C IF(IARGT(1).EQ.'NUMB')GOTO249 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,241) 241 FORMAT('***** ERROR IN DPLEG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,242) 242 FORMAT(' IN THE LEGEND ... COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,243) 243 FORMAT(' THE LEGEND MUST BE IDENTIFIED BY A NUMBER,' ) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,244) 244 FORMAT(' AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,245) 245 FORMAT(' LEGEND 2 CARBON DIOXIDE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,246) 246 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,247) 247 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,248)(IANS(I),I=1,IWIDTH) 248 FORMAT(100A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') GOTO9000 249 CONTINUE C ILEGN2=IHARG(1) ILEGNU=IARG(1) IF(1.LE.ILEGNU.AND.ILEGNU.LE.MAXLEG)GOTO259 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,251) 251 FORMAT('***** ERROR IN DPLEG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,252) 252 FORMAT(' IN THE LEGEND ... COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,253) 253 FORMAT(' THE NUMBER OF LEGENDS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,254)MAXLEG 254 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,255) 255 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,256)I 256 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'LEGEND.') CALL DPWRST('XXX','BUG ') GOTO9000 259 CONTINUE C C ********************************************* C ** STEP 3-- ** C ** DETERMINE THE START POSITION (ISTARS) ** C ** FOR THE LEGEND STRING. ** C ********************************************* C ISTARS=ISTOPN+2 C C ******************************************** C ** STEP 4-- ** C ** DETERMINE THE STOP POSITION (ISTOPS) ** C ** FOR THE LEGEND STRING. ** C ******************************************** C ISTOPS=IWIDTH IMIN=ISTARS IF(IMIN.GT.IWIDTH)GOTO490 DO400I=IMIN,IWIDTH IREV=IWIDTH-I+IMIN IF(IANS(IREV).NE.' ')GOTO420 400 CONTINUE GOTO490 420 CONTINUE ISTOPS=IREV 490 CONTINUE C C *********************************************** C ** STEP 5- - ** C ** COPY OVER THE STRING OF INTEREST. ** C ** CONVERT TO ASCII NUMERIC REPRESENTATION. ** C *********************************************** C IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'ON')GOTO570 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'OFF')GOTO570 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'AUTO')GOTO570 IF(NUMARG.EQ.2.AND.IHARG(2).EQ.'DEFA')GOTO570 IF(NUMARG.EQ.1)GOTO570 GOTO540 C 540 CONTINUE J=0 IF(ISTARS.GT.ISTOPS)GOTO570 DO550I=ISTARS,ISTOPS J=J+1 CCCCC THE FOLLOWING LINE AS CHANGED SEPTEMBER 1993 CCCCC TO ALLOW FOR LOWER CASE SEPTEMBER 1993 CCCCC ISTH(J)=IANS(I) ISTH(J)=IANSLC(I) 550 CONTINUE N2=J GOTO590 C 570 CONTINUE J=1 ISTH(1)=' ' N2=J GOTO590 C 590 CONTINUE C C **************************************************************** C ** STEP 6-- * C ** INSERT THE CHARACTER STRING IN LOCATIONS * C ** 1 TO N2 OF ISTH(.) INTO THE * C ** PACKED INTERNAL DATAPLOT TABLE ILEGTE(.). C ** UPDATE (IF NECESSARY) THE INTERNAL TABLES * C ** ILEGNA(.), ILEGST(.), AND ILEGSP(.). * C **************************************************************** C CCCCC MAY NEED TO ADD IANSLC TO THE ARG LIST BELOW??? SEPTEMBER 1993 CALL DPINLE(ILEGN2,ISTH,N2,ILEGNA,ILEGST,ILEGSP, 1NUMLEG,MAXLEG,ILEGTE,NCLEG,MXCLEG,IANS,IWIDTH,IBUGP2, 1IERROR) C C *************************** C ** STEP 7-- ** C ** PRINT OUT A MESSAGE ** C *************************** C 800 CONTINUE IF(ICASLE.EQ.'ALL')GOTO820 C 810 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO819 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,811)ILEGNA(ILEGNU) 811 FORMAT('LEGEND ',A4,' HAS JUST BEEN SET TO') CALL DPWRST('XXX','BUG ') IF(N2.EQ.0)WRITE(ICOUT,999) IF(N2.EQ.0)CALL DPWRST('XXX','BUG ') IF(N2.GE.1)WRITE(ICOUT,812)(ISTH(I),I=1,N2) 812 FORMAT(12X,118A1) IF(N2.GE.1)CALL DPWRST('XXX','BUG ') 819 CONTINUE GOTO9000 C 820 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO829 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,821) 821 FORMAT('ALL LEGENDS HAVE JUST BEEN SET TO') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') 829 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGP2.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPLEG--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)N2,NCLEG,MXCLEG 9012 FORMAT('N2,NCLEG,MXCLEG = ',3I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)(ISTH(I),I=1,N2) 9013 FORMAT('ISTH(.) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)(ILEGTE(I),I=1,NCLEG) 9015 FORMAT('ILEGTE(.) = ',100A1) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)ILEGNU,IARG(1),NUMLEG,MAXLEG 9017 FORMAT('ILEGNU,IARG(1),NUMLEG,MAXLEG = ',4I8) CALL DPWRST('XXX','BUG ') DO9020I=1,NUMLEG WRITE(ICOUT,9021)I,ILEGNA(I),ILEGST(I),ILEGSP(I) 9021 FORMAT('I,ILEGNA(I),ILEGST(I),ILEGSP(I) = ',I4,3X,A4,I8,I8) CALL DPWRST('XXX','BUG ') 9020 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE DPLEHW(IHARG,IARGT,IARG,ARG,NUMARG, 1PDEFHE, 1MAXLEG, 1PLEGHE,PLEGWI,PLEGVG,PLEGHG, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE HEIGHT AND WIDTH FOR A LEGEND. C THE HEIGHT FOR LEGEND I WILL BE PLACED C IN THE I-TH ELEMENT OF THE FLOATING POINT C VECTOR PLEGHE(.). C THE WIDTH FOR LEGEND I WILL BE PLACED C IN THE I-TH ELEMENT OF THE FLOATING POINT C VECTOR PLEGWI(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --ARG (A HOLLERITH VECTOR) C --NUMARG C --PDEFHE C --MAXLEG C OUTPUT ARGUMENTS--PLEGHE (A FLOATING POINT VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C SIZE (= HEIGHT) FOR LEGEND I. C --PLEGWI = LEGEND WIDTH C --PLEGVG = LEGEND VERTICAL GAP C --PLEHG = LEGEND GHORIZONTAL GAP C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JUNE 1980. 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 IARG(*) DIMENSION ARG(*) C DIMENSION PLEGHE(*) DIMENSION PLEGWI(*) DIMENSION PLEGVG(*) DIMENSION PLEGHG(*) 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)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'HW')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'HW')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.2)GOTO1120 IF(IHARG(3).EQ.'ON')GOTO1120 IF(IHARG(3).EQ.'OFF')GOTO1120 IF(IHARG(3).EQ.'AUTO')GOTO1120 IF(IHARG(3).EQ.'DEFA')GOTO1120 IF(NUMARG.GE.3.AND. 1IARGT(2).EQ.'NUMB'.AND. 1IARGT(3).EQ.'NUMB')GOTO1125 C IERROR='YES' WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPLEHW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' IN THE LEGEND ... HW COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' THE HEIGHT & WIDTH IS SPECIFIED BY 2 NUMBERS, ', 1'AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) 1114 FORMAT(' LEGEND 3 HW 1.5 1') CALL DPWRST('XXX','BUG ') GOTO1199 C 1120 CONTINUE HOLD1=PDEFHE HOLD2=PDEFHE*0.5 GOTO1130 C 1125 CONTINUE HOLD1=ARG(2) HOLD2=ARG(3) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXLEG PLEGHE(I)=HOLD1 PLEGWI(I)=HOLD2 PLEGVG(I)=PLEGHE(I)*0.375 PLEGHG(I)=PLEGWI(I)*0.250 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)PLEGHE(I),PLEGWI(I) 1136 FORMAT('ALL LEGEND HEIGHT & WIDTHS HAVE JUST BEEN SET TO ', 12E15.7) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPLEHW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE LEGEND ... HW COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE LEGEND IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' LEGEND 3 HW 1.5 1') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXLEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPLEHW--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE LEGEND ... HW COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF LEGENDS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXLEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'LEGEND.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.3)GOTO1170 IF(IHARG(4).EQ.'ON')GOTO1170 IF(IHARG(4).EQ.'OFF')GOTO1170 IF(IHARG(4).EQ.'AUTO')GOTO1170 IF(IHARG(4).EQ.'DEFA')GOTO1170 IF(NUMARG.GE.4.AND. 1IARGT(3).EQ.'NUMB'.AND. 1IARGT(4).EQ.'NUMB')GOTO1175 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) CALL DPWRST('XXX','BUG ') GOTO1199 C 1170 CONTINUE HOLD1=PDEFHE HOLD2=PDEFHE*0.5 GOTO1180 C 1175 CONTINUE HOLD1=ARG(3) HOLD2=ARG(4) GOTO1180 C 1180 CONTINUE IFOUND='YES' PLEGHE(I)=HOLD1 PLEGWI(I)=HOLD2 PLEGVG(I)=PLEGHE(I)*0.375 PLEGHG(I)=PLEGWI(I)*0.250 C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,PLEGHE(I),PLEGWI(I) 1186 FORMAT('THE HEIGHT & WIDTH FOR LEGEND ',I8, 1' HAS JUST BEEN SET TO ',2E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE C 1199 CONTINUE RETURN END SUBROUTINE DPLEJU(IHARG,IARGT,IARG,NUMARG,IDEFJU, 1MAXLEG,ILEGJU,IFOUND,IERROR) C C PURPOSE--DEFINE THE JUSTIFICATION FOR A LEGEND. C THE JUSTIFICATION FOR LEGEND I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ILEGJU(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFJU C --MAXLEG C OUTPUT ARGUMENTS--ILEGJU (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C JUSTIFICATION FOR LEGEND I. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/2 C ORIGINAL VERSION--JANUARY 1989. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IDEFJU CHARACTER*4 ILEGJU CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION ILEGJU(*) 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)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'JUST')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'JUST')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFJU GOTO1130 C 1125 CONTINUE IHOLD=IHARG(2) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXLEG ILEGJU(I)=IHOLD 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)ILEGJU(I) 1136 FORMAT('ALL LEGEND JUSTIFICATIONS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPLEJU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE LEGEND ... JUSTIFICATION COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE LEGEND IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' LEGEND 3 JUSTIFICATION CENTER') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXLEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPLEJU--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE LEGEND ... JUSTIFICATION COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF LEGENDS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXLEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'LEGEND.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFJU GOTO1180 C 1175 CONTINUE IHOLD=IHARG(3) GOTO1180 C 1180 CONTINUE IFOUND='YES' ILEGJU(I)=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,ILEGJU(I) 1186 FORMAT('THE JUSTIFICATION FOR LEGEND ',I8, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPLESZ(IHARG,IARGT,IARG,ARG,NUMARG, 1PDEFHE,PDEFWI, 1MAXLEG, 1PLEGHE,PLEGWI,PLEGVG,PLEGHG, 1IFOUND,IERROR) C C PURPOSE--DEFINE THE SIZE FOR A LEGEND. C THE SIZE FOR LEGEND I WILL BE PLACED C IN THE I-TH ELEMENT OF THE FLOATING POINT C VECTOR ILEGCO(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --ARG (A HOLLERITH VECTOR) C --NUMARG C --PDEFHE C --PDEFWI C --MAXLEG C OUTPUT ARGUMENTS--PLEGHE (A FLOATING POINT VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C SIZE (= HEIGHT) FOR LEGEND I. C --PLEGWI = LEGEND WIDTH C --PLEGVG = LEGEND VERTICAL GAP C --PLEHG = LEGEND GHORIZONTAL GAP C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--SEPTEMBER 1980. C UPDATED --MAY 1982. C UPDATED --DECEMBER 1988. DEFAULT WIDTH 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 IARG(*) DIMENSION ARG(*) C DIMENSION PLEGHE(*) DIMENSION PLEGWI(*) DIMENSION PLEGVG(*) DIMENSION PLEGHG(*) 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)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SIZE')GOTO1110 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'HEIG')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'SIZE')GOTO1140 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'HEIG')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 IF(NUMARG.GE.2.AND. 1IARGT(2).EQ.'NUMB')GOTO1125 C IERROR='YES' WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPLESZ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' IN THE LEGEND ... SIZE COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' THE SIZE IS SPECIFIED BY 1 NUMBER, ', 1'AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) 1114 FORMAT(' LEGEND 3 SIZE 1.5') CALL DPWRST('XXX','BUG ') GOTO1199 C 1120 CONTINUE HOLD1=PDEFHE HOLD2=PDEFWI GOTO1130 C 1125 CONTINUE HOLD1=ARG(2) HOLD2=HOLD1*0.5 GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXLEG PLEGHE(I)=HOLD1 PLEGWI(I)=HOLD2 PLEGVG(I)=PLEGHE(I)*0.375 PLEGHG(I)=PLEGHE(I)*0.125 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)PLEGHE(I) 1136 FORMAT('ALL LEGEND SIZES HAVE JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPLESZ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE LEGEND ... SIZE COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE LEGEND IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' LEGEND 3 SIZE 1.5') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXLEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPLESZ--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE LEGEND ... SIZE COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF LEGENDS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXLEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'LEGEND.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 IF(NUMARG.GE.3.AND. 1IARGT(3).EQ.'NUMB')GOTO1175 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) CALL DPWRST('XXX','BUG ') GOTO1199 C 1170 CONTINUE HOLD1=PDEFHE HOLD2=PDEFWI GOTO1180 C 1175 CONTINUE HOLD1=ARG(3) HOLD2=HOLD1*0.5 GOTO1180 C 1180 CONTINUE IFOUND='YES' PLEGHE(I)=HOLD1 PLEGWI(I)=HOLD2 PLEGVG(I)=PLEGHE(I)*0.375 PLEGHG(I)=PLEGHE(I)*0.125 C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,PLEGHE(I) 1186 FORMAT('THE SIZE FOR LEGEND ',I8, 1' HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE C 1199 CONTINUE RETURN END SUBROUTINE DPLET(IANGLU,ISEED,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ, 1TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT, CCCCC AUGUST 1995. ADD IFTORD CCCCC1IFTEXP, 1IFTEXP,IFTORD, CCCCC ADD FOLLOWING LINE. FEBRUARY 1994. CCCCC ADD OPTACC. JUNE 1994. CCCCC ADD IOPTME,IOPTHE, FEBRUARY 1995. 1ROOTAC,OPTACC,IOPTME,IOPTHE, 1ISUBRO,IFOUND,IERROR) C C PURPOSE--CARRY OUT THE LET COMMAND. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1977. C UPDATED --OCTOBER 1978. C UPDATED --NOVEMBER 1978. C UPDATED --JANUARY 1979. C UPDATED --FEBRUARY 1979. C UPDATED --JUNE 1979. C UPDATED --JULY 1979. C UPDATED --SEPTEMBER 1980. C UPDATED --JUNE 1981. C UPDATED --JULY 1981. C UPDATED --SEPTEMBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JUNE 1986. C UPDATED --NOVEMBER 1986. C UPDATED --APRIL 1987. C UPDATED --JUNE 1987. EXP DESIGN C UPDATED --SEPTEMBER 1987. PRIME NUMBERS C UPDATED --AUGUST 1988. PRINCIPLE COMPONENTS C UPDATED --SEPTEMBER 1987. FIBONNACCI NUMBERS C UPDATED --DECEMBER 1988. ELIM. SHORT VERS. OF SEQUENCE C UPDATED --DECEMBER 1988. SHORTEN: LET Y = SEQU 1 1 N C UPDATED --JANUARY 1989. CHECK FOR ARITHMETIC OPERATORS C UPDATED --JANUARY 1989. (SIMULATED) EXPERIMENT C UPDATED --APRIL 1989. LOGISTIC SEQUENCE C UPDATED --APRIL 1989. CANTOR SET C UPDATED --OCTOBER 1991. NORMAL ORD. STAT. MED. C UPDATED --MAY 1993. EV1, EV2, WEIB. ORD. STAT. MED. C UPDATED --JULY 1993. BUG FIX FOR SING VALUE DECOMP C UPDATED --SEPTEMBER 1993. ADD ISUBRO TO CALL TO DPRK C UPDATED --FEBRUARY 1994. LET A = (TAGUCHI) SN- COMMAND C UPDATED --FEBRUARY 1994. LET A = (TAGUCHI) SN+ COMMAND C UPDATED --FEBRUARY 1994. ROOTAC ARGUMENT C UPDATED --JUNE 1994. ADD OPTIMIZATION COMMAND C UPDATED --FEBRUARY 1995. ADD ARGUMENTS TO OPTIMIZATION C UPDATED --SEPTEMBER 1997. BERNOULI NUMBERS C UPDATED --SEPTEMBER 1997. EULER NUMBERS C UPDATED --JULY 2002. ARGUMENT LIST FOR DPSTAC C UPDATED --APRIL 2003. ARGUMENT LIST FOR DPSTAC, C ADDITIONAL SCRATCH ARRAYS C UPDATED --JANUARY 2004. NUMERICAL DERIVATIVE C UPDATED --JANUARY 2004. CHARACTER CODE C UPDATED --JANUARY 2004. ALPHABETIC CHARACTER CODE C UPDATED --JANUARY 2004. GROUP LABEL C UPDATED --JANUARY 2004. ROW LABEL C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IANGLU CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASLE CHARACTER*4 ITYPEL CHARACTER*4 IFOUNZ CHARACTER*4 ITYPE CHARACTER*4 IHOL CHARACTER*4 IHOL2 CHARACTER*4 IERRO1 CHARACTER*4 ITYPEH CHARACTER*4 IW21HO CHARACTER*4 IW22HO CHARACTER*4 IA CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 IFOUNR CHARACTER*4 IFOUN7 CHARACTER*4 IFOUN8 CHARACTER*4 ICASL7 CHARACTER*4 ICASS7 CHARACTER*4 ICASL8 CHARACTER*4 ICASRA CHARACTER*4 ITYW1L CHARACTER*4 ICAT1L CHARACTER*4 INLI1L CHARACTER*4 ITYW2L CHARACTER*4 ITYW1R CHARACTER*4 ICAT1R CHARACTER*4 INLI1R CHARACTER*4 ITYW2R C CHARACTER*4 IFTEXP CCCCC AUGUST 1995. ADD FOLLOWING LINE CHARACTER*4 IFTORD C CHARACTER*4 IHAR14 CHARACTER*4 IHAR15 C CCCCC CHARACTER*4 ICASEX CCCCC CHARACTER*4 ITEXEX CCCCC CHARACTER*4 IPAGEX C CCCCC CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C CHARACTER*4 IMSUBC CHARACTER*4 IOPTME CHARACTER*4 IOPTHE C CCCCC THE FOLLOWING LINE WAS ADDED JANUARY 1989 CHARACTER*4 ICASAR C CHARACTER*4 IWRITE C C--------------------------------------------------------------------- C DIMENSION TEMP(*) DIMENSION TEMP2(*) DIMENSION XTEMP1(*) DIMENSION XTEMP2(*) C DIMENSION IFOUNZ(30) DIMENSION IBEGIN(30) DIMENSION IEND(30) DIMENSION ITYPE(30) DIMENSION IHOL(30) DIMENSION IHOL2(30) DIMENSION INT1(30) DIMENSION FLOAT1(30) DIMENSION IERRO1(30) C CCCCC DIMENSION ITYPEH(225) CCCCC DIMENSION IW21HO(225) CCCCC DIMENSION IW22HO(225) CCCCC DIMENSION W2HOLD(225) DIMENSION ITYPEH(1000) DIMENSION IW21HO(1000) DIMENSION IW22HO(1000) DIMENSION W2HOLD(1000) C C NOTE--THE DIMENSION OF IA SHOULD BE THE SAME AS C THE DIMENSION OF IB IN SUBROUTINE COMPIM C (THE DIMENSION OF IB IS 1000 (JULY 1986)) C NOTE--IF MAKE DIMENSION ADJUSTMENTS HERE IN DPLET, C THEN ALSO MAKE DIMENSION ADJUSTMENTS IN C DPLETF, DPFIT, DPPREF, DPPLOT, C COMPIM, AND COMPID. C CCCCC DIMENSION IA(225) DIMENSION IA(1000) DIMENSION PARAM(100) DIMENSION IPARN(100) DIMENSION IPARN2(100) C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C INCLUDE 'DPCOZI.INC' INCLUDE 'DPCOZZ.INC' C DIMENSION XTEMP3(MAXOBV) 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)) EQUIVALENCE (GARBAG(IGARB1),XTEMP3(1)) 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='DPLE' ISUBN2='T ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IERROR='NO' C ICASLE='UNKN' IMSUBC='UNKN' C C ***** THE FOLLOWING 6 LINES INSERTED AUGUST 1983 ***** CCCCC DO40I=1,225 DO40I=1,1000 ITYPEH(I)=' ' IW21HO(I)=' ' IW22HO(I)=' ' W2HOLD(I)=0.0 40 CONTINUE C C ************************** C ** TREAT THE LET 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 DPLET--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IANGLU,ISEED 52 FORMAT('IANGLU,ISEED = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IBUGA2,IBUGA3 53 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)IBUGCO,IBUGEV 54 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IBUGQ 55 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,56)MAXNXT 56 FORMAT('MAXNXT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,57)IFTEXP 57 FORMAT('IFTEXP = ',A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************* C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS ** C ********************************* C IF(NUMARG.GE.2.AND.IHARG(2).EQ.'= ')GOTO1019 IF(NUMARG.GE.3.AND.IHARG(3).EQ.'= ')GOTO1019 CCCCC JULY 1993. FOLLOWING LINE FOR SINGULAR VALUE DECOMPOSITION IF(NUMARG.GE.4.AND.IHARG(4).EQ.'= ')GOTO1019 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1011) 1011 FORMAT('***** ERROR IN DPLET--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1012) 1012 FORMAT(' IMPROPER FORM FOR THE LET ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1013) 1013 FORMAT(' NO EQUAL SIGN FOUND AFTER THE ', 1'VARIABLE/PARAMETER NAME.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1014) 1014 FORMAT(' THE ENTERED COMMAND LINE IS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1015)(IANS(I),I=1,IWIDTH) 1015 FORMAT(' ',120A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IF(IWIDTH.LE.0)WRITE(ICOUT,1016) 1016 FORMAT(1X) IF(IWIDTH.LE.0)CALL DPWRST('XXX','BUG ') GOTO9000 1019 CONTINUE C CCCCC IF(NUMARG.GE.3)GOTO1029 IF(NUMARG.GE.3.AND.IHARG(2).EQ.'= ')GOTO1029 IF(NUMARG.GE.4.AND.IHARG(3).EQ.'= ')GOTO1029 CCCCC JULY 1993. FOLLOWING LINE FOR SINGULAR VALUE DECOMPOSITION IF(NUMARG.GE.5.AND.IHARG(4).EQ.'= ')GOTO1029 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1021) 1021 FORMAT('***** ERROR IN DPLET--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1022) 1022 FORMAT(' IMPROPER FORM FOR THE LET ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1023) 1023 FORMAT(' NOTHING FOUND TO THE RIGHT OF THE EQUAL SIGN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1024) 1024 FORMAT(' THE ENTERED COMMAND LINE IS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1025)(IANS(I),I=1,IWIDTH) 1025 FORMAT(' ',120A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IF(IWIDTH.LE.0)WRITE(ICOUT,1026) 1026 FORMAT(1X) IF(IWIDTH.LE.0)CALL DPWRST('XXX','BUG ') GOTO9000 1029 CONTINUE C C ************************************** C ** STEP 2-- ** C ** TREAT THE VARIOUS LET SUBCASES ** C ************************************** C C ********************************************* C ** STEP 2.0-- ** C ** TREAT THE EXPERIMENT DESIGN ** C ** GENERATION SUBCASE ** C ********************************************* C CCCCC IF(IHARG(NUMARG).EQ.'DESI'.AND.IHARG2(NUMARG).EQ.'GN')GOTO1010 CCCCC GOTO1090 C C1010 CONTINUE CCCCC ICASLE='DESI' CCCCC CALL DPDESI(IBUGA3,IBUGQ,IFOUND,IERROR) CCCCC GOTO9000 C C1090 CONTINUE C C ********************************************* C ** STEP 2.11-- ** C ** TREAT THE SEQUENCE GENERATION SUBCASE ** C ********************************************* C IF(NUMARG.GE.4.AND.IHARG(3).EQ.'SEQU'.AND. 1IHARG(4).EQ.'DIFF')GOTO1190 IF(IHARG(3).EQ.'SEQU'.AND.IHARG2(3).EQ.'ENCE')GOTO1130 CCCCC THE FOLLOWING LINE WAS ADDED (DECEMBER 1988) CCCCC SO NEED NOT SPELL OUT SEQUENCE FULLY. (DECEMBER 1988) IF(IHARG(3).EQ.'SEQU')GOTO1130 CCCCC THE BRANCH POINT OF THE FOLLOWING LINE (DECEMBER) CCCCC WAS CHANGED FROM 1130 TO 1110 (DECEMBER 1988) CCCCC TO ELIMINATE THE CONFLICT OF FUNCTION EVALUATION VERSUS (DECEMBER 1988) CCCCC SEQUENCE GENERATION. FOR EXAMPLE, (DECEMBER 1988) CCCCC LET X = 1 +1 +5 YIELDING A NUMBER (1+1+5=7) (DECEMBER 1988) CCCCC OR YIELDING A SEQUENCE 1, 2, 3, 4, 5 (DECEMBER 1988) IF(NUMARG.GE.5.AND.IHARG(2).EQ.'='.AND. 1IARGT(3).EQ.'NUMB'.AND.IARGT(4).EQ.'NUMB'.AND. 1IARGT(5).EQ.'NUMB')GOTO1110 GOTO1190 C 1110 CONTINUE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** CAUTION FROM SUBROUTINE DPLET--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' DUE TO CONFLICTS WITH OTHER FORMS OF THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' LET COMMAND, THE 3-ARGUMENT SHORT-CUT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) 1114 FORMAT(' SYNTAX THAT YOU USED TO GENERATE A SEQUENCE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1115) 1115 FORMAT(' IS NOW (JANUARY 1989) ILLEGAL.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1116) 1116 FORMAT(' THE OPERATION WILL BE CARRIED OUT,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1117) 1117 FORMAT(' BUT IN THE FUTURE, PLEASE USE THE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1118) 1118 FORMAT(' FULL SYNTAX WHICH CONTAINS THE WORD') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1119) 1119 FORMAT(' SEQUENCE EXPLICITLY.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1120) 1120 FORMAT(' FOR EXAMPLE, REPLACE LET X = 1 1 10') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1121) 1121 FORMAT(' BY LET X = SEQUENCE 1 1 10') CALL DPWRST('XXX','BUG ') C IHAR14=IHARG(4) IHAR15=IHARG(5) IF((IHAR14(1:1).EQ.'+'.OR.IHAR14(1:1).EQ.'-').AND. 1(IHAR15(1:1).EQ.'+'.OR.IHAR15(1:1).EQ.'-'))GOTO1190 GOTO1130 C 1130 CONTINUE ICASLE='SEQU' CALL DPSEQU(IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 1190 CONTINUE C C ******************************************** C ** STEP 2.12-- ** C ** TREAT THE PATTERN GENERATION SUBCASE ** C ******************************************** C IF(IHARG(3).EQ.'PATT'.AND.IHARG2(3).EQ.'ERN ')GOTO1210 IF(IHARG(3).EQ.'DATA'.AND.IHARG2(3).EQ.' ')GOTO1210 GOTO1290 C 1210 CONTINUE ICASLE='PATT' CALL DPPAT(IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 1290 CONTINUE C C ************************************************** C ** STEP 2.13-- ** C ** TREAT THE RANDOM NUMBER GENERATION SUBCASE ** C ** (AND THE RANDOM PERMUTATION SUBCASE) ** C ** (AND THE BOOTSTRAP INDEX SUBCASE == THE ** C ** DISCRETE UNIFORM RANDOM NUMBER SUBCASE) ** C ************************************************** C CALL CKRAND(ICASRA,ILOCNU,IBUGA3,IFOUNR,IERROR) IF(IFOUNR.EQ.'YES')GOTO1310 GOTO1390 C 1310 CONTINUE ICASLE='RAND' CALL DPRAND(ICASRA,ISEED,ILOCNU, 1IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 1390 CONTINUE C C ******************************* C ** STEP 2.14-- ** C ** TREAT THE ROOTS SUBCASE ** C ******************************* C IF(IHARG(3).EQ.'ROOT'.AND.IHARG2(3).EQ.'S ')GOTO1400 IF(IHARG(3).EQ.'ROOT'.AND.IHARG2(3).EQ.' ')GOTO1400 IF(IHARG(3).EQ.'ZERO'.AND.IHARG2(3).EQ.'S ')GOTO1400 IF(IHARG(3).EQ.'ZERO'.AND.IHARG2(3).EQ.' ')GOTO1400 IF(IHARG(3).EQ.'SOLV'.AND.IHARG2(3).EQ.'E ')GOTO1400 GOTO1490 C 1400 CONTINUE ICASLE='ROOT' IFOUND='YES' CALL DPROOT(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IA,PARAM,IPARN,IPARN2, CCCCC ADD FOLLOWING LINE. FEBRUARY 1994. 1ROOTAC, 1IANGLU,IBUGA3,IBUGCO,IBUGEV,IBUGQ,IERROR) GOTO9000 C 1490 CONTINUE C C ************************************ C ** STEP 2.15-- ** C ** TREAT THE DERIVATIVE SUBCASE ** C ************************************ C IF(IHARG(3).EQ.'DERI'.AND.IHARG2(3).EQ.'VATI')GOTO1500 GOTO1590 C 1500 CONTINUE ICASLE='DERI' IFOUND='YES' ITYPEL='V' CALL DPDERV(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IA,PARAM,IPARN,IPARN2, 1IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1, 1NUMCL,NUMPL,NUMAOL,ITYW1L,ICAT1L,INLI1L,ITYW2L, 1NUMCR,NUMPR,NUMAOR,ITYW1R,ICAT1R,INLI1R,ITYW2R, 1IANGLU,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,IFOUND,IERROR) CCCCC WRITE(ICOUT,1511) C1511 FORMAT('***** THE DIFFERENTIATION CAPABILITY') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1512) C1512 FORMAT(' HAS NOT YET BEEN IMPLEMENTED') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1513) C1513 FORMAT(' AT THIS COMPUTER INSTALLATION.') CCCCC CALL DPWRST('XXX','BUG ') GOTO9000 C 1590 CONTINUE C C ********************************** C ** STEP 2.16-- ** C ** TREAT THE INTEGRAL SUBCASE ** C ********************************** C IF(IHARG(3).EQ.'INTE'.AND.IHARG2(3).EQ.'GRAL')GOTO1610 GOTO1690 C 1610 CONTINUE DO1620I=1,NUMARG IF(IHARG(I).EQ.'WRT ')GOTO1600 1620 CONTINUE GOTO1690 C 1600 CONTINUE ICASLE='INTE' IFOUND='YES' ITYPEL='V' CALL DPINTE(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IA,PARAM,IPARN,IPARN2, 1IANGLU,IBUGA3,IBUGCO,IBUGEV,IBUGQ,IERROR) GOTO9000 C 1690 CONTINUE C C ********************************************** C ** STEP 2.16B-- ** C ** TREAT THE NUMERICAL DERIVATIVE SUBCASE ** C ********************************************** C IF(IHARG(3).EQ.'NUME'.AND.IHARG(4).EQ.'DERI')THEN ICASLE='NDER' IFOUND='YES' ITYPEL='P' CALL DPNDER(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1 IA,PARAM,IPARN,IPARN2, 1 IANGLU,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,IERROR) GOTO9000 ENDIF C C C ************************************************* C ** STEP 2.17-- ** C ** TREAT THE RUNGE-KUTTA (DIFF. EQ.) SUBCASE ** C ************************************************* C IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'RUNG'.AND.IHARG(4).EQ.'KUTT')GOTO1700 IF(NUMARG.GE.5.AND. 1IHARG(4).EQ.'RUNG'.AND.IHARG(5).EQ.'KUTT')GOTO1700 GOTO1790 C 1700 CONTINUE ICASLE='RUNG' IFOUND='YES' ITYPEL='V' CALL DPRK(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IA,PARAM,IPARN,IPARN2, CCCCC THE FOLLOWING LINE WAS AUGMENTED SEPTEMBER 1993 CCCCC1IANGLU,IBUGA3,IBUGCO,IBUGEV,IBUGQ,IERROR) 1IANGLU,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,IERROR) GOTO9000 C 1790 CONTINUE C CCCCC FOLLOWING SECTION ADDED JUNE 1994. C ************************************** C ** STEP 2.18-- ** C ** TREAT THE OPTIMIZATION SUBCASE ** C ************************************** C IF(IHARG(3).EQ.'OPTI')GOTO1800 GOTO1890 C 1800 CONTINUE ICASLE='OPTI' IFOUND='YES' CALL DPOPT(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IA,PARAM,IPARN,IPARN2, CCCCC FEBRUARY 1995. ADD ARGUMENTS CCCCC1OPTACC, 1OPTACC,IOPTME,IOPTHE, 1ISUBRO,IBUGA3,IBUGCO,IBUGEV,IBUGQ,IERROR) GOTO9000 C 1890 CONTINUE C C ********************************************** C ** STEP 2.19-- ** C ** TREAT THE CHARACTER CODE SUBCASE ** C ********************************************** C IF(IHARG(3).EQ.'CHAR'.AND.IHARG(4).EQ.'CODE')THEN ICASLE='CCOD' IFOUND='YES' ITYPEL='V' CALL CODECH(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1 IA,PARAM,IPARN,IPARN2, 1 'ON ', 1 IBUGA3,ISUBRO,IERROR) GOTO9000 ENDIF C C ************************************************** C ** STEP 2.19B- ** C ** TREAT THE ALPHABETIC CHARACTER CODE SUBCASE ** C ************************************************** C IF(IHARG(3).EQ.'ALPH'.AND.IHARG(4).EQ.'CHAR'.AND. 1 IHARG(5).EQ.'CODE')THEN ICASLE='CCO2' IFOUND='YES' ITYPEL='V' CALL CODEC2(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1 IA,PARAM,IPARN,IPARN2, 1 'ON ', 1 IBUGA3,ISUBRO,IERROR) GOTO9000 ENDIF C C ********************************************** C ** STEP 2.19C-- ** C ** TREAT THE ROW LABEL SUBCASE ** C ********************************************** C IF(NUMARG.EQ.3.AND. 1 IHARG(1).EQ.'ROWL'.AND.IHARG2(1).EQ.'ABEL'.AND. 1 IHARG(2).EQ.'= ')THEN ICASLE='RLAB' IFOUND='YES' ITYPEL='V' CALL DPROLA(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1 IA,PARAM,IPARN,IPARN2, 1 'ON ', 1 IBUGA3,ISUBRO,IERROR) GOTO9000 ENDIF C C ********************************************** C ** STEP 2.19D-- ** C ** TREAT THE GROUP LABEL SUBCASE ** C ********************************************** C IF(IHARG(3).EQ.'GROU'.AND.IHARG(4).EQ.'LABE')THEN ICASLE='GLAB' IFOUND='YES' ITYPEL='V' IWRITE='ON ' CALL DPGROL(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1 IA,PARAM,IPARN,IPARN2, 1 IWRITE, 1 IBUGA3,ISUBRO,IERROR) GOTO9000 ENDIF C C ********************************************** C ** STEP 2.20-- ** C ** TREAT THE MATH CALCULATIONS SUBCASE ** C ** (INPUT = A VECTOR; OUTPUT = A VECTOR) ** C ********************************************** C CALL CKMATH(IBUGA3,ISUBRO,IFOUN7,ICASL7,ICASS7,IMSUBC,ILOCV) IF(IFOUN7.EQ.'YES'.AND.ICASL7.NE.'UNKN'.AND. 1ILOCV.GE.1)GOTO2000 GOTO2090 C 2000 CONTINUE ICASLE='MANI' CCCCC AUGUST 1995. ADD IFTORD ARGUMENT CCCCC OCTOBER 1998. BREAK DPMATC INTO 2 ROUTINES (STARTING TO CCCCC CHOKE SOME COMPILERS) CCCCC MAY 2002. ADD ISEED TO DPMAT2 CASE CCCCC CALL DPMATC(ICASL7,ILOCV,IFTEXP, IFOUND='NO' CALL DPMATC(ICASL7,ICASS7,ILOCV,IFTEXP,IFTORD, 1IMSUBC, 1ISEED, 1IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) IF(IFOUND.EQ.'YES')GOTO9000 CALL DPMAT2(ICASL7,ICASS7,ILOCV,IFTEXP,IFTORD, 1IMSUBC, 1ISEED, 1IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR) GOTO9000 C 2090 CONTINUE C CCCCC THE FOLLOWING SECTION WAS REWRITTEN OCTOBER 1991 C ********************************************* C ** STEP 2.21-- ** C ** TREAT THE ORDER STATISTIC MEDIAN GENERATION SUBCASE C ** UNIFORM DISTRIBUTION C ** NORMAL DISTRIBUTION C ** HALFNORMAL DISTRIBUTION C ** EV1 (GUMBEL) DISTRIBUTION C ** EV2 (FRECHET) DISTRIBUTION C ** WEIBULL DISTRIBUTION C ********************************************* C IF(NUMARG.GE.6.AND. 1IHARG(3).EQ.'UNIF'.AND.IHARG(4).EQ.'ORDE'.AND. 1IHARG(5).EQ.'STAT'.AND.IHARG(6).EQ.'MEDI')GOTO2110 C IF(NUMARG.GE.6.AND. 1IHARG(3).EQ.'NORM'.AND.IHARG(4).EQ.'ORDE'.AND. 1IHARG(5).EQ.'STAT'.AND.IHARG(6).EQ.'MEDI')GOTO2120 C IF(NUMARG.GE.6.AND. 1IHARG(3).EQ.'HALF'.AND.IHARG(4).EQ.'ORDE'.AND. 1IHARG(5).EQ.'STAT'.AND.IHARG(6).EQ.'MEDI')GOTO2130 IF(NUMARG.GE.7.AND. 1IHARG(3).EQ.'HALF'.AND.IHARG(4).EQ.'NORM'.AND. 1IHARG(5).EQ.'ORDE'.AND.IHARG(6).EQ.'STAT'.AND. 1IHARG(7).EQ.'MEDI')GOTO2130 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1993 IF(NUMARG.GE.6.AND. 1IHARG(3).EQ.'EV1'.AND.IHARG(4).EQ.'ORDE'.AND. 1IHARG(5).EQ.'STAT'.AND.IHARG(6).EQ.'MEDI')GOTO2140 IF(NUMARG.GE.6.AND. 1IHARG(3).EQ.'GUMB'.AND.IHARG(4).EQ.'ORDE'.AND. 1IHARG(5).EQ.'STAT'.AND.IHARG(6).EQ.'MEDI')GOTO2140 IF(NUMARG.GE.6.AND. 1IHARG(3).EQ.'EV2'.AND.IHARG(4).EQ.'ORDE'.AND. 1IHARG(5).EQ.'STAT'.AND.IHARG(6).EQ.'MEDI')GOTO2150 IF(NUMARG.GE.6.AND. 1IHARG(3).EQ.'FREC'.AND.IHARG(4).EQ.'ORDE'.AND. 1IHARG(5).EQ.'STAT'.AND.IHARG(6).EQ.'MEDI')GOTO2150 IF(NUMARG.GE.6.AND. 1IHARG(3).EQ.'WEIB'.AND.IHARG(4).EQ.'ORDE'.AND. 1IHARG(5).EQ.'STAT'.AND.IHARG(6).EQ.'MEDI')GOTO2160 C GOTO2190 C 2110 CONTINUE ICASLE='UOSM' CALL DPOSM(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 2120 CONTINUE ICASLE='NOSM' CALL DPOSM(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 2130 CONTINUE ICASLE='HOSM' CALL DPOSM(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1993 2140 CONTINUE ICASLE='E1OM' CALL DPOSM(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1993 2150 CONTINUE ICASLE='E2OM' CALL DPOSM(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1993 2160 CONTINUE ICASLE='WOSM' CALL DPOSM(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 2190 CONTINUE C C ********************************************* C ** STEP 2.24-- ** C ** TREAT THE WEIBULL ADJUSTED RANKS SUBCASE ZZ C ********************************************* C IF(NUMARG.GE.5.AND. 1IHARG(3).EQ.'WEIB'.AND.IHARG(4).EQ.'ADJU'.AND. 1IHARG(5).EQ.'RANK')GOTO2410 GOTO2490 C 2410 CONTINUE ICASLE='WEAR' CALL DPWEAR(IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 2490 CONTINUE C C ************************************************* C ** STEP 2.25-- ** C ** TREAT THE PRIME NUMBER GENERATION SUBCASE ** C ************************************************* C IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'PRIM'.AND.IHARG(4).EQ.'NUMB')GOTO2510 GOTO2590 C 2510 CONTINUE ICASLE='PRIM' CALL DPGENS(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 2590 CONTINUE C C ****************************************************** C ** STEP 2.26-- ** C ** TREAT THE FIBONNACCI NUMBER GENERATION SUBCASE ** C ****************************************************** C IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'FIBO'.AND.IHARG(4).EQ.'NUMB')GOTO2610 IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'FIBO'.AND.IHARG(4).EQ.'SEQU')GOTO2610 GOTO2690 C 2610 CONTINUE ICASLE='FIBO' CALL DPGENS(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 2690 CONTINUE C CCCCC THE FOLLOWING LOGISTIC SECTION WAS ADDED APRIL 1989 C ****************************************************** C ** STEP 2.27-- ** C ** TREAT THE LOGISTIC SEQUENCE GENERATION SUBCASE ** C ****************************************************** C IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'LOGI'.AND.IHARG(4).EQ.'NUMB')GOTO2710 IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'LOGI'.AND.IHARG(4).EQ.'SEQU')GOTO2710 IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'LOGI'.AND.IHARG(4).EQ.'SET')GOTO2710 GOTO2790 C 2710 CONTINUE ICASLE='LOGI' CALL DPGENS(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 2790 CONTINUE C CCCCC THE FOLLOWING CANTOR SET SECTION WAS ADDED APRIL 1989 CCCCC NOTE THAT SOME SUCCEEDING SECTIONS WERE RENUMBERED APRIL 1989 C ****************************************************** C ** STEP 2.28-- ** C ** TREAT THE CANTOR SET GENERATION SUBCASE ** C ****************************************************** C IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'CANT'.AND.IHARG(4).EQ.'NUMB')GOTO2810 IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'CANT'.AND.IHARG(4).EQ.'SEQU')GOTO2810 IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'CANT'.AND.IHARG(4).EQ.'SET')GOTO2810 GOTO2890 C 2810 CONTINUE ICASLE='CANT' CALL DPGENS(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 2890 CONTINUE C C ****************************************************** C ** STEP 2.29-- ** C ** TREAT THE BERNOULLI NUMBER GENERATION SUBCASE ** C ****************************************************** C IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'BERN'.AND.IHARG(4).EQ.'NUMB')GOTO2910 IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'BERN'.AND.IHARG(4).EQ.'SEQU')GOTO2910 GOTO2990 C 2910 CONTINUE ICASLE='BERN' CALL DPGENS(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 2990 CONTINUE C C C ****************************************************** C ** STEP 2.30-- ** C ** TREAT THE EULER NUMBER GENERATION SUBCASE ** C ****************************************************** C IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'EULE'.AND.IHARG(4).EQ.'NUMB')GOTO3010 IF(NUMARG.GE.4.AND. 1IHARG(3).EQ.'EULE'.AND.IHARG(4).EQ.'SEQU')GOTO3010 GOTO3090 C 3010 CONTINUE ICASLE='EULE' CALL DPGENS(ICASLE,IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 3090 CONTINUE C C C ************************************************** C ** STEP 2.41-- ** C ** TREAT THE STATISTICAL CALCULATIONS SUBCASE ** C ** (INPUT = A VECTOR; OUTPUT = A PARAMETER) ** C ************************************************** C CALL DPTYP2(IANS,IWIDTH,IHNAME,IHNAM2,NUMNAM,MAXNAM,IBUGA3, 1 IUSE,IVALUE,VALUE,IN, 1 IFOUNZ,IBEGIN,IEND, 1 ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1, 1 NUMCL,NUMPL,NUMAOL,ITYW1L,ICAT1L,INLI1L,ITYW2L, 1 NUMCR,NUMPR,NUMAOR,ITYW1R,ICAT1R,INLI1R,ITYW2R) C CCCCC THE FOLLOWING 2 LINES WERE ADDED JANUARY 1988 CALL CKARIT(IFOUNZ,IBEGIN,IANS,IWIDTH,ICASAR,IBUGA3) CCCCC THE FOLLOWING 10 LINES WERE ADDED FEBRUARY 1994 CCCCC TO ALLOW DETECTION OF THE FEBRUARY 1994 CCCCC LET A = (TAGUCHI) SN- Y COMMAND AND THE FEBRUARY 1994 CCCCC LET A = (TAGUCHI) SN+ Y COMMAND FEBRUARY 1994 C IF(NUMARG.GE.3)THEN IF(IHARG(3).EQ.'SN- ')GOTO4000 IF(IHARG(3).EQ.'SN+ ')GOTO4000 ENDIF IF(NUMARG.GE.4)THEN IF(IHARG(3).EQ.'TAGU')THEN IF(IHARG(4).EQ.'SN- ')GOTO4000 IF(IHARG(4).EQ.'SN+ ')GOTO4000 ENDIF ENDIF CCCCC THE FOLLOWING SECTION WAS ADDED MARCH 2003 CCCCC TO ALLOW DETECTION OF THE HODGES-LEHMAN AND CCCCC DIFFERENCE OF HODGES-LEHMAN C IF(NUMARG.GE.4)THEN IF(IHARG(3).EQ.'HODG'.AND.IHARG(4).EQ.'LEHM')GOTO4000 ENDIF IF(NUMARG.GE.6)THEN IF(IHARG(5).EQ.'HODG'.AND.IHARG(6).EQ.'LEHM')GOTO4000 ENDIF C IF(ICASAR.EQ.'YES')GOTO4190 C CCCCC THE FOLLOWING LINE WAS ADDED FEBRUARY 1994 4000 CONTINUE CALL CKSTAT(IBUGA3,IFOUN8,ICASL8,ILOCV) IF(IFOUN8.EQ.'YES'.AND.ICASL8.NE.'UNKN'.AND. 1ILOCV.GE.1)GOTO4100 GOTO4190 C 4100 CONTINUE ICASLE='STAT' CALL DPSTAC(ICASL8,ILOCV, 1IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1, 1TEMP,TEMP2,XTEMP1,XTEMP2,XTEMP3,MAXNXT, CCCCC JULY 2002. ADD FOLLOWING FOR HODGES-LEHMAN 1ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6, 1IBUGA3,IBUGQ,IFOUND,IERROR) GOTO9000 C 4190 CONTINUE C C *************************************** C ** STEP 2.42-- ** C ** TREAT THE INTERPOLATION SUBCASE ** C *************************************** C IF(IHARG(3).EQ.'INTE'.AND.IHARG2(3).EQ.'RPOL')GOTO4210 GOTO4290 C 4210 CONTINUE DO4220I=1,NUMARG IF(IHARG(I).EQ.'WRT ')GOTO4200 4220 CONTINUE GOTO4290 C 4200 CONTINUE ICASLE='INTR' IFOUND='YES' ITYPEL='V' CCCCC CALL DPINTR(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, CCCCC1IA,PARAM,IPARN,IPARN2, CCCCC1IANGLU,IBUGA3,IBUGQ,IBUGCO,IBUGEV,IERROR) GOTO9000 C 4290 CONTINUE C C ****************************************************** C ** STEP 2.43-- ** C ** TREAT THE (SIMULATED) EXPERIMENT SUBCASE ** C ****************************************************** C IF(NUMARG.GE.3.AND.IHARG(3).EQ.'EXPE')GOTO4310 GOTO4390 C 4310 CONTINUE CCCCC ICASLE='EXPE' CCCCC CALL DPEXPE(ICASEX,ITEXEX,IPAGEX,ISEED, CCCCC1IBUGA3,IBUGQ,IFOUND,IERROR) CCCCC GOTO9000 C 4390 CONTINUE C C ********************************************* C ** STEP 2.50-- ** C ** TREAT THE FUNCTION EVALUATION SUBCASE ** C ********************************************* C 5000 CONTINUE ICASLE='FUNC' CALL DPFUEV(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IA,PARAM,IPARN,IPARN2, 1IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1, 1NUMCL,NUMPL,NUMAOL,ITYW1L,ICAT1L,INLI1L,ITYW2L, 1NUMCR,NUMPR,NUMAOR,ITYW1R,ICAT1R,INLI1R,ITYW2R, 1IANGLU,IBUGA3,IBUGCO,IBUGEV,IBUGQ,IFOUND,IERROR) GOTO9000 C C ********************************* C ** STEP 80-- ** C ** GENERATE AN ERROR MESSAGE ** C ** (IF NECESSARY) ** C ********************************* C C8000 CONTINUE CCCCC IERROR='YES' CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,8071) C8071 FORMAT('***** ERROR IN DPLET--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,8072) C8072 FORMAT(' IMPROPER FORM FOR THE LET ', CCCCC CALL DPWRST('XXX','BUG ') CCCCC1'COMMAND') CCCCC WRITE(ICOUT,8073) C8073 FORMAT(' IMPROPER SYNTAX') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,8074)ICASLE C8074 FORMAT(' ICASLE = ',A4) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,8075) C8075 FORMAT(' THE ENTERED COMMAND LINE IS AS FOLLOWS--') CCCCC CALL DPWRST('XXX','BUG ') CCCCC IF(IWIDTH.GE.1)WRITE(ICOUT,8076)(IANS(I),I=1,IWIDTH) C8076 FORMAT(' ',120A1) CCCCC IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') CCCCC IF(IWIDTH.LE.0)WRITE(ICOUT,8077) C8077 FORMAT(1X) CCCCC IF(IWIDTH.LE.0)CALL DPWRST('XXX','BUG ') CCCCC GOTO9000 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 DPLET--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IANGLU,ISEED 9012 FORMAT('IANGLU,ISEED = ',A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)IBUGA2,IBUGA3 9013 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)IBUGCO,IBUGEV 9014 FORMAT('IBUGCO,IBUGEV = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IBUGQ 9015 FORMAT('IBUGQ = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)ICASLE,IMSUBC 9016 FORMAT('ICASLE,IMSUBC = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9017)IFOUND,IERROR 9017 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9018)IFTEXP 9018 FORMAT('IFTEXP = ',A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPLETE(IANS,IWIDTH) C C PURPOSE--GENERATE AN ERROR MESSAGE C IN CONNECTION WITH THE LET COMMAND. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--SEPTEMBER 1980. C UPDATED --SEPTEMBER 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IANS C C--------------------------------------------------------------------- C 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 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101) 101 FORMAT('***** ERROR (FROM DPLETE) IN DPTYP2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) 102 FORMAT(' ILLEGAL OR UNKNOWN SYNTAX FOR THE LET COMMAND') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)(IANS(I),I=1,IWIDTH) 103 FORMAT(' COMMAND LINE--',80A1) CALL DPWRST('XXX','BUG ') C RETURN END SUBROUTINE DPLETF(IANGLU,IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO, CCCCC APRIL 1996. ADD FOLLOWING ARGUMENT 1ISFLAG, 1IFOUND,IERROR) C C PURPOSE--CARRY OUT THE LET FUNCTION COMMAND. C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 1977. C UPDATED --OCTOBER 1978. C UPDATED --NOVEMBER 1978. C UPDATED --JANUARY 1979. C UPDATED --FEBRUARY 1979. C UPDATED --JUNE 1979. C UPDATED --JULY 1979. C UPDATED --SEPTEMBER 1980. C UPDATED --JUNE 1981. C UPDATED --JULY 1981. C UPDATED --SEPTEMBER 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --APRIL 1996. PRESERVE CASE FOR LET STRING C UPDATED --AUGUST 2005. CODE FOR LET FUNCTION ... = DERIVATIVE C WAS NOT BEING RECOGNIZED C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IANGLU CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGCO CHARACTER*4 IBUGEV CHARACTER*4 IBUGQ CHARACTER*4 ISUBRO CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ICASLF C CHARACTER*4 IFOUNZ CHARACTER*4 ITYPE CHARACTER*4 IHOL CHARACTER*4 IHOL2 CHARACTER*4 IERRO1 CHARACTER*4 ITYPEH CHARACTER*4 IW21HO CHARACTER*4 IW22HO CHARACTER*4 IA CHARACTER*4 IPARN CHARACTER*4 IPARN2 CHARACTER*4 ITYW1L CHARACTER*4 ICAT1L CHARACTER*4 INLI1L CHARACTER*4 ITYW2L CHARACTER*4 ITYW1R CHARACTER*4 ICAT1R CHARACTER*4 INLI1R CHARACTER*4 ITYW2R C CHARACTER*4 ITYPEL C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC APRIL 1996. ADD FOLLOWING LINE CHARACTER*10 ISFLAG CHARACTER*4 ISTEPN C DIMENSION IFOUNZ(30) DIMENSION IBEGIN(30) DIMENSION IEND(30) DIMENSION ITYPE(30) DIMENSION IHOL(30) DIMENSION IHOL2(30) DIMENSION INT1(30) DIMENSION FLOAT1(30) DIMENSION IERRO1(30) C CCCCC DIMENSION ITYPEH(225) CCCCC DIMENSION IW21HO(225) CCCCC DIMENSION IW22HO(225) CCCCC DIMENSION W2HOLD(225) DIMENSION ITYPEH(1000) DIMENSION IW21HO(1000) DIMENSION IW22HO(1000) DIMENSION W2HOLD(1000) C C NOTE--THE DIMENSION OF IA SHOULD BE THE SAME AS C THE DIMENSION OF IB IN SUBROUTINE COMPIM C (THE DIMENSION OF IB IS 1000 (JULY 1986)). C CCCCC DIMENSION IA(225) DIMENSION IA(1000) DIMENSION PARAM(100) DIMENSION IPARN(100) DIMENSION IPARN2(100) 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='DPLE' ISUBN2='TF ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IERROR='NO' C ICASLF='UNKN' C C ***** THE FOLLOWING 6 LINES INSERTED AUGUST 1983 ***** CCCCC DO40I=1,225 DO40I=1,1000 ITYPEH(I)=' ' IW21HO(I)=' ' IW22HO(I)=' ' W2HOLD(I)=0.0 40 CONTINUE C C *********************************** C ** TREAT THE LET FUNCTION 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 DPLETF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IBUGA2,IBUGA3 52 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C C ********************************* C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS ** C ********************************* C ISTEPN='1' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.3.AND.IHARG(3).EQ.'= '.AND. 1IHARG2(3).EQ.' ')GOTO1119 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1111) 1111 FORMAT('***** ERROR IN DPLETF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1112) 1112 FORMAT(' IMPROPER FORM FOR THE LET FUNCTION ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1113) 1113 FORMAT(' NO EQUAL SIGN FOUND AFTER THE FUNCTION NAME') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1114) 1114 FORMAT(' THE ENTERED COMMAND LINE IS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1115)(IANS(I),I=1,IWIDTH) 1115 FORMAT(' ',120A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IF(IWIDTH.LE.0)WRITE(ICOUT,1116) 1116 FORMAT(1X) IF(IWIDTH.LE.0)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1119 CONTINUE C IF(NUMARG.GE.4)GOTO1129 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1121) 1121 FORMAT('***** ERROR IN DPLETF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1122) 1122 FORMAT(' IMPROPER FORM FOR THE LET FUNCTION ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1123) 1123 FORMAT(' NOTHING FOUND TO THE RIGHT OF THE EQUAL SIGN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1124) 1124 FORMAT(' THE ENTERED COMMAND LINE IS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)WRITE(ICOUT,1125)(IANS(I),I=1,IWIDTH) 1125 FORMAT(' ',120A1) IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ') IF(IWIDTH.LE.0)WRITE(ICOUT,1126) 1126 FORMAT(1X) IF(IWIDTH.LE.0)CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1129 CONTINUE C C ***************************************** C ** STEP 2-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE ** C ***************************************** C ISTEPN='2' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CCCCC FEBRUARY 2003: CHECK WHETHER FUNCTION OR STRING IS CCCCC BEING CALLED FOR. CCCCC AUGUST 2005: CHECK FOR 'FUNC' SHOULD BE IN IHARG(1), NOT CCCCC NOT IHARG(2) C IF(IHARG(4).EQ.'DERI'.AND.IHARG2(4).EQ.'VATI')THEN IF(IHARG(1).EQ.'FUNC')GOTO1140 ENDIF IF(IHARG(4).EQ.'DIFF'.AND.IHARG2(4).EQ.'EREN')THEN IF(IHARG(1).EQ.'FUNC')GOTO1140 ENDIF IF(IHARG(4).EQ.'PART'.AND.IHARG2(4).EQ.'IAL ')THEN IF(IHARG(1).EQ.'FUNC')GOTO1140 ENDIF C IF(IHARG(4).EQ.'INTE'.AND.IHARG2(4).EQ.'GRAL')THEN IF(IHARG(1).EQ.'FUNC')GOTO1150 ENDIF C GOTO1130 C C ********************************************* C ** STEP 3.1-- ** C ** TREAT THE FUNCTION DEFINITION SUBCASE ** C ********************************************* C 1130 CONTINUE C ISTEPN='3.1' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFOUND='YES' ICASLF='DEFI' CCCCC APRIL 1996. ADD ISFLAG ARGUMENT CCCCC CALL DPFUNC(IBUGA3,IERROR) CALL DPFUNC(IBUGA3,IERROR,ISFLAG) GOTO9000 C C ********************************************* C ** STEP 3.2-- ** C ** TREAT THE ANALYTIC DERIVATIVE SUBCASE ** C ********************************************* C 1140 CONTINUE C ISTEPN='3.2' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFOUND='YES' ICASLF='DERI' C CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1141) C1141 FORMAT('***** NOTE--THE DIFFERENTIATION ') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1142) C1142 FORMAT(' CAPABILITY HAS BEEN TEMPORARILY ') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1143) C1143 FORMAT(' DISCONNECTED (FOR DEBUGGING PURPOSES)') CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1144) C1144 FORMAT(' FROM DATAPLOT') CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO9000 C CCCCC CALL DPDERV(ICASLF,IHARG,IARG,ARG,IARGT,NUMARG,IHNAME,IVALUE, CCCCC1VALUE,IUSE,IN,NUMNAM,MAXNAM,IANS,IWIDTH,IANGLE,NUMCOL,MAXCOL, CCCCC1V,PRED,RES,N,MAXN, CCCCC1IFSTAR,IFSTOP,IFUNC,NCTIF,MAXNIF,IFUNC2,IFUNC3, CCCCC1ITYPEH,IW2HOL,W2HOLD,NWHOLD, CCCCC1IBUGA3,IBUGQ,ISUB,NS,IERROR) ICASLF='DERI' IFOUND='YES' CCCCC ITYPEL='V' ITYPEL='F' CALL DPDERV(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD, 1IA,PARAM,IPARN,IPARN2, 1IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1, 1NUMCL,NUMPL,NUMAOL,ITYW1L,ICAT1L,INLI1L,ITYW2L, 1NUMCR,NUMPR,NUMAOR,ITYW1R,ICAT1R,INLI1R,ITYW2R, 1IANGLU,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,IFOUND,IERROR) GOTO9000 C C ********************************************* C ** STEP 3.3-- ** C ** TREAT THE INDEFINITE INTEGRAL SUBCASE ** C ********************************************* C 1150 CONTINUE C ISTEPN='3.3' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IFOUND='YES' ICASLF='INTE' C WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** NOTE--THE INTEGRATION ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' CAPABILITY HAS BEEN TEMPORARILY ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' DISCONNECTED (FOR DEBUGGING PURPOSES)') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154) 1154 FORMAT(' FROM DATAPLOT') CALL DPWRST('XXX','BUG ') GOTO9000 C CCCCC CALL DPINTG(ICASLF,IHARG,IARG,ARG,IARGT,NUMARG,IHNAME,IVALUE, CCCCC1VALUE,IUSE,IN,NUMNAM,MAXNAM,IANS,IWIDTH,IANGLE,NUMCOL,MAXCOL, CCCCC1V,PRED,RES,N,MAXN, CCCCC1IFSTAR,IFSTOP,IFUNC,NCTIF,MAXNIF,IFUNC2,IFUNC3, CCCCC1ITYPEH,IW2HOL,W2HOLD,NWHOLD, CCCCC1IBUGIN,IBUGQ,ISUB,NS,IERROR) CCCCC GOTO9000 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 DPLETF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3 9012 FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)ICASLF 9014 FORMAT('ICASLF = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUND,IERROR 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPLETH(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH, 1MAXLEG,PLEGTH,IFOUND,IERROR) C C PURPOSE--DEFINE THE THICKNESS FOR A LEGEND. C THE THICKNESS FOR LEGEND I WILL BE PLACED C IN THE I-TH ELEMENT OF THE REAL C VECTOR PLEGTH(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --ARG (A REAL VECTOR) C --NUMARG C --PDEFTH C --MAXLEG C OUTPUT ARGUMENTS--PLEGTH (A REAL VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C THICKNESS FOR LEGEND I. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--ALAN HECKERT C COMPUTER SERVICES DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89/2 C ORIGINAL VERSION--JANUARY 1989. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IFOUND CHARACTER*4 IERROR C C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) DIMENSION ARG(*) C DIMENSION PLEGTH(*) 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)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'THIC')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'THIC')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE PHOLD=PDEFTH GOTO1130 C 1125 CONTINUE PHOLD=ARG(2) GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXLEG PLEGTH(I)=PHOLD 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)PLEGTH(I) 1136 FORMAT('ALL LEGEND THICKNESSS HAVE JUST BEEN SET TO ', 1E15.7) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPLETH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE LEGEND ... THICKNESS COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE LEGEND IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' LEGEND 3 THICKNESS 0.3') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXLEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPLETH--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE LEGEND ... THICKNESS COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF LEGENDS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXLEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'LEGEND.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE PHOLD=PDEFTH GOTO1180 C 1175 CONTINUE PHOLD=ARG(3) GOTO1180 C 1180 CONTINUE IFOUND='YES' PLEGTH(I)=PHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,PLEGTH(I) 1186 FORMAT('THE THICKNESS FOR LEGEND ',I8, 1' HAS JUST BEEN SET TO ',E15.7) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPLEUN(IHARG,IARGT,IARG,NUMARG,IDEFUZ, 1MAXLEG,ILEGUN,IFOUND,IERROR) C C PURPOSE--DEFINE THE UNITS FOR A LEGEND. C (SCREEN OR DATA). C THE UNITS FOR LEGEND I WILL BE PLACED C IN THE I-TH ELEMENT OF THE HOLLERITH C VECTOR ILEGUN(.). C INPUT ARGUMENTS--IHARG (A HOLLERITH VECTOR) C --IARGT (A HOLLERITH VECTOR) C --IARG (A HOLLERITH VECTOR) C --NUMARG C --IDEFUZ C --MAXLEG C OUTPUT ARGUMENTS--ILEGUN (A HOLLERITH VECTOR C WHOSE I-TH ELEMENT CONTAINS THE C UNITS FOR LEGEND I. C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--99/12 C ORIGINAL VERSION--DECEMBER 1999. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IARGT CHARACTER*4 IDEFUZ CHARACTER*4 ILEGUN CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IHOLD C C--------------------------------------------------------------------- C DIMENSION IHARG(*) DIMENSION IARGT(*) DIMENSION IARG(*) C DIMENSION ILEGUN(*) 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)GOTO1199 IF(NUMARG.GE.1.AND.IHARG(1).EQ.'UNIT')GOTO1110 IF(NUMARG.GE.2.AND.IHARG(2).EQ.'UNIT')GOTO1140 GOTO1199 C 1110 CONTINUE IF(NUMARG.LE.1)GOTO1120 IF(IHARG(2).EQ.'ON')GOTO1120 IF(IHARG(2).EQ.'OFF')GOTO1120 IF(IHARG(2).EQ.'AUTO')GOTO1120 IF(IHARG(2).EQ.'DEFA')GOTO1120 GOTO1125 C 1120 CONTINUE IHOLD=IDEFUZ GOTO1130 C 1125 CONTINUE IHOLD=IHARG(2) IF(IHOLD.NE.'DATA')IHOLD='SCRE' GOTO1130 C 1130 CONTINUE IFOUND='YES' DO1135I=1,MAXLEG ILEGUN(I)=IHOLD 1135 CONTINUE C IF(IFEEDB.EQ.'OFF')GOTO1139 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') I=1 WRITE(ICOUT,1136)ILEGUN(I) 1136 FORMAT('ALL LEGEND UNITSS HAVE JUST BEEN SET TO ', 1A4) CALL DPWRST('XXX','BUG ') 1139 CONTINUE GOTO1199 C 1140 CONTINUE IF(IARGT(1).EQ.'NUMB')GOTO1150 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1141) 1141 FORMAT('***** ERROR IN DPLEUN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1142) 1142 FORMAT(' IN THE LEGEND ... UNITS COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1143) 1143 FORMAT(' THE LEGEND IS IDENTIFIED BY A NUMBER, AS IN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1144) 1144 FORMAT(' LEGEND 3 UNITS DATA') CALL DPWRST('XXX','BUG ') GOTO1199 C 1150 CONTINUE I=IARG(1) IF(1.LE.I.AND.I.LE.MAXLEG)GOTO1160 IERROR='YES' WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1151) 1151 FORMAT('***** ERROR IN DPLEUN--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1152) 1152 FORMAT(' IN THE LEGEND ... UNITS COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1153) 1153 FORMAT(' THE NUMBER OF LEGENDS MUST BE ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1154)MAXLEG 1154 FORMAT(' BETWEEN 1 AND ',I8,' (INCLUSIVELY);') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1155) 1155 FORMAT(' SUCH WAS NOT THE CASE HERE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1156)I 1156 FORMAT(' A REFERENCE WAS MADE TO THE ',I8,'-TH ', 1'LEGEND.') CALL DPWRST('XXX','BUG ') GOTO1199 C 1160 CONTINUE IF(NUMARG.LE.2)GOTO1170 IF(IHARG(3).EQ.'ON')GOTO1170 IF(IHARG(3).EQ.'OFF')GOTO1170 IF(IHARG(3).EQ.'AUTO')GOTO1170 IF(IHARG(3).EQ.'DEFA')GOTO1170 GOTO1175 C 1170 CONTINUE IHOLD=IDEFUZ GOTO1180 C 1175 CONTINUE IHOLD=IHARG(3) IF(IHOLD.NE.'DATA')IHOLD='SCRE' GOTO1180 C 1180 CONTINUE IFOUND='YES' ILEGUN(I)=IHOLD C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1186)I,ILEGUN(I) 1186 FORMAT('THE UNITS FOR LEGEND ',I8, 1' HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE GOTO1199 C 1199 CONTINUE RETURN END SUBROUTINE DPLF(IHARG,NUMARG, 1IDEFLF, 1ITEXLF, 1IBUGD2,ISUBRO,IFOUND,IERROR) C C PURPOSE--DEFINE THE LINE FEED SWITCH (ON OR OFF) FOR C TEXT SCRIPT. C THE LINE FEED SWITCH WILL BE PLACED C IN THE CHARACTER VARIABLE ITEXLF. C INPUT ARGUMENTS--IHARG (A CHARACTER VECTOR) C --NUMARG C --IDEFLF C --IBUGD2 C OUTPUT ARGUMENTS--ITEXLF C --IFOUND ('YES' OR 'NO' ) C --IERROR ('YES' OR 'NO' ) C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--APRIL 1981. C UPDATED --MAY 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHARG CHARACTER*4 IDEFLF CHARACTER*4 ITEXLF 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 DPLF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)IDEFLF 53 FORMAT('IDEFLF = ',A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)NUMARG 54 FORMAT('NUMARG = ',I8) 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 LINE FEED CASE ** C ******************************** C IF(NUMARG.LE.0)GOTO1161 IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'FEED')GOTO1161 IF(IHARG(NUMARG).EQ.'ON')GOTO1161 IF(IHARG(NUMARG).EQ.'OFF')GOTO1162 IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161 IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165 GOTO1170 C 1161 CONTINUE ITEXLF='ON' GOTO1180 C 1162 CONTINUE ITEXLF='OFF' GOTO1180 C 1165 CONTINUE ITEXLF=IDEFLF GOTO1180 C 1170 CONTINUE IERROR='YES' WRITE(ICOUT,1171) 1171 FORMAT('***** ERROR IN DPLF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1172) 1172 FORMAT(' ILLEGAL ENTRY FOR LINE FEED ', 1'COMMAND.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1173) 1173 FORMAT(' TEST EXAMPLE TO DEMONSTRATE THE ', 1'PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1174) 1174 FORMAT(' SUPPOSE THE THE ANALYST WISHES ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1175) 1175 FORMAT(' TO HAVE A LINE FEED AFTER THE TEXT ', 1'COMMAND,') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1177) 1177 FORMAT(' THEN ALLOWABLE FORMS ARE--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1178) 1178 FORMAT(' LINE FEED ON (OR LF ON) ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1179) 1179 FORMAT(' LINE FEED (OR LF) ') CALL DPWRST('XXX','BUG ') GOTO9000 C 1180 CONTINUE IFOUND='YES' C IF(IFEEDB.EQ.'OFF')GOTO1189 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1181) 1181 FORMAT('THE LINE FEED (AFTER TEXT) ') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1182)ITEXLF 1182 FORMAT('HAS JUST BEEN SET TO ',A4) CALL DPWRST('XXX','BUG ') 1189 CONTINUE 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 DPLF') 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)IDEFLF,ITEXLF 9013 FORMAT('IDEFLF,ITEXLF = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPLIB1(IH,IH2,X,SAVE1,SAVE2,SAVE3,I,IANGLU, 1TERM,IBUGEV,IFOUND,IERROR) C C PURPOSE--PERFORM A LIBRARY FUNCTION EVALUATION. C NOTE--THIS IS PART 1 C (EVALUATE MANY OF THE USUAL FORTRAN LIBRARY FUNCTIONS) C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JANUARY 1979. C UPDATED --NOVEMBER 1979. C UPDATED --FEBRUARY 1981. C UPDATED --JUNE 1981. C UPDATED --JULY 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JULY 1986. C UPDATED --JUNE 1987. FRACT(.) C UPDATED --SEPTEMBER 1987. ROUND(.) C UPDATED --SEPTEMBER 1987. LSD(.) C UPDATED --SEPTEMBER 1988. IND(.) = INDICATOR FUNCTION C UPDATED --OCTOBER 1988. ROUND(.) WITH 2ND ARGUMENT C UPDATED --DECEMBER 1988. LSD(.) RENAMED AS MSD(.) C UPDATED --MARCH 1989. JULIA(.) C UPDATED --MARCH 1989. SAVE3 AS INPUT ARGUMENT (JULIA) C UPDATED --JANUARY 1990. BINPAT(.,.) C UPDATED --FEBRUARY 1993. ARG CHECK FOR ROUND() C UPDATED --JULY 1993. FIX JULIA (ALAN) C UPDATED --SEPTEMBER 1994. ADD BETA, BETAI, LNBETA (FOR C COMPLETE, INCOMPLETE BETA, C LOG BETA) C UPDATED --SEPTEMBER 1994. GAMMAI (INCOMPLETE GAMMA) C UPDATED --SEPTEMBER 1994. GAMMAR (RECIPROCAL GAMMA) C UPDATED --SEPTEMBER 1994. DIGAMMA (DIGAMMA) C UPDATED --SEPTEMBER 1994. TRICOMI (TRICOMI GAMMA) C UPDATED --SEPTEMBER 1994. GAMMAIC (COMPLEMENTARY C INCOMPLETE GAMMA) C UPDATED --SEPTEMBER 1994. POCH (POCHHAMMER GENERALIZED C SYMBOL) C UPDATED --SEPTEMBER 1994. POCH (POCHHAMMER GENERALIZED C SYMBOL FIRST ORDER) C UPDATED --SEPTEMBER 1994. CHU (LOG CONFLUENT HYPERGE.) C UPDATED --MARCH 1995. HEAVE (HEAVESIDE FUNCTION) C UPDATED --MARCH 1995. STEP (STEP FUNCTION) C UPDATED --MARCH 1995. CEIL (CEILING FUNCTION) C UPDATED --MARCH 1995. GCD (GREATEST COMMON DIVISOR FUNCTION) C UPDATED --JANUARY 1997. ADD LOGBETA AND LNGAMMA AS C SYNONYMS C UPDATED --MARCH 1997. ADD LAMBDA, STRUVE FUNCTIONS C UPDATED --JULY 1997. CHM (M CONFLUENT HYPERGEOMETRIC) C UPDATED --AUGUST 1997. CGAMMA, CGAMMAI (COMPLEX GAMMA) C UPDATED --AUGUST 1997. CLNGAM, CLNGAM (COMPLEX LOG GAMMA) C UPDATED --AUGUST 1997. CPSI, CPSII (COMPLEX PSI) C UPDATED --AUGUST 1997. HYPERGEO (HYPERGEOMETRIC) C UPDATED --AUGUST 1997. PARABOLIC CYLINDER FUNCTIONS C PBDV, PBDV1 C PBVV, PBVV1 C PBWA, PBWA1 C UPDATED --AUGUST 1997. CLNBETA, CLNBETAI (COMPLEX C LOG BETA) C UPDATED --AUGUST 1997. CBETA, CBETAI (COMPLEX BETA) C UPDATED --SEPTEMBER 1997. PSI SYNONYM FOR DIGAMMA C UPDATED --SEPTEMBER 1997. KELVIN FUNCTIONS C (BER, BERI, BER1, BERI1, C KER, KERI, KER1, KERI1) C UPDATED --SEPTEMBER 1997. ZETA, ETA, CATLAN BETA C UPDATED --OCTOBER 1997. PSIFN C UPDATED --APRIL 1998. ADD IGACDF, IGAPDF, IGAPPF C (INVERTED GAMMA) C UPDATED --APRIL 1998. ADD SUPPORT FOR LOCATION AND C SCALE PARAMETERS WHERE C APPROPRIATE FOR CDF, PDF, C PPF, AND SF FUNCTIONS C UPDATED --MAY 2002. FERMDIRA C UPDATED --MAY 2006. HARMNUMB C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IANGLU CHARACTER*4 IBUGEV CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ISIGN C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C FOLLOWING SECTION ADDED SEPTEMBER 1994. C DOUBLE PRECISION DTEMP1(1000) DOUBLE PRECISION DTEMP2(1000) DOUBLE PRECISION DRESLT DOUBLE PRECISION DRSLT2 DOUBLE PRECISION DRSLT3 DOUBLE PRECISION DRSLT4 DOUBLE PRECISION DRSLT5 DOUBLE PRECISION DRSLT6 DOUBLE PRECISION DRSLT7 DOUBLE PRECISION DRSLT8 DOUBLE PRECISION DARG1 DOUBLE PRECISION DARG2 DOUBLE PRECISION DARG3 DOUBLE PRECISION DARG4 DOUBLE PRECISION DBETAI DOUBLE PRECISION DBETA DOUBLE PRECISION DLBETA DOUBLE PRECISION DGAMI DOUBLE PRECISION DGAMR DOUBLE PRECISION DGAMIP DOUBLE PRECISION DGAMIC DOUBLE PRECISION DGAMIT DOUBLE PRECISION DPOCH DOUBLE PRECISION DPOCH1 DOUBLE PRECISION DPSI DOUBLE PRECISION DCHU DOUBLE PRECISION FDM0P5 DOUBLE PRECISION FDP0P5 DOUBLE PRECISION FDP1P5 DOUBLE PRECISION FDP2P5 C C FOLLOWING SECTION ADDED AUGUST 1997 C COMPLEX ZRESLT COMPLEX ZARG COMPLEX CPSI 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 PI/3.1415926536/ C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPLI' ISUBN2='B1 ' C IF(IBUGEV.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPLIB1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IH,IH2,X 52 FORMAT('IH,IH2,X = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)SAVE1,SAVE2,SAVE3,I,IANGLU 53 FORMAT('SAVE1,SAVE2,SAVE3,I,IANGLU = ',3E15.7,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)TERM,IBUGEV,NUMBPW 54 FORMAT('TERM,IBUGEV,NUMBPW = ',E15.7,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IFOUND,IERROR 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IFOUND='YES' C IF(IH.EQ.'SQRT'.AND.IH2.EQ.' ')GOTO401 IF(IH.EQ.'EXP '.AND.IH2.EQ.' ')GOTO402 IF(IH.EQ.'LN '.AND.IH2.EQ.' ')GOTO403 IF(IH.EQ.'LOG '.AND.IH2.EQ.' ')GOTO403 IF(IH.EQ.'LOGE'.AND.IH2.EQ.' ')GOTO403 IF(IH.EQ.'LOG2'.AND.IH2.EQ.' ')GOTO405 IF(IH.EQ.'ALOG'.AND.IH2.EQ.' ')GOTO403 IF(IH.EQ.'ALOG'.AND.IH2.EQ.'E ')GOTO403 IF(IH.EQ.'LOG1'.AND.IH2.EQ.'0 ')GOTO404 IF(IH.EQ.'ALOG'.AND.IH2.EQ.'10 ')GOTO404 C IF(IH.EQ.'ATAN'.AND.IH2.EQ.' ')GOTO463 IF(IH.EQ.'ATAN'.AND.IH2.EQ.'2 ')GOTO408 IF(IH.EQ.'ABS '.AND.IH2.EQ.' ')GOTO410 IF(IH.EQ.'AINT'.AND.IH2.EQ.' ')GOTO411 IF(IH.EQ.'INT '.AND.IH2.EQ.' ')GOTO411 IF(IH.EQ.'INTE'.AND.IH2.EQ.'GER ')GOTO411 IF(IH.EQ.'AMOD'.AND.IH2.EQ.' ')GOTO412 IF(IH.EQ.'MOD '.AND.IH2.EQ.' ')GOTO412 IF(IH.EQ.'MODU'.AND.IH2.EQ.'LO ')GOTO412 IF(IH.EQ.'SIGN'.AND.IH2.EQ.' ')GOTO413 IF(IH.EQ.'FRAC'.AND.IH2.EQ.'T ')GOTO414 CCCCC THE FOLLOWING LINE WAS COMMENTED OUT DECEMBER 1988 CCCCC AND REPLACED BY THE SUCCEEDING LINE (DECEMBER 1988) CCCCC IF(IH.EQ.'LSD '.AND.IH2.EQ.' ')GOTO415 IF(IH.EQ.'MSD '.AND.IH2.EQ.' ')GOTO415 IF(IH.EQ.'ROUN'.AND.IH2.EQ.'D ')GOTO417 IF(IH.EQ.'IND '.AND.IH2.EQ.' ')GOTO418 IF(IH.EQ.'OCTA'.AND.IH2.EQ.'L ')GOTO421 IF(IH.EQ.'OCTD'.AND.IH2.EQ.'EC ')GOTO421 IF(IH.EQ.'DECO'.AND.IH2.EQ.'CT ')GOTO422 C IF(IH.EQ.'ERF '.AND.IH2.EQ.' ')GOTO441 IF(IH.EQ.'ERFC'.AND.IH2.EQ.' ')GOTO442 IF(IH.EQ.'MIN '.AND.IH2.EQ.' ')GOTO443 IF(IH.EQ.'MAX '.AND.IH2.EQ.' ')GOTO444 IF(IH.EQ.'GAMM'.AND.IH2.EQ.'A ')GOTO445 IF(IH.EQ.'LOGG'.AND.IH2.EQ.'AMMA')GOTO446 CCCCC JANUARY 1997. LNGAMMA ADDED AS SYNONYM IF(IH.EQ.'LNGA'.AND.IH2.EQ.'MMA ')GOTO446 IF(IH.EQ.'DIM '.AND.IH2.EQ.' ')GOTO447 IF(IH.EQ.'JULI'.AND.IH2.EQ.'A ')GOTO510 CCCCC THE FOLLOWING LINE WAS ADDED MARCH 1989 IF(IH.EQ.'BINP'.AND.IH2.EQ.'AT ')GOTO610 CCCCC THE FOLLOWING 2 LINES ADDED SEPTEMBER 1994 IF(IH.EQ.'BETA'.AND.IH2.EQ.' ')GOTO620 IF(IH.EQ.'BETA'.AND.IH2.EQ.'I ')GOTO630 IF(IH.EQ.'LNBE'.AND.IH2.EQ.'TA ')GOTO640 CCCCC JANUARY 1997. LOGBETA ADDED AS SYNONYM IF(IH.EQ.'LOGB'.AND.IH2.EQ.'ETA ')GOTO640 IF(IH.EQ.'GAMM'.AND.IH2.EQ.'AI ')GOTO650 IF(IH.EQ.'GAMM'.AND.IH2.EQ.'AIP ')GOTO652 IF(IH.EQ.'GAMM'.AND.IH2.EQ.'AIC ')GOTO655 IF(IH.EQ.'GAMM'.AND.IH2.EQ.'AR ')GOTO660 IF(IH.EQ.'DIGA'.AND.IH2.EQ.'MMA ')GOTO670 CCCCC SEPTEMBER 1997. ADD FOLLOWING LINE IF(IH.EQ.'PSI '.AND.IH2.EQ.' ')GOTO670 CCCCC OCTOBER 1997. ADD FOLLOWING LINE IF(IH.EQ.'PSIF'.AND.IH2.EQ.'N ')GOTO1670 IF(IH.EQ.'TRIC'.AND.IH2.EQ.'OMI ')GOTO680 IF(IH.EQ.'POCH'.AND.IH2.EQ.' ')GOTO690 IF(IH.EQ.'POCH'.AND.IH2.EQ.'1 ')GOTO700 IF(IH.EQ.'CHU '.AND.IH2.EQ.' ')GOTO710 CCCCC THE FOLLOWING SECTION ADDED MARCH 1995. IF(IH.EQ.'HEAV'.AND.IH2.EQ.'E ')GOTO810 IF(IH.EQ.'STEP'.AND.IH2.EQ.' ')GOTO820 IF(IH.EQ.'CEIL'.AND.IH2.EQ.' ')GOTO830 IF(IH.EQ.'FLOO'.AND.IH2.EQ.'R ')GOTO840 IF(IH.EQ.'GCD '.AND.IH2.EQ.' ')GOTO850 CCCCC THE FOLLOWING SECTION ADDED JANUARY 1997 IF(IH.EQ.'LAMB'.AND.IH2.EQ.'DA ')GOTO860 IF(IH.EQ.'LAMB'.AND.IH2.EQ.'DAP ')GOTO870 IF(IH.EQ.'H0 '.AND.IH2.EQ.' ')GOTO880 IF(IH.EQ.'H1 '.AND.IH2.EQ.' ')GOTO890 IF(IH.EQ.'HV '.AND.IH2.EQ.' ')GOTO900 IF(IH.EQ.'L0 '.AND.IH2.EQ.' ')GOTO910 IF(IH.EQ.'L1 '.AND.IH2.EQ.' ')GOTO920 IF(IH.EQ.'LV '.AND.IH2.EQ.' ')GOTO930 CCCCC THE FOLLOWING SECTION ADDED JULY 1997 IF(IH.EQ.'CHM '.AND.IH2.EQ.' ')GOTO940 CCCCC THE FOLLOWING SECTION ADDED AUGUST 1997 IF(IH.EQ.'CGAM'.AND.IH2.EQ.'MA ')GOTO950 IF(IH.EQ.'CLNG'.AND.IH2.EQ.'AM ')GOTO955 IF(IH.EQ.'CGAM'.AND.IH2.EQ.'MAI ')GOTO960 IF(IH.EQ.'CLNG'.AND.IH2.EQ.'AMI ')GOTO965 IF(IH.EQ.'CPSI'.AND.IH2.EQ.' ')GOTO970 IF(IH.EQ.'CPSI'.AND.IH2.EQ.'I ')GOTO980 IF(IH.EQ.'HYPE'.AND.IH2.EQ.'RGEO')GOTO990 IF(IH.EQ.'PBDV'.AND.IH2.EQ.' ')GOTO1000 IF(IH.EQ.'PBDV'.AND.IH2.EQ.'1 ')GOTO1010 IF(IH.EQ.'PBVV'.AND.IH2.EQ.' ')GOTO1020 IF(IH.EQ.'PBVV'.AND.IH2.EQ.'1 ')GOTO1030 IF(IH.EQ.'PBWA'.AND.IH2.EQ.' ')GOTO1040 IF(IH.EQ.'PBWA'.AND.IH2.EQ.'1 ')GOTO1050 IF(IH.EQ.'CLNB'.AND.IH2.EQ.'ETA ')GOTO1060 IF(IH.EQ.'CLNB'.AND.IH2.EQ.'ETAI')GOTO1070 IF(IH.EQ.'CBET'.AND.IH2.EQ.'A ')GOTO1080 IF(IH.EQ.'CBET'.AND.IH2.EQ.'AI ')GOTO1090 IF(IH.EQ.'ZETA'.AND.IH2.EQ.' ')GOTO1100 IF(IH.EQ.'BER '.AND.IH2.EQ.' ')GOTO1110 IF(IH.EQ.'BERI'.AND.IH2.EQ.' ')GOTO1120 IF(IH.EQ.'BER1'.AND.IH2.EQ.' ')GOTO1130 IF(IH.EQ.'BERI'.AND.IH2.EQ.'1 ')GOTO1140 IF(IH.EQ.'KER '.AND.IH2.EQ.' ')GOTO1150 IF(IH.EQ.'KERI'.AND.IH2.EQ.' ')GOTO1160 IF(IH.EQ.'KER1'.AND.IH2.EQ.' ')GOTO1170 IF(IH.EQ.'KERI'.AND.IH2.EQ.'1 ')GOTO1180 IF(IH.EQ.'ETA '.AND.IH2.EQ.' ')GOTO1190 IF(IH.EQ.'CATL'.AND.IH2.EQ.'AN ')GOTO1200 IF(IH.EQ.'FERM'.AND.IH2.EQ.'DIRA')GOTO1210 IF(IH.EQ.'HARM'.AND.IH2.EQ.'NUMB')GOTO1220 C IFOUND='NO' GOTO9000 C 401 CONTINUE IF(X.GE.0.0)GOTO1801 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1501) 1501 FORMAT('***** ERROR IN DPLIB1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1601) 1601 FORMAT(' ATTEMPT TO TAKE SQUARE ROOT OF NEGATIVE NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1701)X 1701 FORMAT(' THE NEGATIVE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1801 CONTINUE IF(X.EQ.0.0)TERM=X IF(X.GT.0.0)TERM=SQRT(X) GOTO9000 C 402 CONTINUE ARG=X IF(ARG.GT.80.0)TERM=CPUMAX IF(ARG.LT.-80.0)TERM=0.0 IF(-80.0.LE.ARG.AND.ARG.LE.80.0)TERM=EXP(ARG) GOTO9000 C 403 CONTINUE IF(X.GT.0.0)GOTO1803 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1503) 1503 FORMAT('***** ERROR IN DPLIB1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1603) 1603 FORMAT(' ATTEMPT TO TAKE LOG OF NON-POSITIVE NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1703)X 1703 FORMAT(' THE NON-POSITIVE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1803 CONTINUE TERM=ALOG(X) GOTO9000 C 404 CONTINUE IF(X.GT.0.0)GOTO1804 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1504) 1504 FORMAT('***** ERROR IN DPLIB1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1604) 1604 FORMAT(' ATTEMPT TO TAKE LOG OF NON-POSITIVE NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1704)X 1704 FORMAT(' THE NON-POSITIVE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1804 CONTINUE TERM=ALOG10(X) GOTO9000 C 405 CONTINUE IF(X.GT.0.0)GOTO1805 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1505) 1505 FORMAT('***** ERROR IN DPLIB1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1605) 1605 FORMAT(' ATTEMPT TO TAKE LOG OF NON-POSITIVE NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1705)X 1705 FORMAT(' THE NON-POSITIVE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1805 CONTINUE TERM=ALOG(X)/ALOG(2.0) GOTO9000 C 463 CONTINUE ARG=X RESULT=ATAN(ARG) IF(IANGLU.EQ.'DEGR')RESULT=(180.0/PI)*RESULT IF(IANGLU.EQ.'GRAD')RESULT=(200.0/PI)*RESULT TERM=RESULT GOTO9000 C 408 CONTINUE ARG1=X ARG2=SAVE1 RESULT=ATAN2(ARG1,ARG2) TERM=RESULT GOTO9000 C 410 CONTINUE TERM=ABS(X) GOTO9000 C 411 CONTINUE TERM=AINT(X) GOTO9000 C 412 CONTINUE TERM=AMOD(X,SAVE1) GOTO9000 C 413 CONTINUE TERM=1.0 IF(X.LT.0.0)TERM=-1.0 GOTO9000 C 414 CONTINUE TERM=X-AINT(X) TERM=ABS(TERM) GOTO9000 C 415 CONTINUE TERM=ABS(X) DO1515I=1,1000 IF(TERM.GT.10.0)TERM=TERM/10.0 IF(TERM.LT.1.0)TERM=TERM*10.0 IF(1.0.LE.TERM.AND.TERM.LE.10.0)GOTO1615 1515 CONTINUE 1615 CONTINUE TERM=AINT(TERM) GOTO9000 C 417 CONTINUE CCCCC THE FOLLOWING ERROR CHECK SECTION WAS ADDED FEBRUARY 1993 IF(-10.0.LE.SAVE1.AND.SAVE1.LE.10.0)GOTO2109 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2101) 2101 FORMAT('***** ERROR IN DPLIB1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2102) 2102 FORMAT(' INVALID (OR NON-EXISTENT) SECOND ARGUMENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2103) 2103 FORMAT(' FOR THE ROUND(..,..) FUNCTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2104) 2104 FORMAT(' EXAMPLE OF PROPER FORM--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2105) 2105 FORMAT(' LET Y2=ROUND(Y,3) TO ROUND TO 3 DEC. PLACES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2106) 2106 FORMAT(' LET Y2=ROUND(Y,0) TO ROUND TO 0 DEC. PLACES') CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2109 CONTINUE CCCCC IF(X.GE.0.0)TERM=AINT(X+0.5) CCCCC IF(X.LT.0.0)TERM=AINT(X-0.5) ABSX=ABS(X) IPOWER=0 IF(SAVE1.GT.0.0)IPOWER=AINT(SAVE1+0.5) AMULT=10.0**IPOWER TEMP2=ABSX*AMULT TEMP3=AINT(TEMP2+0.5) TEMP4=TEMP3/AMULT TERM=TEMP4 IF(X.LT.0.0)TERM=(-TEMP4) GOTO9000 C 418 CONTINUE TERM=0.0 IF(ABS(SAVE1).EQ.0.0)EPS=0.000001 IF(ABS(SAVE1).NE.0.0)EPS=ABS(SAVE1*0.000001) ALOWER=SAVE1-EPS AUPPER=SAVE1+EPS IF(ALOWER.LE.X.AND.X.LE.AUPPER)TERM=1.0 GOTO9000 C 421 CONTINUE IBASE1=8 IBASE2=10 GOTO424 422 CONTINUE IBASE1=10 IBASE2=8 GOTO424 424 CONTINUE ARG=X IX=ARG+0.5 ISIGN='+' IF(IX.LT.0)ISIGN='-' ISUM=0 DO425IBIT=1,NUMBPW INEWX=IX/IBASE2 IDIG=IX-IBASE2*INEWX ISUM=ISUM+IDIG*IBASE1**(IBIT-1) IF(INEWX.LE.0)GOTO426 IX=INEWX 425 CONTINUE 426 CONTINUE IF(ISIGN.EQ.'-')ISUM=-ISUM TERM=ISUM GOTO9000 C 441 CONTINUE ARG1=X*SQRT(2.0) CALL NORCDF(ARG1,RESULT) TERM=2.0*RESULT-1.0 GOTO9000 C 442 CONTINUE ARG1=X*SQRT(2.0) CALL NORCDF(ARG1,RESULT) TERM=2.0*RESULT-1.0 TERM=1.0-TERM GOTO9000 C 443 CONTINUE TERM=X IF(SAVE1.LT.X)TERM=SAVE1 GOTO9000 C 444 CONTINUE TERM=X IF(SAVE1.GT.X)TERM=SAVE1 GOTO9000 C 445 CONTINUE ARG=X CALL GAMMAF(ARG,TERM) GOTO9000 C 446 CONTINUE ARG=X CALL LOGGAM(ARG,TERM) GOTO9000 C 447 CONTINUE TERM=0.0 IF(SAVE1.LT.X)TERM=X-SAVE1 GOTO9000 C CCCCC THE FOLLOWING SECTION (JULIA) WAS ADDED MARCH 1989 510 CONTINUE XCALC=X YCALC=SAVE1 X0=SAVE2 Y0=SAVE3 IMAX=100 ICOUNT=0 CUT=10.0**6 DO511I=1,IMAX ICOUNT=ICOUNT+1 CCCCC THE FOLLOWING LINE WAS ADDED JULY 1993 (ALAN) XTEMP=XCALC XCALC=XCALC**2-YCALC**2+X0 CCCCC THE FOLLOWING LINE WAS FIXED JULY 1993 (ALAN) CCCCC YCALC=2.0*XCALC*YCALC+Y0 YCALC=2.0*XTEMP*YCALC+Y0 IF(ABS(XCALC).GT.CUT)GOTO515 IF(ABS(YCALC).GT.CUT)GOTO515 511 CONTINUE 515 CONTINUE TERM=ICOUNT GOTO9000 C CCCCC THE FOLLOWING SECTION (BINPAT(X,K)) WAS ADDED JANUARY 1990 CCCCC BINPAT WILL OUTPUT A -1 OR +1 610 CONTINUE IX=X+0.1 ISAVE=SAVE1+0.1 IMOD=2**ISAVE IMOD2=IMOD/2 IX2=MOD(IX,IMOD) IF(IX2.EQ.0)IX2=IMOD IX3=1 IF(IX2.LE.IMOD2)IX3=(-1) TERM=IX3 GOTO9000 C CCCCC THE FOLLOWING SECTION (BETA(A,B)) WAS ADDED SEPTEMBER 1994 620 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DRESLT=DBETA(DARG1,DARG2) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (BETAI(A,B)) WAS ADDED SEPTEMBER 1994 630 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DRESLT=DBETAI(DARG1,DARG2,DARG3) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (LNBETA(A,B)) WAS ADDED SEPTEMBER 1994 640 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DRESLT=DLBETA(DARG1,DARG2) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (GAMMAI(X,P)) WAS ADDED SEPTEMBER 1994 650 CONTINUE DARG2=DBLE(X) DARG1=DBLE(SAVE1) DRESLT=DGAMI(DARG1,DARG2) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (GAMMAIP(X,P)) WAS ADDED SEPTEMBER 1994 652 CONTINUE DARG2=DBLE(X) DARG1=DBLE(SAVE1) DRESLT=DGAMIP(DARG1,DARG2) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (GAMMAIC(X,P)) WAS ADDED SEPTEMBER 1994 655 CONTINUE DARG2=DBLE(X) DARG1=DBLE(SAVE1) DRESLT=DGAMIC(DARG1,DARG2) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (GAMMAR(X)) WAS ADDED SEPTEMBER 1994 660 CONTINUE DARG1=DBLE(X) DRESLT=DGAMR(DARG1) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (DIGAMMA(X)) WAS ADDED SEPTEMBER 1994 670 CONTINUE DARG1=DBLE(X) DRESLT=DPSI(DARG1) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (PSIFN(X,N)) WAS ADDED OCTOBER 1997 1670 CONTINUE DARG1=DBLE(X) IF(DARG1.LE.0.0D0)THEN WRITE(ICOUT,1676) CALL DPWRST('XXX','BUG') GOTO9000 ENDIF 1676 FORMAT('***** ERROR FROM PSIFN--FIRST ARGUMENT NOT POSITIVE') IARG1=INT(SAVE1+0.5) IF(IARG1.LT.0.0.OR.IARG1.GT.100)THEN WRITE(ICOUT,1677) CALL DPWRST('XXX','BUG') GOTO9000 ENDIF 1677 FORMAT('***** ERROR FROM PSIFN--SECOND ARGUMENT NOT ', 1'IN THE RANGE (0,100)') IARG2=1 IARG3=1 IARG4=0 IERR=0 CALL DPSIFN(DARG1,IARG1,IARG2,IARG3,DRESLT,IARG4,IERR) IF(IERR.LE.0)THEN TERM=SNGL(DRESLT) ELSEIF(IERR.EQ.1)THEN WRITE(ICOUT,1671) CALL DPWRST('XXX','BUG') ELSEIF(IERR.EQ.2)THEN WRITE(ICOUT,1672) CALL DPWRST('XXX','BUG') ELSEIF(IERR.EQ.3)THEN WRITE(ICOUT,1673) CALL DPWRST('XXX','BUG') ELSE TERM=SNGL(DRESLT) ENDIF 1671 FORMAT('**** ERROR FROM PSIFN--INPUT ERROR') 1672 FORMAT('**** ERROR FROM PSIFN--OVERFLOW, EITHER X IS TOO ', 1'SMALL OR ORDER IS TOO LARGE') 1673 FORMAT('**** ERROR FROM PSIFN--ORDER IS TOO LARGE') GOTO9000 C CCCCC THE FOLLOWING SECTION (TRICOMI(X,A)) WAS ADDED SEPTEMBER 1994 680 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DRESLT=DGAMIT(DARG2,DARG1) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (POCH(X,A)) WAS ADDED SEPTEMBER 1994 690 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DRESLT=DPOCH(DARG2,DARG1) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (POCH1(X,A)) WAS ADDED SEPTEMBER 1994 700 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DRESLT=DPOCH1(DARG2,DARG1) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (CHU(X)) WAS ADDED SEPTEMBER 1994 710 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DRESLT=DCHU(DARG2,DARG3,DARG1) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (HEAVE(X,A,B)) WAS ADDED MARCH 1995 CCCCC HEAVSIDE FUNCTION IS 1 IF X>= 0, 0 IF X < 0. TEST FOR A SHIFT CCCCC PARAMETER, THE FUNCTION IS 1 IF A <= X <= B, 0 OTHERWISE 810 CONTINUE IF(SAVE1.NE.-99.9)THEN ARG2=SAVE1 ELSE ARG2=0.0 ENDIF IF(SAVE2.NE.-99.9)THEN ARG3=SAVE2 ELSE ARG3=CPUMAX ENDIF TERM=0.0 IF(ARG2.LE.ARG3)THEN IF(X.GE.ARG2.AND.X.LE.ARG3)TERM=1.0 ELSE IF(X.GE.ARG3.AND.X.LE.ARG2)TERM=1.0 ENDIF GOTO9000 C CCCCC THE FOLLOWING SECTION (STEP(X)) WAS ADDED MARCH 1995 820 CONTINUE ARG1=X IF(ARG1.GE.0.0)THEN IARG2=INT(ARG1) TERM=REAL(IARG2) ELSE IARG2=INT(ARG1) ARG3=REAL(IARG2) ARG4=ARG1-ARG3 TERM=ARG3 IF(ARG4.NE.0.0)TERM=TERM-1.0 ENDIF GOTO9000 C CCCCC THE FOLLOWING SECTION (CEIL(X)) WAS ADDED MARCH 1995 CCCCC CEILING FUNCTION ROUNDS TO INTEGER TOWARDS POSITIVE INFINITY 830 CONTINUE ARG1=X IF(ARG1.GE.0.0)THEN IARG2=INT(ARG1) ARG3=REAL(IARG2) ARG4=ARG1-ARG3 TERM=ARG3 IF(ARG4.NE.0.0)TERM=TERM+1.0 ELSE IARG2=INT(ARG1) TERM=REAL(IARG2) ENDIF GOTO9000 C CCCCC THE FOLLOWING SECTION (FLOOR(X)) WAS ADDED MARCH 1995 CCCCC FLOOR FUNCTION ROUNDS TO INTEGER TOWARDS NEGATIVE INFINITY 840 CONTINUE ARG1=X IF(ARG1.LE.0.0)THEN IARG2=INT(ARG1) ARG3=REAL(IARG2) ARG4=ARG1-ARG3 TERM=ARG3 IF(ARG4.NE.0.0)TERM=TERM-1.0 ELSE IARG2=INT(ARG1) TERM=REAL(IARG2) ENDIF GOTO9000 C CCCCC THE FOLLOWING SECTION (GCD(IX1,IX2)) WAS ADDED MARCH 1995 CCCCC FINDS GREATEST COMMON DIVISOR OF 2 NUMBERS. 850 CONTINUE IARG1=INT(X+0.5) ITERM1=IABS(IARG1) IARG2=INT(SAVE1+0.5) ITERM2=IABS(IARG2) IF(ITERM1.EQ.0)THEN TERM=REAL(ITERM2) ELSE 851 CONTINUE IARG3=MOD(ITERM2,ITERM1) IF(IARG3.EQ.0)THEN TERM=REAL(ITERM1) GOTO9000 ENDIF ITERM2=ITERM1 ITERM1=IARG3 GOTO851 ENDIF GOTO9000 C CCCCC THE FOLLOWING SECTION (LAMBDA(X,A)) WAS ADDED MARCH 1997 CCCCC CALL DIFFERENT ROUTINE BASED ON INTEGER OR REAL ORDER. 860 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ITEMP=INT(DARG2) DARG3=DABS(DARG2-DBLE(ITEMP)) IERROR='NO' IF(DARG3.LT.0.0D-20)THEN CALL LAMN(INT(DARG2),DARG1,NJUNK,DRESLT,DARG3,IERROR) ELSE CALL LAMV(DARG2,DARG1,DARG4,DRESLT,DARG3,IERROR) ENDIF IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,861) 861 FORMAT('***** ERROR. ORDER OF LAMBDA FUNCTION MUST BE ', 1 'LESS THAN 500.') CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ELSE TERM=SNGL(DRESLT) ENDIF GOTO9000 C CCCCC THE FOLLOWING SECTION (LAMBDAP(X,A)) WAS ADDED MARCH 1997 CCCCC CALL DIFFERENT ROUTINE BASED ON INTEGER OR REAL ORDER. 870 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ITEMP=INT(DARG2) DARG3=DABS(DARG2-DBLE(ITEMP)) IERROR='NO' IF(DARG3.LT.0.0D-20)THEN CALL LAMN(INT(DARG2),DARG1,NJUNK,DARG3,DRESLT,IERROR) ELSE CALL LAMV(DARG2,DARG1,DARG4,DARG3,DRESLT,IERROR) ENDIF IF(IERROR.EQ.'YES')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,871) 871 FORMAT('***** ERROR. ORDER OF LAMBDA FUNCTION MUST BE ', 1 'LESS THAN 500.') CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ELSE TERM=SNGL(DRESLT) ENDIF GOTO9000 C CCCCC THE FOLLOWING SECTION (H0(X)) WAS ADDED MARCH 1997 880 CONTINUE IF(X.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,881) 881 FORMAT('***** ERROR. FIRST ARGUMENT TO H0 MUST BE ', 1 'NON-NEGATIVE.') CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF DARG1=DBLE(X) CALL STVH0(DARG1,DRESLT) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (H1(X)) WAS ADDED MARCH 1997 890 CONTINUE IF(X.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,891) 891 FORMAT('***** ERROR. FIRST ARGUMENT TO H1 MUST BE ', 1 'NON-NEGATIVE.') CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF DARG1=DBLE(X) CALL STVH1(DARG1,DRESLT) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (HV(X,V)) WAS ADDED MARCH 1997 900 CONTINUE DARG1=DBLE(X) IF(X.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,901) 901 FORMAT('***** ERROR. FIRST ARGUMENT TO HV MUST BE ', 1 'NON-NEGATIVE.') CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF IF(SAVE1.LT.-8.5 .OR. SAVE1.GT.12.5)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,906) 906 FORMAT('***** ERROR. SECOND ARGUMENT TO HV MUST BE IN THE ', 1 'RANGE (-8.5, 12.5).') CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF DARG2=DBLE(SAVE1) CALL STVHV(DARG2,DARG1,DRESLT) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (L0(X)) WAS ADDED MARCH 1997 910 CONTINUE IF(X.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,911) 911 FORMAT('***** ERROR. FIRST ARGUMENT TO L0 MUST BE ', 1 'NON-NEGATIVE.') CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF DARG1=DBLE(X) CALL STVL0(DARG1,DRESLT) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (L1(X)) WAS ADDED MARCH 1997 920 CONTINUE IF(X.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,921) 921 FORMAT('***** ERROR. FIRST ARGUMENT TO L1 MUST BE ', 1 'NON-NEGATIVE.') CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF DARG1=DBLE(X) CALL STVL1(DARG1,DRESLT) TERM=SNGL(DRESLT) GOTO9000 CCCCC THE FOLLOWING SECTION (LV(X,V)) WAS ADDED MARCH 1997 930 CONTINUE DARG1=DBLE(X) IF(X.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,931) 931 FORMAT('***** ERROR. FIRST ARGUMENT TO HV MUST BE ', 1 'NON-NEGATIVE.') CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF IF(SAVE1.LT.-20.0 .OR. SAVE1.GT.20.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,936) 936 FORMAT('***** ERROR. SECOND ARGUMENT TO HV MUST BE IN THE ', 1 'RANGE (-20.0, 20.0).') CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF DARG2=DBLE(SAVE1) CALL STVLV(DARG2,DARG1,DRESLT) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (CHM(X)) WAS ADDED JULY 1997 940 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL CHM(DARG2,DARG3,DARG1,DRESLT,IERR2) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (CGAMMA(XR,XC)) WAS ADDED AUGUST 1997 950 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ICODE=1 CALL CGAMA(DARG1,DARG2,ICODE,DRESLT,DRSLT2) TERM=REAL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (CLNGAM(XR,XC)) WAS ADDED AUGUST 1997 955 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ICODE=0 CALL CGAMA(DARG1,DARG2,ICODE,DRESLT,DRSLT2) TERM=REAL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (CGAMMAI(XR,XC)) WAS ADDED AUGUST 1997 960 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ICODE=1 CALL CGAMA(DARG1,DARG2,ICODE,DRESLT,DRSLT2) TERM=REAL(DRSLT2) GOTO9000 C CCCCC THE FOLLOWING SECTION (CLNGAMI(XR,XC)) WAS ADDED AUGUST 1997 965 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ICODE=0 CALL CGAMA(DARG1,DARG2,ICODE,DRESLT,DRSLT2) TERM=REAL(DRSLT2) GOTO9000 C CCCCC THE FOLLOWING SECTION (CPSI(XR,XC)) WAS ADDED AUGUST 1997 970 CONTINUE ARG1=DBLE(X) ARG2=DBLE(SAVE1) ZARG=CMPLX(ARG1,ARG2) ZRESLT=CPSI(ZARG) TERM=REAL(ZRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (CPSII(XR,XC)) WAS ADDED AUGUST 1997 980 CONTINUE ARG1=DBLE(X) ARG2=DBLE(SAVE1) ZARG=CMPLX(ARG1,ARG2) ZRESLT=CPSI(ZARG) TERM=AIMAG(ZRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (HYPERGEO(X,A,B,C)) WAS ADDED AUGUST 1997 990 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) IF(DABS(DARG1).GE.1.0D0)THEN WRITE(ICOUT,992) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF 992 FORMAT('***** ERROR: HYPERGEO FUNCTION IS CURRENTLY ONLY ', 1'SUPPORTED FOR ARGUMENTS WITH ABSOLUTE VALUE LESS THAN 1') CALL HYGFX(DARG2,DARG3,DARG4,DARG1,DRESLT,IERR2) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (PBDV(X,A)) WAS ADDED AUGUST 1997 1000 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) CALL PBDV(DARG2,DARG1,DTEMP1,DTEMP2,DRESLT,DRSLT2) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (PBDV1(X,A)) WAS ADDED AUGUST 1997 1010 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) CALL PBDV(DARG2,DARG1,DTEMP1,DTEMP2,DRESLT,DRSLT2) TERM=SNGL(DRSLT2) GOTO9000 C CCCCC THE FOLLOWING SECTION (PBVV(X,A)) WAS ADDED AUGUST 1997 1020 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) CALL PBVV(DARG2,DARG1,DTEMP1,DTEMP2,DRESLT,DRSLT2) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (PBVV1(X,A)) WAS ADDED AUGUST 1997 1030 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) CALL PBVV(DARG2,DARG1,DTEMP1,DTEMP2,DRESLT,DRSLT2) TERM=SNGL(DRSLT2) GOTO9000 C CCCCC THE FOLLOWING SECTION (PBWA(X,A)) WAS ADDED AUGUST 1997 CCCCC PUT CHECK FOR ABSOLUTE VALUE OF ARGUMENTS <= 5. SPETEMBER 1997. 1040 CONTINUE DARG1=DBLE(ABS(X)) DARG2=DBLE(SAVE1) IF(DABS(DARG1).GT.5.0D0)THEN WRITE(ICOUT,1042) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF 1042 FORMAT('***** ERROR: ABSOLUTE VALUE OF FIRST ARGUMENT TO ', 1'PBWA MUST BE LESS THAN OR EQUAL TO 5.') IF(DABS(DARG2).GT.5.0D0)THEN WRITE(ICOUT,1044) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF 1044 FORMAT('***** ERROR: ABSOLUTE VALUE OF SECOND ARGUMENT TO ', 1'PBWA MUST BE LESS THAN OR EQUAL TO 5.') CALL PBWA(DARG2,DARG1,DRESLT,DRSLT2,DRSLT3,DRSLT4) IF(X.GE.0.0)THEN TERM=SNGL(DRESLT) ELSE TERM=SNGL(DRSLT3) ENDIF GOTO9000 C CCCCC THE FOLLOWING SECTION (PBWA1(X,A)) WAS ADDED AUGUST 1997 1050 CONTINUE DARG1=DBLE(ABS(X)) DARG2=DBLE(SAVE1) CALL PBWA(DARG2,DARG1,DRESLT,DRSLT2,DRSLT3,DRSLT4) IF(X.GE.0.0)THEN TERM=SNGL(DRSLT2) ELSE TERM=SNGL(DRSLT4) ENDIF GOTO9000 C CCCCC THE FOLLOWING SECTION (CLNBETA(XR,XC)) WAS ADDED AUGUST 1997 1060 CONTINUE TERM=0.0 DARG1=DBLE(X) IF(DARG1.LE.0.D0)THEN WRITE(ICOUT,1061) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 1061 FORMAT('****** ERROR FROM CLNBETA: FIRST ARGUMENT MUST BE ', 1'POSITIVE.') DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) IF(DARG3.LE.0.D0)THEN WRITE(ICOUT,1062) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 1062 FORMAT('****** ERROR FROM CLNBETA: THIRD ARGUMENT MUST BE ', 1'POSITIVE.') DARG4=DBLE(SAVE2) ICODE=0 CALL CGAMA(DARG1,DARG2,ICODE,DRESLT,DRSLT2) CALL CGAMA(DARG3,DARG4,ICODE,DRSLT3,DRSLT4) CALL CGAMA(DARG1+DARG3,DARG2+DARG4,ICODE,DRSLT5,DRSLT6) TERM=REAL(DRESLT + DRSLT3 - DRSLT5) GOTO9000 C CCCCC THE FOLLOWING SECTION (CLNBETAI(XR,XC)) WAS ADDED AUGUST 1997 1070 CONTINUE TERM=0.0 DARG1=DBLE(X) IF(DARG1.LE.0.D0)THEN WRITE(ICOUT,1071) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 1071 FORMAT('****** ERROR FROM CLNBETAI: FIRST ARGUMENT MUST BE ', 1'POSITIVE.') DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) IF(DARG3.LE.0.D0)THEN WRITE(ICOUT,1072) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 1072 FORMAT('****** ERROR FROM CLNBETAI: THIRD ARGUMENT MUST BE ', 1'POSITIVE.') DARG4=DBLE(SAVE2) ICODE=0 CALL CGAMA(DARG1,DARG2,ICODE,DRESLT,DRSLT2) CALL CGAMA(DARG3,DARG4,ICODE,DRSLT3,DRSLT4) CALL CGAMA(DARG1+DARG3,DARG2+DARG4,ICODE,DRSLT5,DRSLT6) TERM=REAL(DRSLT2 + DRSLT4 - DRSLT6) GOTO9000 C CCCCC THE FOLLOWING SECTION (CBETA(XR,XC)) WAS ADDED SEPTEMBER 1997 1080 CONTINUE TERM=0.0 DARG1=DBLE(X) IF(DARG1.LE.0.D0)THEN WRITE(ICOUT,1081) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 1081 FORMAT('****** ERROR FROM CBETA: FIRST ARGUMENT MUST BE ', 1'POSITIVE.') DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) IF(DARG3.LE.0.D0)THEN WRITE(ICOUT,1082) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 1082 FORMAT('****** ERROR FROM CBETA: THIRD ARGUMENT MUST BE ', 1'POSITIVE.') DARG4=DBLE(SAVE2) ICODE=0 CALL CGAMA(DARG1,DARG2,ICODE,DRESLT,DRSLT2) CALL CGAMA(DARG3,DARG4,ICODE,DRSLT3,DRSLT4) CALL CGAMA(DARG1+DARG3,DARG2+DARG4,ICODE,DRSLT5,DRSLT6) TERM=SNGL(DEXP(DRESLT + DRSLT3 - DRSLT5)) GOTO9000 C CCCCC THE FOLLOWING SECTION (CBETAI(XR,XC)) WAS ADDED SEPTEMBER 1997 1090 CONTINUE TERM=0.0 DARG1=DBLE(X) IF(DARG1.LE.0.D0)THEN WRITE(ICOUT,1091) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 1091 FORMAT('****** ERROR FROM CBETAI: FIRST ARGUMENT MUST BE ', 1'POSITIVE.') DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) IF(DARG3.LE.0.D0)THEN WRITE(ICOUT,1092) CALL DPWRST('XXX','BUG ') GOTO9000 ENDIF 1092 FORMAT('****** ERROR FROM CBETAI: THIRD ARGUMENT MUST BE ', 1'POSITIVE.') DARG4=DBLE(SAVE2) ICODE=0 CALL CGAMA(DARG1,DARG2,ICODE,DRESLT,DRSLT2) CALL CGAMA(DARG3,DARG4,ICODE,DRSLT3,DRSLT4) CALL CGAMA(DARG1+DARG3,DARG2+DARG4,ICODE,DRSLT5,DRSLT6) TERM=SNGL(DEXP(DRSLT2 + DRSLT4 - DRSLT6)) GOTO9000 C CCCCC THE FOLLOWING SECTION (ZETA(X)) WAS ADDED SEPTEMBER 1997 1100 CONTINUE DARG1=DBLE(X) IF(DARG1.LE.1.0D0)THEN WRITE(ICOUT,1101) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 1101 FORMAT('***** ERROR: ARGUMENT FOR ZETA FUNCTION MUST ', 1'BE > 1') ENDIF CALL ZETA(DARG1,DRESLT) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (BER(X)) WAS ADDED SEPTEMBER 1997 1110 CONTINUE DARG1=DBLE(X) IF(DARG1.LT.0.D0)THEN WRITE(ICOUT,1112) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF 1112 FORMAT('***** ERROR FROM BER: ARGUMENT MUST BE GREATER ', 1'THAN OR EQUAL TO ZERO.') CALL KLVNA(DARG1,DRESLT,DRSLT2,DRSLT3,DRSLT4,DRSLT5, 1DRSLT6,DRSLT7,DRSLT8) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (BERI(X)) WAS ADDED SEPTEMBER 1997 1120 CONTINUE DARG1=DBLE(X) IF(DARG1.LT.0.D0)THEN WRITE(ICOUT,1122) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF 1122 FORMAT('***** ERROR FROM BERI: ARGUMENT MUST BE GREATER ', 1'THAN OR EQUAL TO ZERO.') CALL KLVNA(DARG1,DRESLT,DRSLT2,DRSLT3,DRSLT4,DRSLT5, 1DRSLT6,DRSLT7,DRSLT8) TERM=SNGL(DRSLT2) GOTO9000 C CCCCC THE FOLLOWING SECTION (BER1(X)) WAS ADDED SEPTEMBER 1997 1130 CONTINUE DARG1=DBLE(X) IF(DARG1.LT.0.D0)THEN WRITE(ICOUT,1132) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF 1132 FORMAT('***** ERROR FROM BER1: ARGUMENT MUST BE GREATER ', 1'THAN OR EQUAL TO ZERO.') CALL KLVNA(DARG1,DRESLT,DRSLT2,DRSLT3,DRSLT4,DRSLT5, 1DRSLT6,DRSLT7,DRSLT8) TERM=SNGL(DRSLT5) GOTO9000 C CCCCC THE FOLLOWING SECTION (BERI1(X)) WAS ADDED SEPTEMBER 1997 1140 CONTINUE DARG1=DBLE(X) IF(DARG1.LT.0.D0)THEN WRITE(ICOUT,1142) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF 1142 FORMAT('***** ERROR FROM BERI1: ARGUMENT MUST BE GREATER ', 1'THAN OR EQUAL TO ZERO.') CALL KLVNA(DARG1,DRESLT,DRSLT2,DRSLT3,DRSLT4,DRSLT5, 1DRSLT6,DRSLT7,DRSLT8) TERM=SNGL(DRSLT6) GOTO9000 C CCCCC THE FOLLOWING SECTION (KER(X)) WAS ADDED SEPTEMBER 1997 1150 CONTINUE DARG1=DBLE(X) IF(DARG1.LE.0.D0)THEN WRITE(ICOUT,1152) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF 1152 FORMAT('***** ERROR FROM KER: ARGUMENT MUST BE POSITIVE ') CALL KLVNA(DARG1,DRESLT,DRSLT2,DRSLT3,DRSLT4,DRSLT5, 1DRSLT6,DRSLT7,DRSLT8) TERM=SNGL(DRSLT3) GOTO9000 C CCCCC THE FOLLOWING SECTION (KERI(X)) WAS ADDED SEPTEMBER 1997 1160 CONTINUE DARG1=DBLE(X) IF(DARG1.LT.0.D0)THEN WRITE(ICOUT,1162) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF 1162 FORMAT('***** ERROR FROM KERI: ARGUMENT MUST BE GREATER ', 1'THAN OR EQUAL TO ZERO.') CALL KLVNA(DARG1,DRESLT,DRSLT2,DRSLT3,DRSLT4,DRSLT5, 1DRSLT6,DRSLT7,DRSLT8) TERM=SNGL(DRSLT4) GOTO9000 C CCCCC THE FOLLOWING SECTION (KER1(X)) WAS ADDED SEPTEMBER 1997 1170 CONTINUE DARG1=DBLE(X) IF(DARG1.LE.0.D0)THEN WRITE(ICOUT,1172) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF 1172 FORMAT('***** ERROR FROM KER1: ARGUMENT MUST BE POSITIVE ') CALL KLVNA(DARG1,DRESLT,DRSLT2,DRSLT3,DRSLT4,DRSLT5, 1DRSLT6,DRSLT7,DRSLT8) TERM=SNGL(DRSLT7) GOTO9000 C CCCCC THE FOLLOWING SECTION (KERI1(X)) WAS ADDED SEPTEMBER 1997 1180 CONTINUE DARG1=DBLE(X) IF(DARG1.LT.0.D0)THEN WRITE(ICOUT,1182) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF 1182 FORMAT('***** ERROR FROM KERI1: ARGUMENT MUST BE GREATER ', 1'THAN OR EQUAL TO ZERO.') CALL KLVNA(DARG1,DRESLT,DRSLT2,DRSLT3,DRSLT4,DRSLT5, 1DRSLT6,DRSLT7,DRSLT8) TERM=SNGL(DRSLT8) GOTO9000 C CCCCC THE FOLLOWING SECTION (ETA(X)) WAS ADDED SEPTEMBER 1997 1190 CONTINUE DARG1=DBLE(X) IF(DARG1.LT.1.0D0)THEN WRITE(ICOUT,1191) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 1191 FORMAT('***** ERROR: ARGUMENT FOR ETA FUNCTION MUST ', 1'BE > 1') ELSEIF(DARG1.EQ.1.0D0)THEN TERM=-0.30685281944 GOTO9000 ENDIF CALL ZETA(DARG1,DRESLT) DARG2=2.0D0**(1.0D0-DARG1) DRSLT2=(1.0D0-DARG2)*DRESLT - DARG2 TERM=SNGL(DRSLT2) GOTO9000 C CCCCC THE FOLLOWING SECTION (CATLAN(X)) WAS ADDED SEPTEMBER 1997 1200 CONTINUE DARG1=DBLE(X) IF(DARG1.LT.1.0D0)THEN WRITE(ICOUT,1201) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 1201 FORMAT('***** ERROR: ARGUMENT FOR CATLAN FUNCTION MUST ', 1'BE >= 1') ENDIF CALL CATLAN(DARG1,DRESLT) TERM=SNGL(DRESLT) GOTO9000 C CCCCC THE FOLLOWING SECTION (FERMDIRA(X,ORD)) WAS ADDED MAY 2002 1210 CONTINUE DARG1=DBLE(X) ARG2=SAVE1 IF(ABS(ARG2 - (-0.5)).LE.0.01)THEN DRESLT=FDM0P5(DARG1) ELSEIF(ABS(ARG2 - 0.5).LE.0.01)THEN DRESLT=FDP0P5(DARG1) ELSEIF(ABS(ARG2 - 1.5).LE.0.01)THEN DRESLT=FDP1P5(DARG1) ELSEIF(ABS(ARG2 - 2.5).LE.0.01)THEN DRESLT=FDP2P5(DARG1) ELSE WRITE(ICOUT,1211) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1213)ARG2 CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 1211 FORMAT('***** ERROR: ORDER FOR FERMDIRA FUNCTION MUST BE ', 1 '-0.5, 0.5, 1.5, OR 2.5.') 1213 FORMAT(' REQUESTED ORDER IS ',E15.7) ENDIF IF(DRESLT.GE.DBLE(CPUMAX))THEN WRITE(ICOUT,1216) CALL DPWRST('XXX','BUG') WRITE(ICOUT,1218)REAL(DARG1) CALL DPWRST('XXX','BUG') TERM=CPUMAX GOTO9000 1216 FORMAT('***** ERROR: RESULT FOR FERMDIRA FUNCTION OVERFLOWS ', 1 'MAXIMUM ALLOWED.') 1218 FORMAT(' X = ',E15.7) ELSE TERM=REAL(DRESLT) ENDIF C CCCCC THE FOLLOWING SECTION (HARMNUMB(N,M)) WAS ADDED MAY 2006. 1220 CONTINUE IARG1=INT(X + 0.5) DARG2=DBLE(SAVE1) IF(DARG2.LT.0.0D0)THEN CALL HN(IARG1,DRESLT) ELSE CALL HNM(IARG1,DARG2,DRESLT) ENDIF TERM=REAL(DRESLT) GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGEV.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF DPLIB1--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IH,IH2,X 9012 FORMAT('IH,IH2,X = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)SAVE1,SAVE2,SAVE3,I,IANGLU 9013 FORMAT('SAVE1,SAVE2,SAVE3,I,IANGLU = ',3E15.7,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)RESULT,TERM,IBUGEV 9014 FORMAT('RESULT,TERM,IBUGEV = ',2E15.7,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUND,IERROR 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPLIB2(IH,IH2,X,SAVE1,SAVE2,I,IANGLU, 1TERM,IBUGEV,IFOUND,IERROR) C C PURPOSE--PERFORM A LIBRARY FUNCTION EVALUATION. C NOTE--THIS IS PART 2 C (EVALUATE TRIGONOMETRIC FUNCTIONS) C C NOTE--DOMAIN OF TRIG ARGUMENT (JULY 1988) C C SIN(X) -INF < X < INF C COS(X) -INF < X < INF C TAN(X) NOT +-PI/2 +-3PI/2 +-5PI/2 ... (WHENEVER COS IS 0) C COT(X) NOT 0 +-PI +-2PI +-3PI ... (WHENEVER SIN IS 0) C SEC(X) NOT +-PI/2 +-3PI/2 +-5PI/2 ... (WHENEVER COS IS 0) C CSC(X) NOT 0 +-PI +-2PI +-3PI ... (WHENEVER SIN IS 0) C C ARCSIN(X) -1 <= X <= 1 YIELDING -PI/2 <= Y <= PI/2 (PRIN. BR.) C ARCCOS(X) -1 <= X <= 1 YIELDING 0 <= Y <= PI (PRIN. BR.) C ARCTAN(X) -INF < X < INF YIELDING -PI/2 < Y < PI/2 (PRIN BR.) C ARCCOT(X) -INF < X < INF YIELDING 0 < X < PI/2 (PRIN. BR.) C ARCSEC(X) X>= 1 X <= -1 YIELDING 0 <= Y < PI/2 -PI <= X < -PI/2 ( C COMPUTED YIELDS 0 <= Y < PI/2 PI/2 < Y <= C ARCCSC(X) X>= 1 X <= -1 YIELDING 0 < Y <= PI/2 -PI < Y <= -PI/2 C COMPUTED YIELDS 0 <= Y < PI/2 -PI/2 <= Y C C SINH(X) -INF < X < INF C COSH(X) 0 <= X < INF C TANH(X) 0 <= X < INF C COTH(X) 0 < X < INF C SECH(X) 0 <= X < INF C CSCH(X) X NOT= 0 ? C C ARCSINH(X) -INF < X < INF C ARCCOSH(X) X >= 1 C ARCTANH(X) -1 < X < 1 C ARCCOTH(X) X > 1 X < -1 C ARCSECH(X) 0 < X <= 1 C ARCCSCH(X) X NOT= 0 C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JANUARY 1979. C UPDATED --NOVEMBER 1979. C UPDATED --FEBRUARY 1981. C UPDATED --JUNE 1981. C UPDATED --JULY 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JULY 1988. (HEAVY RENUMBERING + 0-DIVIDE CHECKS C + PROPER DOMAIN CHECKS) C UPDATED --JANUARY 1989. ASYMPTOTIC TRAPS FOR HYP TRIG FUNC C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IANGLU CHARACTER*4 IBUGEV CHARACTER*4 IFOUND CHARACTER*4 IERROR C 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-----DATA STATEMENTS------------------------------------------------- C DATA PI/3.1415926536/ C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPLI' ISUBN2='B1 ' C RESULT=0.0 C IF(IBUGEV.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IH,IH2,X 52 FORMAT('IH,IH2,X = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)SAVE1,SAVE2,I,IANGLU 53 FORMAT('SAVE1,SAVE2,I,IANGLU = ',E15.7,E15.7,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)TERM,IBUGEV,NUMBPW 54 FORMAT('TERM,IBUGEV,NUMBPW = ',E15.7,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IFOUND,IERROR 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IFOUND='YES' C IF(IH.EQ.'SIN '.AND.IH2.EQ.' ')GOTO1100 IF(IH.EQ.'COS '.AND.IH2.EQ.' ')GOTO1200 IF(IH.EQ.'TAN '.AND.IH2.EQ.' ')GOTO1300 IF(IH.EQ.'COT '.AND.IH2.EQ.' ')GOTO1400 IF(IH.EQ.'SEC '.AND.IH2.EQ.' ')GOTO1500 IF(IH.EQ.'CSC '.AND.IH2.EQ.' ')GOTO1600 C IF(IH.EQ.'ARCS'.AND.IH2.EQ.'IN ')GOTO2100 IF(IH.EQ.'ARCC'.AND.IH2.EQ.'OS ')GOTO2200 IF(IH.EQ.'ARCT'.AND.IH2.EQ.'AN ')GOTO2300 IF(IH.EQ.'ARCC'.AND.IH2.EQ.'OT ')GOTO2400 IF(IH.EQ.'ARCS'.AND.IH2.EQ.'EC ')GOTO2500 IF(IH.EQ.'ARCC'.AND.IH2.EQ.'SC ')GOTO2600 C IF(IH.EQ.'SINH'.AND.IH2.EQ.' ')GOTO3100 IF(IH.EQ.'COSH'.AND.IH2.EQ.' ')GOTO3200 IF(IH.EQ.'TANH'.AND.IH2.EQ.' ')GOTO3300 IF(IH.EQ.'COTH'.AND.IH2.EQ.' ')GOTO3400 IF(IH.EQ.'SECH'.AND.IH2.EQ.' ')GOTO3500 IF(IH.EQ.'CSCH'.AND.IH2.EQ.' ')GOTO3600 C IF(IH.EQ.'ARCS'.AND.IH2.EQ.'INH ')GOTO4100 IF(IH.EQ.'ARCC'.AND.IH2.EQ.'OSH ')GOTO4200 IF(IH.EQ.'ARCT'.AND.IH2.EQ.'ANH ')GOTO4300 IF(IH.EQ.'ARCC'.AND.IH2.EQ.'OTH ')GOTO4400 IF(IH.EQ.'ARCS'.AND.IH2.EQ.'ECH ')GOTO4500 IF(IH.EQ.'ARCC'.AND.IH2.EQ.'SCH ')GOTO4600 C IFOUND='NO' GOTO9000 C C STEP 10-- C EVALUATE THE CIRCULAR TRIG FUNCTIONS C 1100 CONTINUE ARG=X IF(IANGLU.EQ.'DEGR')ARG=(PI/180.0)*ARG IF(IANGLU.EQ.'GRAD')ARG=(PI/200.0)*ARG TERM=SIN(ARG) GOTO9000 C 1200 CONTINUE ARG=X IF(IANGLU.EQ.'DEGR')ARG=(PI/180.0)*ARG IF(IANGLU.EQ.'GRAD')ARG=(PI/200.0)*ARG TERM=COS(ARG) GOTO9000 C 1300 CONTINUE ARG=X IF(IANGLU.EQ.'DEGR')ARG=(PI/180.0)*ARG IF(IANGLU.EQ.'GRAD')ARG=(PI/200.0)*ARG TEMP=COS(ARG) IF(TEMP.NE.0.0)GOTO1330 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1311) 1311 FORMAT('***** ERROR IN DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1312) 1312 FORMAT(' ATTEMPT TO TAKE THE TANGENT OF A NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1313) 1313 FORMAT(' WHICH IS AN ODD MULTIPLE OF PI/2.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1314) 1314 FORMAT(' THIS IS ILLEGAL BECAUSE THE TANGENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1315) 1315 FORMAT(' IS INFINITE AT SUCH POINTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1316)X 1316 FORMAT(' THE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1330 CONTINUE TERM=SIN(ARG)/TEMP GOTO9000 C 1400 CONTINUE ARG=X IF(IANGLU.EQ.'DEGR')ARG=(PI/180.0)*ARG IF(IANGLU.EQ.'GRAD')ARG=(PI/200.0)*ARG TEMP=SIN(ARG) IF(TEMP.NE.0.0)GOTO1430 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1411) 1411 FORMAT('***** ERROR IN DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1412) 1412 FORMAT(' ATTEMPT TO TAKE THE COTANGENT OF A NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1413) 1413 FORMAT(' WHICH IS 0 OR A MULTIPLE OF PI.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1414) 1414 FORMAT(' THIS IS ILLEGAL BECAUSE THE COTANGENT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1415) 1415 FORMAT(' IS INFINITE AT SUCH POINTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1416)X 1416 FORMAT(' THE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1430 CONTINUE TERM=COS(ARG)/TEMP GOTO9000 C 1500 CONTINUE ARG=X IF(IANGLU.EQ.'DEGR')ARG=(PI/180.0)*ARG IF(IANGLU.EQ.'GRAD')ARG=(PI/200.0)*ARG TEMP=COS(ARG) IF(TEMP.NE.0.0)GOTO1530 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1511) 1511 FORMAT('***** ERROR IN DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1512) 1512 FORMAT(' ATTEMPT TO TAKE THE SECANT OF A NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1513) 1513 FORMAT(' WHICH IS AN ODD MULTIPLE OF PI/2.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1514) 1514 FORMAT(' THIS IS ILLEGAL BECAUSE THE SECANT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1515) 1515 FORMAT(' IS INFINITE AT SUCH POINTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1516)X 1516 FORMAT(' THE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1530 CONTINUE TERM=1.0/TEMP GOTO9000 C 1600 CONTINUE ARG=X IF(IANGLU.EQ.'DEGR')ARG=(PI/180.0)*ARG IF(IANGLU.EQ.'GRAD')ARG=(PI/200.0)*ARG TEMP=SIN(ARG) IF(TEMP.NE.0.0)GOTO1630 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1611) 1611 FORMAT('***** ERROR IN DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1612) 1612 FORMAT(' ATTEMPT TO TAKE THE COSECANT OF A NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1613) 1613 FORMAT(' WHICH IS 0 OR A MULTIPLE OF PI.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1614) 1614 FORMAT(' THIS IS ILLEGAL BECAUSE THE COSECANT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1615) 1615 FORMAT(' IS INFINITE AT SUCH POINTS.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1616)X 1616 FORMAT(' THE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 1630 CONTINUE TERM=1.0/TEMP GOTO9000 C C STEP 20-- C EVALUATE THE INVERSE CIRCULAR TRIG FUNCTIONS C 2100 CONTINUE IF(-1.0.LE.X.AND.X.LE.1.0)GOTO2130 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2111) 2111 FORMAT('***** ERROR IN DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2112) 2112 FORMAT(' ATTEMPT TO TAKE ARCSIN OF A NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2113) 2113 FORMAT(' SMALLER THAN -1 OR LARGER THAN +1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2114) 2114 FORMAT(' THIS IS ILLEGAL BECAUSE THE ARCSIN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2115) 2115 FORMAT(' IS NOT DEFINED IN SUCH DOMAIN.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2117)X 2117 FORMAT(' THE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2130 CONTINUE ARG=X IF(ARG.EQ.-1.0)RESULT=-PI/2.0 IF(ARG.EQ.-1.0)GOTO2190 IF(ARG.EQ.1.0)RESULT=PI/2.0 IF(ARG.EQ.1.0)GOTO2190 ARG2=ARG/SQRT(1.0-ARG*ARG) RESULT=ATAN(ARG2) 2190 CONTINUE IF(IANGLU.EQ.'DEGR')RESULT=(180.0/PI)*RESULT IF(IANGLU.EQ.'GRAD')RESULT=(200.0/PI)*RESULT TERM=RESULT GOTO9000 C 2200 CONTINUE IF(-1.0.LE.X.AND.X.LE.1.0)GOTO2230 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2211) 2211 FORMAT('***** ERROR IN DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2212) 2212 FORMAT(' ATTEMPT TO TAKE ARCCOS OF A NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2213) 2213 FORMAT(' SMALLER THAN -1 OR LARGER THAN +1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2214) 2214 FORMAT(' THIS IS ILLEGAL BECAUSE THE ARCCOS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2215) 2215 FORMAT(' IS NOT DEFINED IN SUCH DOMAIN.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2217)X 2217 FORMAT(' THE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2230 CONTINUE ARG=X IF(ARG.EQ.-1.0)RESULT=PI IF(ARG.EQ.-1.0)GOTO2290 IF(ARG.EQ.0.0)RESULT=PI/2.0 IF(ARG.EQ.0.0)GOTO2290 IF(ARG.EQ.1.0)RESULT=0.0 IF(ARG.EQ.1.0)GOTO2290 ARG2=(SQRT(1.0-ARG*ARG))/ARG RESULT=ATAN(ARG2) IF(RESULT.LT.0.0)RESULT=RESULT+PI 2290 CONTINUE IF(IANGLU.EQ.'DEGR')RESULT=(180.0/PI)*RESULT IF(IANGLU.EQ.'GRAD')RESULT=(200.0/PI)*RESULT TERM=RESULT GOTO9000 C 2300 CONTINUE ARG=X RESULT=ATAN(ARG) IF(IANGLU.EQ.'DEGR')RESULT=(180.0/PI)*RESULT IF(IANGLU.EQ.'GRAD')RESULT=(200.0/PI)*RESULT TERM=RESULT GOTO9000 C 2400 CONTINUE IF(X.EQ.0.0)RESULT=PI/2.0 IF(X.EQ.0.0)GOTO2490 ARG=1.0/X RESULT=ATAN(ARG) 2490 CONTINUE IF(IANGLU.EQ.'DEGR')RESULT=(180.0/PI)*RESULT IF(IANGLU.EQ.'GRAD')RESULT=(200.0/PI)*RESULT TERM=RESULT GOTO9000 C 2500 CONTINUE IF(X.LE.-1.0.OR.X.GE.1.0)GOTO2530 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2511) 2511 FORMAT('***** ERROR IN DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2512) 2512 FORMAT(' ATTEMPT TO TAKE ARCSEC OF A NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2513) 2513 FORMAT(' IN THE DOMAIN -1 TO +1 (EXCLUSIVE).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2514) 2514 FORMAT(' THIS IS ILLEGAL BECAUSE THE ARCSEC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2515) 2515 FORMAT(' IS NOT DEFINED IN SUCH DOMAIN.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2517)X 2517 FORMAT(' THE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2530 CONTINUE ARG=1.0/X IF(ARG.EQ.-1.0)RESULT=PI IF(ARG.EQ.-1.0)GOTO2590 IF(ARG.EQ.0.0)RESULT=PI/2.0 IF(ARG.EQ.0.0)GOTO2590 IF(ARG.EQ.1.0)RESULT=0.0 IF(ARG.EQ.1.0)GOTO2590 ARG2=(SQRT(1.0-ARG*ARG))/ARG RESULT=ATAN(ARG2) IF(RESULT.LT.0.0)RESULT=RESULT+PI 2590 CONTINUE IF(IANGLU.EQ.'DEGR')RESULT=(180.0/PI)*RESULT IF(IANGLU.EQ.'GRAD')RESULT=(200.0/PI)*RESULT TERM=RESULT GOTO9000 C 2600 CONTINUE IF(X.LE.-1.0.OR.X.GE.1.0)GOTO2630 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2611) 2611 FORMAT('***** ERROR IN DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2612) 2612 FORMAT(' ATTEMPT TO TAKE ARCCSC OF A NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2613) 2613 FORMAT(' IN THE DOMAIN -1 TO +1 (EXCLUSIVE).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2614) 2614 FORMAT(' THIS IS ILLEGAL BECAUSE THE ARCCSC') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2615) 2615 FORMAT(' IS NOT DEFINED IN SUCH DOMAIN.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,2617)X 2617 FORMAT(' THE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 2630 CONTINUE ARG=1.0/X IF(ARG.EQ.-1.0)RESULT=-PI/2.0 IF(ARG.EQ.-1.0)GOTO2690 IF(ARG.EQ.1.0)RESULT=PI/2.0 IF(ARG.EQ.1.0)GOTO2690 ARG2=ARG/SQRT(1.0-ARG*ARG) RESULT=ATAN(ARG2) 2690 CONTINUE IF(IANGLU.EQ.'DEGR')RESULT=(180.0/PI)*RESULT IF(IANGLU.EQ.'GRAD')RESULT=(200.0/PI)*RESULT TERM=RESULT GOTO9000 C C STEP 30-- C EVALUATE THE HYPERBOLIC TRIG FUNCTIONS C 3100 CONTINUE CCCCC THE ASYMPTOTIC TRAP WAS INSERTED JANUARY 1989 ARG=X IF(ARG.GT.80.0)TERM=CPUMAX IF(ARG.LT.-80.0)TERM=(-CPUMAX) IF(-80.0.LE.ARG.AND.ARG.LE.80.0)TERM=(EXP(ARG)-EXP(-ARG))/2.0 GOTO9000 C 3200 CONTINUE CCCCC THE ASYMPTOTIC TRAP WAS INSERTED JANUARY 1989 ARG=X IF(ARG.GT.80.0)TERM=CPUMAX IF(ARG.LT.-80.0)TERM=CPUMAX IF(-80.0.LE.ARG.AND.ARG.LE.80.0)TERM=(EXP(ARG)+EXP(-ARG))/2.0 GOTO9000 C 3300 CONTINUE CCCCC THE ASYMPTOTIC TRAP WAS INSERTED JANUARY 1989 ARG=X IF(ARG.GT.40.0)TERM=1.0 IF(ARG.LT.-40.0)TERM=(-1.0) IF(-40.0.LE.ARG.AND.ARG.LE.40.0)GOTO3310 GOTO3319 3310 CONTINUE TERM=(EXP(ARG)-EXP(-ARG))/(EXP(ARG)+EXP(-ARG)) GOTO3319 3319 CONTINUE GOTO9000 C 3400 CONTINUE CCCCC THE ASYMPTOTIC TRAP WAS INSERTED JANUARY 1989 ARG=X IF(ARG.GT.40.0)TERM=1.0 IF(ARG.LT.-40.0)TERM=(-1.0) IF(-40.0.LE.ARG.AND.ARG.LE.40.0)GOTO3410 GOTO3419 3410 CONTINUE TERM=(EXP(ARG)+EXP(-ARG))/(EXP(ARG)-EXP(-ARG)) GOTO3419 3419 CONTINUE GOTO9000 C 3500 CONTINUE CCCCC THE ASYMPTOTIC TRAP WAS INSERTED JANUARY 1989 ARG=X IF(ARG.GT.80.0)TERM=0.0 IF(ARG.LT.-80.0)TERM=0.0 IF(-80.0.LE.ARG.AND.ARG.LE.80.0)TERM=2.0/(EXP(ARG)+EXP(-ARG)) GOTO9000 C 3600 CONTINUE CCCCC THE ASYMPTOTIC TRAP WAS INSERTED JANUARY 1989 ARG=X IF(ARG.GT.80.0)TERM=0.0 IF(ARG.LT.-80.0)TERM=(-0.0) IF(-80.0.LE.ARG.AND.ARG.LE.80.0)TERM=2.0/(EXP(ARG)-EXP(-ARG)) GOTO9000 C C STEP 40-- C EVALUATE THE INVERSE HYPERBOLIC TRIG FUNCTIONS C 4100 CONTINUE ARG=X ARG2=ARG+SQRT(ARG*ARG+1.0) RESULT=ALOG(ARG2) TERM=RESULT GOTO9000 C 4200 CONTINUE IF(X.GE.1.0)GOTO4230 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4211) 4211 FORMAT('***** ERROR IN DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4212) 4212 FORMAT(' ATTEMPT TO TAKE ARCCOSH OF A NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4213) 4213 FORMAT(' SMALLER THAN -1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4214) 4214 FORMAT(' THIS IS ILLEGAL BECAUSE THE ARCCOSH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4215) 4215 FORMAT(' IS NOT DEFINED IN SUCH DOMAIN.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4217)X 4217 FORMAT(' THE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 4230 CONTINUE ARG=X IF(ARG.EQ.1.0)RESULT=0.0 IF(ARG.EQ.1.0)GOTO4290 ARG2=ARG+SQRT(ARG*ARG-1.0) RESULT=ALOG(ARG2) 4290 CONTINUE TERM=RESULT GOTO9000 C 4300 CONTINUE IF(-1.0.LT.X.AND.X.LT.1.0)GOTO4330 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4311) 4311 FORMAT('***** ERROR IN DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4312) 4312 FORMAT(' ATTEMPT TO TAKE ARCTANH OF A NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4313) 4313 FORMAT(' <= -1 OR >= +1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4314) 4314 FORMAT(' THIS IS ILLEGAL BECAUSE THE ARCTANH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4315) 4315 FORMAT(' IS NOT DEFINED IN SUCH DOMAIN.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4317)X 4317 FORMAT(' THE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 4330 CONTINUE ARG=X ARG2=(1.0+ARG)/(1.0-ARG) RESULT=0.5*ALOG(ARG2) TERM=RESULT GOTO9000 C 4400 CONTINUE IF(X.LT.-1.0.OR.1.0.LT.X)GOTO4430 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4411) 4411 FORMAT('***** ERROR IN DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4412) 4412 FORMAT(' ATTEMPT TO TAKE ARCCOTH OF A NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4413) 4413 FORMAT(' IN THE DOMAIN -1 TO 1 (INCLUSIVE).') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4414) 4414 FORMAT(' THIS IS ILLEGAL BECAUSE THE ARCCOTH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4415) 4415 FORMAT(' IS NOT DEFINED IN SUCH DOMAIN.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4417)X 4417 FORMAT(' THE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 4430 CONTINUE ARG=X ARG2=(ARG+1.0)/(ARG-1.0) RESULT=0.5*ALOG(ARG2) TERM=RESULT GOTO9000 C 4500 CONTINUE IF(0.0.LT.X.AND.X.LE.1.0)GOTO4530 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4511) 4511 FORMAT('***** ERROR IN DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4512) 4512 FORMAT(' ATTEMPT TO TAKE ARCSECH OF A NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4513) 4513 FORMAT(' <= 0 OR > +1.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4514) 4514 FORMAT(' THIS IS ILLEGAL BECAUSE THE ARCSECH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4515) 4515 FORMAT(' IS NOT DEFINED IN SUCH DOMAIN.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4517)X 4517 FORMAT(' THE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 4530 CONTINUE ARG=1.0/X IF(ARG.EQ.1.0)RESULT=0.0 IF(ARG.EQ.1.0)GOTO4590 ARG2=ARG+SQRT(ARG*ARG-1.0) RESULT=ALOG(ARG2) 4590 CONTINUE TERM=RESULT GOTO9000 C 4600 CONTINUE IF(X.NE.0.0)GOTO4630 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4611) 4611 FORMAT('***** ERROR IN DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4612) 4612 FORMAT(' ATTEMPT TO TAKE ARCCSCH OF A NUMBER') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4613) 4613 FORMAT(' IDENTICALLY 0.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4614) 4614 FORMAT(' THIS IS ILLEGAL BECAUSE THE ARCCSCH') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4615) 4615 FORMAT(' IS NOT DEFINED FOR 0.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,4617)X 4617 FORMAT(' THE NUMBER = ',E15.7) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 4630 CONTINUE ARG=1.0/X ARG2=ARG+SQRT(ARG*ARG+1.0) RESULT=ALOG(ARG2) TERM=RESULT GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGEV.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF DPLIB2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IH,IH2,X 9012 FORMAT('IH,IH2,X = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)SAVE1,SAVE2,I,IANGLU 9013 FORMAT('SAVE1,SAVE2,I,IANGLU = ',E15.7,E15.7,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)RESULT,TERM,IBUGEV 9014 FORMAT('RESULT,TERM,IBUGEV = ',2E15.7,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUND,IERROR 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END CCCCC SUBROUTINE DPLIB3(IH,IH2,X,SAVE1,SAVE2,I,IANGLU, CCCCC SEPTEMBER 1994. ADD SAVE3 ARGUMENT. CCCCC MAY 1998. ADD SAVE5 ARGUMENT. SUBROUTINE DPLIB3(IH,IH2,X,SAVE1,SAVE2,SAVE3,SAVE4,SAVE5, 1SAVE6,SAVE7,SAVE8, 1I,IANGLU, 1TERM,IBUGEV,IFOUND,IERROR) C C PURPOSE--PERFORM A LIBRARY FUNCTION EVALUATION. C NOTE--THIS IS PART 3 C (EVALUATE VARIOUS PROBABILITY FUNCTIONS AND C VARIOUS SPECIAL MATHEMATICAL FUNCTIONS) C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JANUARY 1979. C UPDATED --NOVEMBER 1979. C UPDATED --FEBRUARY 1981. C UPDATED --JUNE 1981. C UPDATED --JULY 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --JUNE 1987. WEICDF, WEIPDF, WEIPPF C UPDATED --MAY 1989. CP, CPK, PERDEF, EXPLOS C UPDATED --MAY 1990. INV. GAUS. PDF, CDF, PPF C UPDATED --MAY 1990. WALD PDF, CDF, PPF C UPDATED --MAY 1990. REV INV GAUS PDF, CDF, PPF C UPDATED --MAY 1990. FAT. LIFE PDF, CDF, PPF C UPDATED --APRIL 1993. ADD TYPE ARG. TO WEIBULL C UPDATED --DECEMBER 1993. GEPCDF, GEPPDF, GEPPPF C GENERALIZED PARETO C UPDATED --JANUARY 1994. MINMAX FOR WEI... C UPDATED --JANUARY 1994. WEIB MINMAX TO DPCOS2.INC C UPDATED --APRIL 1994. BINCDF, BIBPDF, BINPPF C UPDATED --APRIL 1994. POICDF, POIPDF, POIPPF C UPDATED --APRIL 1994. SEMCDF, SEMPDF, SEMPPF C UPDATED --APRIL 1994. NBCDF, NBPDF, NBPPF C UPDATED --APRIL 1994. CAUCDF, CAUPDF, CAUPPF, CAUSF C UPDATED --APRIL 1994. DEXCDF, DEXPDF, DEXPPF, DEXSF C UPDATED --APRIL 1994. EV1CDF, EV1PDF, EV1PPF C UPDATED --APRIL 1994. EV2CDF, EV2PDF, EV2PPF C UPDATED --APRIL 1994. EXPCDF, EXPPDF, EXPPPF, EXPSF C UPDATED --APRIL 1994. GAMCDF, GAMPPF C UPDATED --APRIL 1994. GEOCDF, GEOPDF, GEOPPF C UPDATED --APRIL 1994. HFNCDF, HFNPDF, HFNPPF C UPDATED --APRIL 1994. LAMCDF, LAMPDF, LAMPPF, LAMPPF C UPDATED --APRIL 1994. LGNCDF, LGNPDF, LGNPPF C UPDATED --APRIL 1994. LOGCDF, LOGPDF, LOGPPF, LOGPPF C UPDATED --APRIL 1994. UNICDF, UNIPDF, UNIPPF, UNISF C UPDATED --SEPTEMBER 1994. BETCDF, BETPDF, BETPPF C UPDATED --SEPTEMBER 1994. DISCDF, DISPDF, DISPPF C UPDATED --SEPTEMBER 1994. TRICDF, TRIPDF, TRIPPF C UPDATED --SEPTEMBER 1994. NCBCDF, NCBPPF C UPDATED --SEPTEMBER 1994. NCCCDF, NCCPPF, NCCNCP C UPDATED --SEPTEMBER 1994. NCFCDF, NCFPPF C UPDATED --SEPTEMBER 1994. DNFCDF, DNFPPF C UPDATED --SEPTEMBER 1994. NCTCDF, NCTPPF C UPDATED --SEPTEMBER 1994. DNTCDF, DNTPPF C UPDATED --SEPTEMBER 1994. GAMPDF C UPDATED --SEPTEMBER 1994. SAVE3 FOR NON-CENTRAL DISTR. C UPDATED --SEPTEMBER 1994. ADDITIONAL BESSEL FUNCTIONS C UPDATED --SEPTEMBER 1994. ELLIPTCAL INTEGRALS (BOTH C CARLSON AND LEGENDRE) C UPDATED --SEPTEMBER 1994. 3 EXPONENTIAL INTEGRALS C UPDATED --SEPTEMBER 1994. LOGARITHMIC INTEGRAL C UPDATED --SEPTEMBER 1994. SINE, COSINE, HYPERBOLIC SINE, C HYPERBOLIC COSINE INTEGRALS C UPDATED --SEPTEMBER 1994. DAWSON INTEGRALS C UPDATED --SEPTEMBER 1994. SPENCE DILOGARITHM C UPDATED --SEPTEMBER 1994. HYPCDF, HYPPDF, HYPPPF C UPDATED --OCTOBER 1994. VONCDF, VONPDF, VONPPF C UPDATED --OCTOBER 1994. USE DOUBLE PRECISION FOR I0, C I1, IN BESSEL FUNCTIONS. C UPDATED --OCTOBER 1994. CBESSJR, CBESSJI C UPDATED --OCTOBER 1994. CBESSYR, CBESSYI C UPDATED --OCTOBER 1994. CBESSIR, CBESSII C UPDATED --OCTOBER 1994. CBESSKR, CBESSKI C UPDATED --OCTOBER 1994. BVNCDF C UPDATED --OCTOBER 1994. CABS, CCOS, CEXP, CLOG, C CSIN, CSQRT C UPDATED --NOVEMBER 1994. FRESNC, FRESNS, FRESNF, C FRESNG, PEQ, PEQ1, PLEM, PLEM1 C PEQI, PEQ1I, PLEMI, PLEM1I C UPDATED --NOVEMBER 1994. CN, DN, SN C UPDATED --APRIL 1995. EXPONENTIAL INTEGRAL FIX C UPDATED --APRIL 1995. SINE INTEGRAL AND C HYPERBOLIC SINE INTEGRAL C FOR X < 0 C UPDATED --APRIL 1995. COSCDF, COSPDF, COSPPF C UPDATED --APRIL 1995. ALPCDF, ALPPDF, ALPPPF C UPDATED --APRIL 1995. PNRCDF, PNRPDF, PNRPPF C UPDATED --APRIL 1995. PLNCDF, PLNPDF, PLNPPF C UPDATED --APRIL 1995. FNRCDF, FNRPDF, FNRPPF C UPDATED --APRIL 1995. TNRCDF, TNRPDF, TNRPPF C UPDATED --APRIL 1995. POWCDF, POWPDF, POWPPF C UPDATED --APRIL 1995. CHCDF, CHPDF, CHPPF C UPDATED --APRIL 1995. DLGCDF, DLGPDF, DLGPPF C UPDATED --APRIL 1995. WARCDF, WARPDF, WARPPF C UPDATED --APRIL 1995. LLGCDF, LLGPDF, LLGPPF C UPDATED --APRIL 1995. GGDCDF, GGDPDF, GGDPPF C UPDATED --MAY 1995. NCTPDF C UPDATED --JUNE 1995. ADD ARGUMENT TO WARCDF C UPDATED --JULY 1995. ADD HERMITE, LEGENDRE, C LAGUERRE, CHEBYCHEV T AND U, C NORMALIZED LAGUERRE, JACOBI, C ULTRASPHERICAL, ASSOCIATED C LEGENDRE C POLYNOMIALS C UPDATED --SEPTEMBER 1995. ANGCDF, ANGPDF, ANGPPF C UPDATED --SEPTEMBER 1995. ARSCDF, ARSPDF, ARSPPF C UPDATED --SEPTEMBER 1995. ACTIVATE BVNPDF C UPDATED --SEPTEMBER 1995. ACTIVATE TNRCDF, TNRPPF C UPDATED --SEPTEMBER 1995. ACTIVATE FNRCDF, FNRPPF C UPDATED --OCTOBER 1995. DWECDF, DWEPDF, DWEPPF C UPDATED --OCTOBER 1995. LGACDF, LGAPDF, LGAPPF C UPDATED --OCTOBER 1995. HSECDF, HSEPDF, HSEPPF C UPDATED --OCTOBER 1995. HFCCDF, HFCPDF, HFCPPF C UPDATED --OCTOBER 1995. HFLCDF, HFLPDF, HFLPPF C UPDATED --OCTOBER 1995. GEVCDF, GEVPDF, GEVPPF C UPDATED --OCTOBER 1995. GOMCDF, GOMPDF, GOMPPF C UPDATED --OCTOBER 1995. PA2CDF, PA2PDF, PA2PPF C UPDATED --OCTOBER 1995. WCACDF, WCAPDF, WCAPPF C UPDATED --OCTOBER 1995. EWECDF, EWEPDF, EWEPPF C UPDATED --OCTOBER 1995. TNECDF, TNEPDF, TNEPPF C UPDATED --DECEMBER 1995. GLOCDF, GLOPDF, GLOPPF C UPDATED --DECEMBER 1995. PEXCDF, PEXPDF, PEXPPF C UPDATED --JANUARY 1996. DGACDF, DGAPDF, DGAPPF C UPDATED --JANUARY 1996. KAPCDF, KAPPDF, KAPPPF C UPDATED --JANUARY 1996. FCACDF, FCAPDF, FCAPPF C UPDATED --JANUARY 1996. NCCPDF C UPDATED --FEBRUARY 1996. BBNCDF, BBNPDF, BBNPPF C UPDATED --FEBRUARY 1996. BRACDF, BRAPDF, BRAPPF C UPDATED --FEBRUARY 1996. GEXCDF, GEXPDF, GEXPPF C UPDATED --MAY 1996. RECCDF, RECPDF, RECPPF C UPDATED --SEPTEMBER 1997. BN, EN, BINOM C UPDATED --APRIL 1998. LOCATION AND SCALE PARAMETERS C FOR MANY DISTRIBUTIONS C UPDATED --APRIL 1998. HAZARD AND CUMULATIVE HAZARD C FOR MANY DISTRIBUTIONS C C UPDATED --MAY 1998. NORMXCDF, NORMXPDF, NORMXPPF C UPDATED --MARCH 1999. SRACDF, SRAPPF C UPDATED --MARCH 1999. ABRAM, CLAUSN, DEBYE C EXP3, GOODST, LOBACH, C STROM, SYNCH1, SYNCH2, TRAN C UPDATED --AUGUST 2001. GLDCDF, GLDPDF, GLDPPF, C GLDCHK, GLDLLM, GLDULM C UPDATED --SEPTEMBER 2001. LDECDF, LDEPDF, LDEPPF C UPDATED --SEPTEMBER 2001. IWECDF, IWEPDF, IWEPPF C UPDATED --SEPTEMBER 2001. JSBCDF, JSBPDF, JSBPPF C UPDATED --SEPTEMBER 2001. JSUCDF, JSUPDF, JSUPPF C UPDATED --NOVEMBER 2001. GEECDF, GEEPDF, GEEPPF, C GEEHAZ, GEECHAZ C UPDATED --MAY 2002. TSPCDF, TSPPDF, TSPPPF, C UPDATED --MAY 2002. BWECDF, BWEPDF, BWEPPF, C BWEHAZ, BWECHAZ C UPDATED --JANUARY 2003. GHPDF C UPDATED --APRIL 2003. LANCDF, LANPDF, LANPPF C UPDATED --APRIL 2003. LANXM1, LANXM2, LANDIF C UPDATED --MAY 2003. IBPDF, SLAPDF C UPDATED --MAY 2003. ERRCDF, ERRPDF, ERRPPF C UPDATED --JUNE 2003. TRACDF, TRAPDF, TRAPPF C UPDATED --NOVEMBER 2003. FTCDF, FTPDF, FTPPF C UPDATED --NOVEMBER 2003. SNCDF, SNPDF, SNPPF C UPDATED --NOVEMBER 2003. TNCDF, TNPDF, TNPPF C UPDATED --NOVEMBER 2003. ZIPCDF, ZIPPDF, ZIPPPF C UPDATED --DECEMBER 2003. SLACDF, SLAPPF C UPDATED --DECEMBER 2003. IBCDF, IBPPF C UPDATED --DECEMBER 2003. MAKCDF, MAKPDF, MAKPPF C UPDATED --MARCH 2004. LSNCDF, LSNPDF, LSNPPF C UPDATED --MARCH 2004. LSTCDF, LSTPDF, LSTPPF C UPDATED --MARCH 2004. POLCDF, POLPDF, POLPPF C UPDATED --APRIL 2004. HERCDF, HERPDF, HERPPF C UPDATED --APRIL 2004. BU1CDF, BU1PDF, BU1PPF C UPDATED --APRIL 2004. ... C UPDATED --APRIL 2004. B12CDF, B12PDF, B12PPF C UPDATED --APRIL 2004. YULCDF, YULPDF, YULPPF C UPDATED --APRIL 2004. GWACDF, GWAPDF, GWAPPF C UPDATED --MAY 2004. DNTPDF, DNFPDF, NCFPDF C UPDATED --JUNE 2004. SDECDF, SDEPDF, SDEPPF C UPDATED --JUNE 2004. ADECDF, ADEPDF, ADEPPF C UPDATED --JUNE 2004. MAXCDF, MAXPDF, MAXPPF C UPDATED --JUNE 2004. FERCDF, FERPDF, FERPPF C UPDATED --JUNE 2004. RAYCDF, RAYPDF, RAYPPF C UPDATED --JULY 2004. GALCDF, GALPDF, GALPPF C UPDATED --AUGUST 2004. GIGCDF, GALPDF, GALPPF C UPDATED --AUGUST 2004. BEICDF, BEIPDF, BEIPPF C UPDATED --AUGUST 2004. BEKCDF, BEKPDF, BEKPPF C UPDATED --AUGUST 2004. MCLCDF, MCLPDF, MCLPPF C UPDATED --SEPTEMBER 2004. GMCCDF, GMCPDF, GMCPPF C UPDATED --SEPTEMBER 2004. HBOCDF, HBOPDF, HBOPPF C UPDATED --DECEMBER 2004. RESOLVE AMBIGUITY IN CALLS C TO PARETO (PAR) AND PARETO C SECOND KIND (PA2) SUBROUTINES C UPDATED --MARCH 2005. EXPAFR, LGNAFR, WEIAFR C UPDATED --JULY 2005. CALL LIST TO LGAxxx AND SNxxx C UPDATED --AUGUST 2005. ADJUSTMENT TO C TRICDF, TRIPDF, TRIPPF C TO HAVE GENERAL CASE HANDLED C WITHIN THE ROUTINE SINCE SHAPE C PARAMETER BOUNDED BY LOWER AND C UPPER LIMIT PARAMETERS. C UPDATED --NOVEMBER 2005. AIRINT C UPDATED --NOVEMBER 2005. AIRYGI C UPDATED --NOVEMBER 2005. AIRYHI C UPDATED --NOVEMBER 2005. ATNINT C UPDATED --NOVEMBER 2005. BIRINT C UPDATED --NOVEMBER 2005. I0INT C UPDATED --NOVEMBER 2005. I0ML0 C UPDATED --NOVEMBER 2005. I1ML1 C UPDATED --NOVEMBER 2005. J0INT C UPDATED --NOVEMBER 2005. K0INT C UPDATED --NOVEMBER 2005. Y0INT C UPDATED --FEBRUARY 2006. GL5CDF, GL5PDF, GL5PPF C UPDATED --FEBRUARY 2006. WAKCDF, WAKPDF, WAKPPF C UPDATED --MARCH 2006. BNOCDF, BNOPDF, BNOPPF C UPDATED --MARCH 2006. GL2CDF, GL2PDF, GL2PPF C UPDATED --MARCH 2006. GL3CDF, GL3PDF, GL3PPF C UPDATED --MARCH 2006. GL4CDF, GL4PDF, GL4PPF C UPDATED --MARCH 2006. ALDCDF, ALDPDF, ALDPPF C UPDATED --MAY 2006. BGECDF, BGEPDF, BGEPPF C UPDATED --MAY 2006. CHANGE ZIPPDF TO ZETPDF C UPDATED --MAY 2006. BTACDF, BTAPDF, BTAPPF C UPDATED --MAY 2006. LBECDF, LBEPDF, LBEPPF C UPDATED --JUNE 2006. LPOCDF, LPOPDF, LPOPPF C UPDATED --JUNE 2006. MATCDF, MATPDF, MATPPF C UPDATED --JUNE 2006. LCTCDF, LCTPDF, LCTPPF C UPDATED --JUNE 2006. OCCCDF, OCCPDF, OCCPPF C UPDATED --JUNE 2006. PAPCDF, PAPPDF, PAPPPF C UPDATED --JUNE 2006. NEYCDF, NEYPDF, NEYPPF C UPDATED --JUNE 2006. DXGCDF, DXGPDF, DXGPPF C UPDATED --JUNE 2006. LOSCDF, LOSPDF, LOSPPF C UPDATED --JUNE 2006. GLSCDF, GLSPDF, GLSPPF C UPDATED --JULY 2006. GETCDF, GETPDF, GETPPF C UPDATED --JULY 2006. GNBCDF, GNBPDF, GNBPPF C UPDATED --JULY 2006. QBICDF, QBIPDF, QBIPPF C UPDATED --AUGUST 2006. CONCDF, CONPDF, CONPPF C UPDATED --AUGUST 2006. LKCDF, LKPDF, LKPPF C UPDATED --SEPTEMBER 2006. KATCDF, KATPDF, KATPPF C UPDATED --NOVEMBER 2006. DIWCDF, DIWPDF, DIWPPF, C DIWHAZ C UPDATED --NOVEMBER 2006. GLGCDF, GLGPDF, GLGPPF C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IANGLU CHARACTER*4 IBUGEV CHARACTER*4 IWRITE CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 IFLAG2 C C--------------------------------------------------------------------- C CCCCC THE FOLLOWING LINE WAS ADDED JANUARY 1994 CCCCC SO AS TO ALLOW THE EXTRACTION OF MINMAX JANUARY 1994 CCCCC FOR WEIBULL, (EV1, AND EV2) DISTRIBUTIONS JANUARY 1994 INCLUDE 'DPCOS2.INC' INCLUDE 'DPCOMC.INC' INCLUDE 'DPCOST.INC' C CCCCC SEPTEMBER 1994. FOLLOWING ROUTINE NEEDED BY SOME NEW CCCCC BESSEL FUNCTION ROUTINES. C DIMENSION TEMP1(1000) DOUBLE PRECISION DTEMP1(1000) COMPLEX CTEMP1(102) COMPLEX Z1 COMPLEX Z2 COMPLEX PEQ COMPLEX PEQ1 COMPLEX PLEM COMPLEX PLEM1 DOUBLE PRECISION DARG1 DOUBLE PRECISION DARG2 DOUBLE PRECISION DARG3 DOUBLE PRECISION DARG4 DOUBLE PRECISION DARG5 DOUBLE PRECISION DARG6 DOUBLE PRECISION DARG7 DOUBLE PRECISION DARG8 DOUBLE PRECISION DARG9 DOUBLE PRECISION DSPENC DOUBLE PRECISION DBESI0 DOUBLE PRECISION DBESI1 DOUBLE PRECISION DBSI0E DOUBLE PRECISION DBSI1E DOUBLE PRECISION DRESLT CCCCC JULY 1995. ADD FOLLOWING LINES DOUBLE PRECISION DRSLT2 DOUBLE PRECISION DTERM1 DOUBLE PRECISION DTERM2 DOUBLE PRECISION DTERM3 DOUBLE PRECISION DTERM4 DOUBLE PRECISION DTERM5 DOUBLE PRECISION DGAMMA DOUBLE PRECISION DGAMR DOUBLE PRECISION DPI DOUBLE PRECISION DPN(10) DOUBLE PRECISION DABRAM(0:100) INTEGER IPN(10) C DOUBLE PRECISION DFRENC C DOUBLE PRECISION ABRAM0 DOUBLE PRECISION ABRAM1 DOUBLE PRECISION ABRAM2 DOUBLE PRECISION CLAUSN DOUBLE PRECISION DEBYE1 DOUBLE PRECISION DEBYE2 DOUBLE PRECISION DEBYE3 DOUBLE PRECISION DEBYE4 DOUBLE PRECISION EXP3 DOUBLE PRECISION GOODST DOUBLE PRECISION LANCDF DOUBLE PRECISION LANPDF DOUBLE PRECISION LANPPF DOUBLE PRECISION LANXM1 DOUBLE PRECISION LANXM2 DOUBLE PRECISION LANDIF DOUBLE PRECISION LOBACH DOUBLE PRECISION STROM DOUBLE PRECISION SYNCH1 DOUBLE PRECISION SYNCH2 DOUBLE PRECISION TRAN02 DOUBLE PRECISION TRAN03 DOUBLE PRECISION TRAN04 DOUBLE PRECISION TRAN05 DOUBLE PRECISION TRAN06 DOUBLE PRECISION TRAN07 DOUBLE PRECISION TRAN08 DOUBLE PRECISION TRAN09 DOUBLE PRECISION AIRINT DOUBLE PRECISION AIRYGI DOUBLE PRECISION AIRYHI DOUBLE PRECISION ATNINT DOUBLE PRECISION BIRINT DOUBLE PRECISION I0INT DOUBLE PRECISION I0ML0 DOUBLE PRECISION I1ML1 DOUBLE PRECISION J0INT DOUBLE PRECISION K0INT DOUBLE PRECISION Y0INT DOUBLE PRECISION CDFGLO DOUBLE PRECISION QUAGLO DOUBLE PRECISION CDFWAK DOUBLE PRECISION QUAWAK DOUBLE PRECISION XPAR(5) C LOGICAL HYPPNT 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 C00/1.0/ DATA C11/1.0/ DATA C22,C20/2.0,-1.0/ DATA C33,C31/4.0,-3.0/ DATA C44,C42,C40/8.0,-8.0,1.0/ DATA C55,C53,C51/16.0,-20.0,5.0/ DATA C66,C64,C62,C60/32.0,-48.0,18.0,-1.0/ DATA C77,C75,C73,C71/64.0,-112.0,56.0,-7.0/ DATA C88,C86,C84,C82,C80/128.0,-256.0,160.0,-32.0,1.0/ DATA C99,C97,C95,C93,C91/256.0,-576.0,432.0,-120.0,9.0/ DATA C1010,C108,C106,C104,C102,C100/512.0,-1280.0,1120.0,-400.0, 1 50.0,-1.0/ C DATA D00,D02,D04,D06,D08,D010,D012 1 /1.0,-2.2499997,1.2656208,-0.3163866,0.0444479, 1 -0.0039444,0.0002100/ DATA F00,F01,F02,F03,F04,F05,F06 1 /0.79788456,-0.00000077,-0.00552740,-0.00009512, 1 0.00137237,-0.00072805,0.00014476/ DATA G00,G01,G02,G03,G04,G05,G06 1 /-0.78539816,-0.04166397,-0.00003954,0.00262573, 1 -0.00054125,-0.00029333,0.00013558/ DATA D10,D12,D14,D16,D18,D110,D112 1 /0.5,-0.56249985,0.21093573,-0.03954289, 1 0.00443319,-0.00031761,0.00001109/ DATA F10,F11,F12,F13,F14,F15,F16 1 /0.79788456,0.00000156,0.01659667,0.00017105, 1 -0.00249511,0.00113653,-0.00020033/ DATA G10,G11,G12,G13,G14,G15,G16 1 /-2.35619449,0.12499612,0.00005650,-0.00637879, 1 0.00074348,0.00079824,-0.00029166/ DATA REALPI /3.141593/ DATA DPI / 3.1415926535 8979323846 2643383279 503 D0 / C C-----START POINT----------------------------------------------------- C IFOUND='NO' IERROR='NO' C ISUBN1='DPLI' ISUBN2='B2 ' C IF(IBUGEV.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPLIB3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IH,IH2,X 52 FORMAT('IH,IH2,X = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)SAVE1,SAVE2,I,IANGLU 53 FORMAT('SAVE1,SAVE2,I,IANGLU = ',E15.7,E15.7,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)TERM,IBUGEV,IFOUND,IERROR,NUMBPW 54 FORMAT('TERM,IBUGEV,IFOUND,IERROR,NUMBPW = ', 1E15.7,2X,A4,2X,A4,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IFOUND,IERROR 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IFOUND='YES' C IF(IH.EQ.'NORC'.AND.IH2.EQ.'DF ')GOTO551 IF(IH.EQ.'NORP'.AND.IH2.EQ.'DF ')GOTO552 IF(IH.EQ.'NORP'.AND.IH2.EQ.'PF ')GOTO553 IF(IH.EQ.'NORS'.AND.IH2.EQ.'F ')GOTO554 IF(IH.EQ.'NORH'.AND.IH2.EQ.'AZ ')GOTO555 IF(IH.EQ.'NORC'.AND.IH2.EQ.'HAZ ')GOTO556 IF(IH.EQ.'NORM'.AND.IH2.EQ.'XCDF')GOTO8557 IF(IH.EQ.'NORM'.AND.IH2.EQ.'XPDF')GOTO8558 IF(IH.EQ.'NORM'.AND.IH2.EQ.'XPPF')GOTO8559 C IF(IH.EQ.'TCDF'.AND.IH2.EQ.' ')GOTO561 IF(IH.EQ.'TPDF'.AND.IH2.EQ.' ')GOTO562 IF(IH.EQ.'TPPF'.AND.IH2.EQ.' ')GOTO563 C IF(IH.EQ.'CHSC'.AND.IH2.EQ.'DF ')GOTO571 IF(IH.EQ.'CHSP'.AND.IH2.EQ.'DF ')GOTO572 IF(IH.EQ.'CHSP'.AND.IH2.EQ.'PF ')GOTO573 C IF(IH.EQ.'FCDF'.AND.IH2.EQ.' ')GOTO581 IF(IH.EQ.'FPDF'.AND.IH2.EQ.' ')GOTO582 IF(IH.EQ.'FPPF'.AND.IH2.EQ.' ')GOTO583 C IF(IH.EQ.'WEIC'.AND.IH2.EQ.'DF ')GOTO591 IF(IH.EQ.'WEIP'.AND.IH2.EQ.'DF ')GOTO592 IF(IH.EQ.'WEIP'.AND.IH2.EQ.'PF ')GOTO593 IF(IH.EQ.'WEIH'.AND.IH2.EQ.'AZ ')GOTO594 IF(IH.EQ.'WEIC'.AND.IH2.EQ.'HAZ ')GOTO595 IF(IH.EQ.'WEIA'.AND.IH2.EQ.'FR ')GOTO596 C CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1990 IF(IH.EQ.'IGCD'.AND.IH2.EQ.'F ')GOTO601 IF(IH.EQ.'IGPD'.AND.IH2.EQ.'F ')GOTO602 IF(IH.EQ.'IGPP'.AND.IH2.EQ.'F ')GOTO603 IF(IH.EQ.'IGHA'.AND.IH2.EQ.'Z ')GOTO604 IF(IH.EQ.'IGCH'.AND.IH2.EQ.'AZ ')GOTO605 C CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1990 IF(IH.EQ.'WALC'.AND.IH2.EQ.'DF ')GOTO611 IF(IH.EQ.'WALP'.AND.IH2.EQ.'DF ')GOTO612 IF(IH.EQ.'WALP'.AND.IH2.EQ.'PF ')GOTO613 IF(IH.EQ.'WALH'.AND.IH2.EQ.'AZ ')GOTO614 IF(IH.EQ.'WALC'.AND.IH2.EQ.'HAZ ')GOTO615 C CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1990 IF(IH.EQ.'RIGC'.AND.IH2.EQ.'DF ')GOTO621 IF(IH.EQ.'RIGP'.AND.IH2.EQ.'DF ')GOTO622 IF(IH.EQ.'RIGP'.AND.IH2.EQ.'PF ')GOTO623 IF(IH.EQ.'RIGH'.AND.IH2.EQ.'AZ ')GOTO624 IF(IH.EQ.'RIGC'.AND.IH2.EQ.'HAZ ')GOTO625 C CCCCC THE FOLLOWING 3 LINES WERE ADDED MAY 1990 IF(IH.EQ.'FLCD'.AND.IH2.EQ.'F ')GOTO631 IF(IH.EQ.'FLPD'.AND.IH2.EQ.'F ')GOTO632 IF(IH.EQ.'FLPP'.AND.IH2.EQ.'F ')GOTO633 IF(IH.EQ.'FLHA'.AND.IH2.EQ.'Z ')GOTO634 IF(IH.EQ.'FLCH'.AND.IH2.EQ.'AZ ')GOTO635 C CCCCC THE FOLLOWING 3 LINES WERE ADDED DECEMBER 1993 IF(IH.EQ.'GEPC'.AND.IH2.EQ.'DF ')GOTO641 IF(IH.EQ.'GEPP'.AND.IH2.EQ.'DF ')GOTO642 IF(IH.EQ.'GEPP'.AND.IH2.EQ.'PF ')GOTO643 IF(IH.EQ.'GEPH'.AND.IH2.EQ.'AZ ')GOTO644 IF(IH.EQ.'GEPC'.AND.IH2.EQ.'HAZ ')GOTO645 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'BINC'.AND.IH2.EQ.'DF ')GOTO651 IF(IH.EQ.'BINP'.AND.IH2.EQ.'DF ')GOTO652 IF(IH.EQ.'BINP'.AND.IH2.EQ.'PF ')GOTO653 C CCCCC THE FOLLOWING 2 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'POIC'.AND.IH2.EQ.'DF ')GOTO661 IF(IH.EQ.'POIP'.AND.IH2.EQ.'DF ')GOTO662 IF(IH.EQ.'POIP'.AND.IH2.EQ.'PF ')GOTO663 C CCCCC THE FOLLOWING 2 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'SEMC'.AND.IH2.EQ.'DF ')GOTO671 IF(IH.EQ.'SEMP'.AND.IH2.EQ.'DF ')GOTO672 IF(IH.EQ.'SEMP'.AND.IH2.EQ.'PF ')GOTO673 C CCCCC THE FOLLOWING 2 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'NBCD'.AND.IH2.EQ.'F ')GOTO681 IF(IH.EQ.'NBPD'.AND.IH2.EQ.'F ')GOTO682 IF(IH.EQ.'NBPP'.AND.IH2.EQ.'F ')GOTO683 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'CAUC'.AND.IH2.EQ.'DF ')GOTO691 IF(IH.EQ.'CAUP'.AND.IH2.EQ.'DF ')GOTO692 IF(IH.EQ.'CAUP'.AND.IH2.EQ.'PF ')GOTO693 IF(IH.EQ.'CAUS'.AND.IH2.EQ.'F ')GOTO694 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'DEXC'.AND.IH2.EQ.'DF ')GOTO701 IF(IH.EQ.'DEXP'.AND.IH2.EQ.'DF ')GOTO702 IF(IH.EQ.'DEXP'.AND.IH2.EQ.'PF ')GOTO703 IF(IH.EQ.'DEXS'.AND.IH2.EQ.'F ')GOTO704 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'EV1C'.AND.IH2.EQ.'DF ')GOTO711 IF(IH.EQ.'EV1P'.AND.IH2.EQ.'DF ')GOTO712 IF(IH.EQ.'EV1P'.AND.IH2.EQ.'PF ')GOTO713 IF(IH.EQ.'EV1H'.AND.IH2.EQ.'AZ ')GOTO714 IF(IH.EQ.'EV1C'.AND.IH2.EQ.'HAZ ')GOTO715 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'EV2C'.AND.IH2.EQ.'DF ')GOTO721 IF(IH.EQ.'EV2P'.AND.IH2.EQ.'DF ')GOTO722 IF(IH.EQ.'EV2P'.AND.IH2.EQ.'PF ')GOTO723 IF(IH.EQ.'EV2H'.AND.IH2.EQ.'AZ ')GOTO724 IF(IH.EQ.'EV2C'.AND.IH2.EQ.'HAZ ')GOTO725 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'EXPC'.AND.IH2.EQ.'DF ')GOTO731 IF(IH.EQ.'EXPP'.AND.IH2.EQ.'DF ')GOTO732 IF(IH.EQ.'EXPP'.AND.IH2.EQ.'PF ')GOTO733 IF(IH.EQ.'EXPS'.AND.IH2.EQ.'F ')GOTO734 IF(IH.EQ.'EXPH'.AND.IH2.EQ.'AZ ')GOTO735 IF(IH.EQ.'EXPC'.AND.IH2.EQ.'HAZ ')GOTO736 IF(IH.EQ.'EXPA'.AND.IH2.EQ.'FR ')GOTO737 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'GAMC'.AND.IH2.EQ.'DF ')GOTO741 IF(IH.EQ.'GAMP'.AND.IH2.EQ.'DF ')GOTO742 IF(IH.EQ.'GAMP'.AND.IH2.EQ.'PF ')GOTO743 IF(IH.EQ.'GAMH'.AND.IH2.EQ.'AZ ')GOTO744 IF(IH.EQ.'GAMC'.AND.IH2.EQ.'HAZ ')GOTO745 C CCCCC MARCH 2004. MAKE DISTINCTION BETWEEN TWO COMMON DEFINITIONS CCCCC OF GEOMETRIC DISTRIBUTION. THE JOHNSON, KOTZ, AND KEMP CCCCC DEFINITION (THE DEFAULT) IS THE NUMBER OF TRIALS UP TO AND CCCCC INCLUDING THE FIRST SUCCESS (OR FAILURE). THE DEFINITION CCCCC USED IN THE DIGITAL LIBRARY OF MATHEMATICAL FUNCTIONS CCCCC IS THE NUMBER OF TRIALS UNTIL, BUT NOT INCLUDING, THE CCCCC FIRST SUCCESS. C IF(IGEODF.EQ.'DLMF')THEN C CCCCC THE FOLLOWING 3 LINES WERE ADDED MARCH 2004 IF(IH.EQ.'GEOC'.AND.IH2.EQ.'DF ')GOTO756 IF(IH.EQ.'GEOP'.AND.IH2.EQ.'DF ')GOTO757 IF(IH.EQ.'GEOP'.AND.IH2.EQ.'PF ')GOTO758 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 ELSE IF(IH.EQ.'GEOC'.AND.IH2.EQ.'DF ')GOTO751 IF(IH.EQ.'GEOP'.AND.IH2.EQ.'DF ')GOTO752 IF(IH.EQ.'GEOP'.AND.IH2.EQ.'PF ')GOTO753 ENDIF C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'HFNC'.AND.IH2.EQ.'DF ')GOTO761 IF(IH.EQ.'HFNP'.AND.IH2.EQ.'DF ')GOTO762 IF(IH.EQ.'HFNP'.AND.IH2.EQ.'PF ')GOTO763 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'LAMC'.AND.IH2.EQ.'DF ')GOTO771 IF(IH.EQ.'LAMP'.AND.IH2.EQ.'DF ')GOTO772 IF(IH.EQ.'LAMP'.AND.IH2.EQ.'PF ')GOTO773 IF(IH.EQ.'LAMS'.AND.IH2.EQ.'F ')GOTO774 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'LGNC'.AND.IH2.EQ.'DF ')GOTO781 IF(IH.EQ.'LGNP'.AND.IH2.EQ.'DF ')GOTO782 IF(IH.EQ.'LGNP'.AND.IH2.EQ.'PF ')GOTO783 IF(IH.EQ.'LGNH'.AND.IH2.EQ.'AZ ')GOTO784 IF(IH.EQ.'LGNC'.AND.IH2.EQ.'HAZ ')GOTO785 IF(IH.EQ.'LGNA'.AND.IH2.EQ.'FR ')GOTO786 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'LOGC'.AND.IH2.EQ.'DF ')GOTO791 IF(IH.EQ.'LOGP'.AND.IH2.EQ.'DF ')GOTO792 IF(IH.EQ.'LOGP'.AND.IH2.EQ.'PF ')GOTO793 IF(IH.EQ.'LOGS'.AND.IH2.EQ.'F ')GOTO794 IF(IH.EQ.'LOGH'.AND.IH2.EQ.'AZ ')GOTO795 IF(IH.EQ.'LOGC'.AND.IH2.EQ.'HAZ ')GOTO796 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'PARC'.AND.IH2.EQ.'DF ')GOTO801 IF(IH.EQ.'PARP'.AND.IH2.EQ.'DF ')GOTO802 IF(IH.EQ.'PARP'.AND.IH2.EQ.'PF ')GOTO803 IF(IH.EQ.'PARH'.AND.IH2.EQ.'AZ ')GOTO804 IF(IH.EQ.'PARC'.AND.IH2.EQ.'HAZ ')GOTO805 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1994 IF(IH.EQ.'UNIC'.AND.IH2.EQ.'DF ')GOTO811 IF(IH.EQ.'UNIP'.AND.IH2.EQ.'DF ')GOTO812 IF(IH.EQ.'UNIP'.AND.IH2.EQ.'PF ')GOTO813 IF(IH.EQ.'UNIS'.AND.IH2.EQ.'F ')GOTO814 IF(IH.EQ.'UNIH'.AND.IH2.EQ.'AZ ')GOTO815 IF(IH.EQ.'UNIC'.AND.IH2.EQ.'HAZ ')GOTO816 C CCCCC THE FOLLOWING 3 LINES WERE ADDED SEPTEMBER 1994 IF(IH.EQ.'BETC'.AND.IH2.EQ.'DF ')GOTO821 IF(IH.EQ.'BETP'.AND.IH2.EQ.'DF ')GOTO822 IF(IH.EQ.'BETP'.AND.IH2.EQ.'PF ')GOTO823 C CCCCC THE FOLLOWING 2 LINES WERE ADDED SEPTEMBER 1994 IF(IH.EQ.'NCBC'.AND.IH2.EQ.'DF ')GOTO831 IF(IH.EQ.'NCBP'.AND.IH2.EQ.'DF ')GOTO832 IF(IH.EQ.'NCBP'.AND.IH2.EQ.'PF ')GOTO833 C CCCCC THE FOLLOWING 2 LINES WERE ADDED SEPTEMBER 1994 IF(IH.EQ.'NCCC'.AND.IH2.EQ.'DF ')GOTO841 IF(IH.EQ.'NCCP'.AND.IH2.EQ.'DF ')GOTO842 IF(IH.EQ.'NCCP'.AND.IH2.EQ.'PF ')GOTO843 IF(IH.EQ.'NCCN'.AND.IH2.EQ.'CP ')GOTO844 C CCCCC THE FOLLOWING 2 LINES WERE ADDED SEPTEMBER 1994 IF(IH.EQ.'NCFC'.AND.IH2.EQ.'DF ')GOTO851 IF(IH.EQ.'NCFP'.AND.IH2.EQ.'DF ')GOTO852 IF(IH.EQ.'NCFP'.AND.IH2.EQ.'PF ')GOTO853 C CCCCC THE FOLLOWING 2 LINES WERE ADDED SEPTEMBER 1994 IF(IH.EQ.'NCTC'.AND.IH2.EQ.'DF ')GOTO861 IF(IH.EQ.'NCTP'.AND.IH2.EQ.'DF ')GOTO862 IF(IH.EQ.'NCTP'.AND.IH2.EQ.'PF ')GOTO863 C CCCCC THE FOLLOWING 3 LINES WERE ADDED SEPTEMBER 1994 IF(IH.EQ.'DISC'.AND.IH2.EQ.'DF ')GOTO871 IF(IH.EQ.'DISP'.AND.IH2.EQ.'DF ')GOTO872 IF(IH.EQ.'DISP'.AND.IH2.EQ.'PF ')GOTO873 C CCCCC THE FOLLOWING 3 LINES WERE ADDED SEPTEMBER 1994 IF(IH.EQ.'TRIC'.AND.IH2.EQ.'DF ')GOTO881 IF(IH.EQ.'TRIP'.AND.IH2.EQ.'DF ')GOTO882 IF(IH.EQ.'TRIP'.AND.IH2.EQ.'PF ')GOTO883 C CCCCC THE FOLLOWING 2 LINES WERE ADDED SEPTEMBER 1994 IF(IH.EQ.'DNTC'.AND.IH2.EQ.'DF ')GOTO891 IF(IH.EQ.'DNTP'.AND.IH2.EQ.'DF ')GOTO892 IF(IH.EQ.'DNTP'.AND.IH2.EQ.'PF ')GOTO893 C CCCCC THE FOLLOWING 2 LINES WERE ADDED SEPTEMBER 1994 IF(IH.EQ.'DNFC'.AND.IH2.EQ.'DF ')GOTO901 IF(IH.EQ.'DNFP'.AND.IH2.EQ.'DF ')GOTO902 IF(IH.EQ.'DNFP'.AND.IH2.EQ.'PF ')GOTO903 C CCCCC THE FOLLOWING 3 LINES WERE ADDED SEPTEMBER 1994 IF(IH.EQ.'HYPC'.AND.IH2.EQ.'DF ')GOTO911 IF(IH.EQ.'HYPP'.AND.IH2.EQ.'DF ')GOTO912 IF(IH.EQ.'HYPP'.AND.IH2.EQ.'PF ')GOTO913 C CCCCC THE FOLLOWING 3 LINES WERE ADDED OCTOBER 1994 IF(IH.EQ.'VONC'.AND.IH2.EQ.'DF ')GOTO921 IF(IH.EQ.'VONP'.AND.IH2.EQ.'DF ')GOTO922 IF(IH.EQ.'VONP'.AND.IH2.EQ.'PF ')GOTO923 C CCCCC THE FOLLOWING 3 LINES WERE ADDED OCTOBER 1994 IF(IH.EQ.'BVNC'.AND.IH2.EQ.'DF ')GOTO931 IF(IH.EQ.'BVNP'.AND.IH2.EQ.'DF ')GOTO932 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1995 IF(IH.EQ.'COSC'.AND.IH2.EQ.'DF ')GOTO941 IF(IH.EQ.'COSP'.AND.IH2.EQ.'DF ')GOTO942 IF(IH.EQ.'COSP'.AND.IH2.EQ.'PF ')GOTO943 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1995 IF(IH.EQ.'ALPC'.AND.IH2.EQ.'DF ')GOTO951 IF(IH.EQ.'ALPP'.AND.IH2.EQ.'DF ')GOTO952 IF(IH.EQ.'ALPP'.AND.IH2.EQ.'PF ')GOTO953 IF(IH.EQ.'ALPH'.AND.IH2.EQ.'AZ ')GOTO954 IF(IH.EQ.'ALPC'.AND.IH2.EQ.'HAZ ')GOTO955 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1995 IF(IH.EQ.'PNRC'.AND.IH2.EQ.'DF ')GOTO961 IF(IH.EQ.'PNRP'.AND.IH2.EQ.'DF ')GOTO962 IF(IH.EQ.'PNRP'.AND.IH2.EQ.'PF ')GOTO963 IF(IH.EQ.'PNRH'.AND.IH2.EQ.'AZ ')GOTO964 IF(IH.EQ.'PNRC'.AND.IH2.EQ.'HAZ ')GOTO965 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1995 IF(IH.EQ.'PLNC'.AND.IH2.EQ.'DF ')GOTO971 IF(IH.EQ.'PLNP'.AND.IH2.EQ.'DF ')GOTO972 IF(IH.EQ.'PLNP'.AND.IH2.EQ.'PF ')GOTO973 IF(IH.EQ.'PLNH'.AND.IH2.EQ.'AZ ')GOTO974 IF(IH.EQ.'PLNC'.AND.IH2.EQ.'HAZ ')GOTO975 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1995 IF(IH.EQ.'FNRC'.AND.IH2.EQ.'DF ')GOTO981 IF(IH.EQ.'FNRP'.AND.IH2.EQ.'DF ')GOTO982 IF(IH.EQ.'FNRP'.AND.IH2.EQ.'PF ')GOTO983 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1995 IF(IH.EQ.'POWC'.AND.IH2.EQ.'DF ')GOTO991 IF(IH.EQ.'POWP'.AND.IH2.EQ.'DF ')GOTO992 IF(IH.EQ.'POWP'.AND.IH2.EQ.'PF ')GOTO993 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1995 IF(IH.EQ.'TNRC'.AND.IH2.EQ.'DF ')GOTO1011 IF(IH.EQ.'TNRP'.AND.IH2.EQ.'DF ')GOTO1012 IF(IH.EQ.'TNRP'.AND.IH2.EQ.'PF ')GOTO1013 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1995 IF(IH.EQ.'CHCD'.AND.IH2.EQ.'F ')GOTO1021 IF(IH.EQ.'CHPD'.AND.IH2.EQ.'F ')GOTO1022 IF(IH.EQ.'CHPP'.AND.IH2.EQ.'F ')GOTO1023 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1995 IF(IH.EQ.'DLGC'.AND.IH2.EQ.'DF ')GOTO1031 IF(IH.EQ.'DLGP'.AND.IH2.EQ.'DF ')GOTO1032 IF(IH.EQ.'DLGP'.AND.IH2.EQ.'PF ')GOTO1033 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1995 IF(IH.EQ.'WARC'.AND.IH2.EQ.'DF ')GOTO1041 IF(IH.EQ.'WARP'.AND.IH2.EQ.'DF ')GOTO1042 IF(IH.EQ.'WARP'.AND.IH2.EQ.'PF ')GOTO1043 IF(IH.EQ.'YULC'.AND.IH2.EQ.'DF ')GOTO1046 IF(IH.EQ.'YULP'.AND.IH2.EQ.'DF ')GOTO1047 IF(IH.EQ.'YULP'.AND.IH2.EQ.'PF ')GOTO1048 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1995 IF(IH.EQ.'LLGC'.AND.IH2.EQ.'DF ')GOTO1051 IF(IH.EQ.'LLGP'.AND.IH2.EQ.'DF ')GOTO1052 IF(IH.EQ.'LLGP'.AND.IH2.EQ.'PF ')GOTO1053 C CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1995 IF(IH.EQ.'GGDC'.AND.IH2.EQ.'DF ')GOTO1061 IF(IH.EQ.'GGDP'.AND.IH2.EQ.'DF ')GOTO1062 IF(IH.EQ.'GGDP'.AND.IH2.EQ.'PF ')GOTO1063 IF(IH.EQ.'GGDH'.AND.IH2.EQ.'AZ ')GOTO1064 IF(IH.EQ.'GGDC'.AND.IH2.EQ.'HAZ ')GOTO1065 CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1998 IF(IH.EQ.'IGAC'.AND.IH2.EQ.'DF ')GOTO1066 IF(IH.EQ.'IGAP'.AND.IH2.EQ.'DF ')GOTO1067 IF(IH.EQ.'IGAP'.AND.IH2.EQ.'PF ')GOTO1068 IF(IH.EQ.'IGAH'.AND.IH2.EQ.'AZ ')GOTO1069 IF(IH.EQ.'IGAC'.AND.IH2.EQ.'HAZ ')GOTO9065 C CCCCC THE FOLLOWING 3 LINES WERE ADDED SEPTEMBER 1995 IF(IH.EQ.'ANGC'.AND.IH2.EQ.'DF ')GOTO1071 IF(IH.EQ.'ANGP'.AND.IH2.EQ.'DF ')GOTO1072 IF(IH.EQ.'ANGP'.AND.IH2.EQ.'PF ')GOTO1073 C CCCCC THE FOLLOWING 3 LINES WERE ADDED SEPTEMBER 1995 IF(IH.EQ.'ARSC'.AND.IH2.EQ.'DF ')GOTO1081 IF(IH.EQ.'ARSP'.AND.IH2.EQ.'DF ')GOTO1082 IF(IH.EQ.'ARSP'.AND.IH2.EQ.'PF ')GOTO1083 C CCCCC THE FOLLOWING 3 LINES WERE ADDED OCTOBER 1995 IF(IH.EQ.'DWEC'.AND.IH2.EQ.'DF ')GOTO1091 IF(IH.EQ.'DWEP'.AND.IH2.EQ.'DF ')GOTO1092 IF(IH.EQ.'DWEP'.AND.IH2.EQ.'PF ')GOTO1093 C CCCCC THE FOLLOWING 3 LINES WERE ADDED OCTOBER 1995 IF(IH.EQ.'LGAC'.AND.IH2.EQ.'DF ')GOTO1101 IF(IH.EQ.'LGAP'.AND.IH2.EQ.'DF ')GOTO1102 IF(IH.EQ.'LGAP'.AND.IH2.EQ.'PF ')GOTO1103 C CCCCC THE FOLLOWING 3 LINES WERE ADDED OCTOBER 1995 IF(IH.EQ.'HSEC'.AND.IH2.EQ.'DF ')GOTO1111 IF(IH.EQ.'HSEP'.AND.IH2.EQ.'DF ')GOTO1112 IF(IH.EQ.'HSEP'.AND.IH2.EQ.'PF ')GOTO1113 C CCCCC THE FOLLOWING 3 LINES WERE ADDED OCTOBER 1995 IF(IH.EQ.'HFCC'.AND.IH2.EQ.'DF ')GOTO1121 IF(IH.EQ.'HFCP'.AND.IH2.EQ.'DF ')GOTO1122 IF(IH.EQ.'HFCP'.AND.IH2.EQ.'PF ')GOTO1123 C CCCCC THE FOLLOWING 3 LINES WERE ADDED OCTOBER 1995 IF(IH.EQ.'HFLC'.AND.IH2.EQ.'DF ')GOTO1131 IF(IH.EQ.'HFLP'.AND.IH2.EQ.'DF ')GOTO1132 IF(IH.EQ.'HFLP'.AND.IH2.EQ.'PF ')GOTO1133 C CCCCC THE FOLLOWING 3 LINES WERE ADDED OCTOBER 1995 IF(IH.EQ.'GEVC'.AND.IH2.EQ.'DF ')GOTO1141 IF(IH.EQ.'GEVP'.AND.IH2.EQ.'DF ')GOTO1142 IF(IH.EQ.'GEVP'.AND.IH2.EQ.'PF ')GOTO1143 IF(IH.EQ.'GEVH'.AND.IH2.EQ.'AZ ')GOTO1144 IF(IH.EQ.'GEVC'.AND.IH2.EQ.'HAZ ')GOTO1145 C CCCCC THE FOLLOWING 3 LINES WERE ADDED OCTOBER 1995 IF(IH.EQ.'GOMC'.AND.IH2.EQ.'DF ')GOTO1151 IF(IH.EQ.'GOMP'.AND.IH2.EQ.'DF ')GOTO1152 IF(IH.EQ.'GOMP'.AND.IH2.EQ.'PF ')GOTO1153 C CCCCC THE FOLLOWING 3 LINES WERE ADDED OCTOBER 1995 IF(IH.EQ.'PA2C'.AND.IH2.EQ.'DF ')GOTO1161 IF(IH.EQ.'PA2P'.AND.IH2.EQ.'DF ')GOTO1162 IF(IH.EQ.'PA2P'.AND.IH2.EQ.'PF ')GOTO1163 C CCCCC THE FOLLOWING 3 LINES WERE ADDED OCTOBER 1995 IF(IH.EQ.'WCAC'.AND.IH2.EQ.'DF ')GOTO1171 IF(IH.EQ.'WCAP'.AND.IH2.EQ.'DF ')GOTO1172 IF(IH.EQ.'WCAP'.AND.IH2.EQ.'PF ')GOTO1173 C CCCCC THE FOLLOWING 3 LINES WERE ADDED OCTOBER 1995 IF(IH.EQ.'EWEC'.AND.IH2.EQ.'DF ')GOTO1181 IF(IH.EQ.'EWEP'.AND.IH2.EQ.'DF ')GOTO1182 IF(IH.EQ.'EWEP'.AND.IH2.EQ.'PF ')GOTO1183 IF(IH.EQ.'EWEH'.AND.IH2.EQ.'AZ ')GOTO1184 IF(IH.EQ.'EWEC'.AND.IH2.EQ.'HAZ ')GOTO1185 C CCCCC THE FOLLOWING 5 LINES WERE ADDED OCTOBER 1995 IF(IH.EQ.'TNEC'.AND.IH2.EQ.'DF ')GOTO1191 IF(IH.EQ.'TNEP'.AND.IH2.EQ.'DF ')GOTO1192 IF(IH.EQ.'TNEP'.AND.IH2.EQ.'PF ')GOTO1193 C CCCCC THE FOLLOWING 5 LINES WERE ADDED DECEMBER 1995 IF(IH.EQ.'GLOC'.AND.IH2.EQ.'DF ')GOTO1201 IF(IH.EQ.'GLOP'.AND.IH2.EQ.'DF ')GOTO1202 IF(IH.EQ.'GLOP'.AND.IH2.EQ.'PF ')GOTO1203 C CCCCC THE FOLLOWING 5 LINES WERE ADDED DECEMBER 1995 IF(IH.EQ.'PEXC'.AND.IH2.EQ.'DF ')GOTO1211 IF(IH.EQ.'PEXP'.AND.IH2.EQ.'DF ')GOTO1212 IF(IH.EQ.'PEXP'.AND.IH2.EQ.'PF ')GOTO1213 IF(IH.EQ.'PEXH'.AND.IH2.EQ.'AZ ')GOTO1214 IF(IH.EQ.'PEXC'.AND.IH2.EQ.'HAZ ')GOTO1215 C CCCCC THE FOLLOWING 5 LINES WERE ADDED DECEMBER 1995 IF(IH.EQ.'DGAC'.AND.IH2.EQ.'DF ')GOTO1221 IF(IH.EQ.'DGAP'.AND.IH2.EQ.'DF ')GOTO1222 IF(IH.EQ.'DGAP'.AND.IH2.EQ.'PF ')GOTO1223 C CCCCC THE FOLLOWING 5 LINES WERE ADDED DECEMBER 1995 IF(IH.EQ.'KAPC'.AND.IH2.EQ.'DF ')GOTO1231 IF(IH.EQ.'KAPP'.AND.IH2.EQ.'DF ')GOTO1232 IF(IH.EQ.'KAPP'.AND.IH2.EQ.'PF ')GOTO1233 C CCCCC THE FOLLOWING 5 LINES WERE ADDED DECEMBER 1995 IF(IH.EQ.'FCAC'.AND.IH2.EQ.'DF ')GOTO1241 IF(IH.EQ.'FCAP'.AND.IH2.EQ.'DF ')GOTO1242 IF(IH.EQ.'FCAP'.AND.IH2.EQ.'PF ')GOTO1243 C CCCCC THE FOLLOWING 5 LINES WERE ADDED FEBRUARY 1996 IF(IH.EQ.'BBNC'.AND.IH2.EQ.'DF ')GOTO1251 IF(IH.EQ.'BBNP'.AND.IH2.EQ.'DF ')GOTO1252 IF(IH.EQ.'BBNP'.AND.IH2.EQ.'PF ')GOTO1253 C CCCCC THE FOLLOWING 5 LINES WERE ADDED MARCH 2004 IF(IH.EQ.'POLC'.AND.IH2.EQ.'DF ')GOTO1256 IF(IH.EQ.'POLP'.AND.IH2.EQ.'DF ')GOTO1257 IF(IH.EQ.'POLP'.AND.IH2.EQ.'PF ')GOTO1258 C CCCCC THE FOLLOWING 5 LINES WERE ADDED FEBRUARY 1996 IF(IH.EQ.'BRAC'.AND.IH2.EQ.'DF ')GOTO1261 IF(IH.EQ.'BRAP'.AND.IH2.EQ.'DF ')GOTO1262 IF(IH.EQ.'BRAP'.AND.IH2.EQ.'PF ')GOTO1263 C CCCCC THE FOLLOWING 5 LINES WERE ADDED FEBRUARY 1996 IF(IH.EQ.'GEXC'.AND.IH2.EQ.'DF ')GOTO1271 IF(IH.EQ.'GEXP'.AND.IH2.EQ.'DF ')GOTO1272 IF(IH.EQ.'GEXP'.AND.IH2.EQ.'PF ')GOTO1273 C CCCCC THE FOLLOWING 5 LINES WERE ADDED MAY 1996 IF(IH.EQ.'RECC'.AND.IH2.EQ.'DF ')GOTO1281 IF(IH.EQ.'RECP'.AND.IH2.EQ.'DF ')GOTO1282 IF(IH.EQ.'RECP'.AND.IH2.EQ.'PF ')GOTO1283 C CCCCC THE FOLLOWING 5 LINES WERE ADDED MAY 1996 IF(IH.EQ.'SRAC'.AND.IH2.EQ.'DF ')GOTO1291 CCCCC IF(IH.EQ.'SRAP'.AND.IH2.EQ.'DF ')GOTO1292 IF(IH.EQ.'SRAP'.AND.IH2.EQ.'PF ')GOTO1293 C CCCCC THE FOLLOWING 7 LINES WERE ADDED SEPTEMBER 2001 IF(IH.EQ.'GLDC'.AND.IH2.EQ.'DF ')GOTO1301 IF(IH.EQ.'GLDP'.AND.IH2.EQ.'DF ')GOTO1302 IF(IH.EQ.'GLDP'.AND.IH2.EQ.'PF ')GOTO1303 CCCCC IF(IH.EQ.'GLDC'.AND.IH2.EQ.'HK ')GOTO1304 IF(IH.EQ.'GLDL'.AND.IH2.EQ.'LM ')GOTO1305 IF(IH.EQ.'GLDU'.AND.IH2.EQ.'LM ')GOTO1306 CCCCC IF(IH.EQ.'GLDS'.AND.IH2.EQ.'GN ')GOTO1307 C CCCCC THE FOLLOWING SECTION WAS ADDED SEPTEMBER 2001 IF(IH.EQ.'LDEC'.AND.IH2.EQ.'DF ')GOTO1321 IF(IH.EQ.'LDEP'.AND.IH2.EQ.'DF ')GOTO1322 IF(IH.EQ.'LDEP'.AND.IH2.EQ.'PF ')GOTO1323 IF(IH.EQ.'IWEC'.AND.IH2.EQ.'DF ')GOTO1331 IF(IH.EQ.'IWEP'.AND.IH2.EQ.'DF ')GOTO1332 IF(IH.EQ.'IWEP'.AND.IH2.EQ.'PF ')GOTO1333 IF(IH.EQ.'IWEH'.AND.IH2.EQ.'AZ ')GOTO1334 IF(IH.EQ.'IWEC'.AND.IH2.EQ.'HAZ ')GOTO1335 IF(IH.EQ.'JSBC'.AND.IH2.EQ.'DF ')GOTO1341 IF(IH.EQ.'JSBP'.AND.IH2.EQ.'DF ')GOTO1342 IF(IH.EQ.'JSBP'.AND.IH2.EQ.'PF ')GOTO1343 IF(IH.EQ.'JSUC'.AND.IH2.EQ.'DF ')GOTO1351 IF(IH.EQ.'JSUP'.AND.IH2.EQ.'DF ')GOTO1352 IF(IH.EQ.'JSUP'.AND.IH2.EQ.'PF ')GOTO1353 IF(IH.EQ.'GEEC'.AND.IH2.EQ.'DF ')GOTO1361 IF(IH.EQ.'GEEP'.AND.IH2.EQ.'DF ')GOTO1362 IF(IH.EQ.'GEEP'.AND.IH2.EQ.'PF ')GOTO1363 IF(IH.EQ.'GEEH'.AND.IH2.EQ.'AZ ')GOTO1364 IF(IH.EQ.'GEEC'.AND.IH2.EQ.'HAZ ')GOTO1365 IF(IH.EQ.'TSPC'.AND.IH2.EQ.'DF ')GOTO1371 IF(IH.EQ.'TSPP'.AND.IH2.EQ.'DF ')GOTO1372 IF(IH.EQ.'TSPP'.AND.IH2.EQ.'PF ')GOTO1373 IF(IH.EQ.'BWEC'.AND.IH2.EQ.'DF ')GOTO1381 IF(IH.EQ.'BWEP'.AND.IH2.EQ.'DF ')GOTO1382 IF(IH.EQ.'BWEP'.AND.IH2.EQ.'PF ')GOTO1383 IF(IH.EQ.'BWEH'.AND.IH2.EQ.'AZ ')GOTO1384 IF(IH.EQ.'BWEC'.AND.IH2.EQ.'HAZ ')GOTO1385 IF(IH.EQ.'GHCD'.AND.IH2.EQ.'F ')GOTO1391 IF(IH.EQ.'GHPD'.AND.IH2.EQ.'F ')GOTO1392 IF(IH.EQ.'GHPP'.AND.IH2.EQ.'F ')GOTO1393 IF(IH.EQ.'SLAC'.AND.IH2.EQ.'DF ')GOTO1401 IF(IH.EQ.'SLAP'.AND.IH2.EQ.'DF ')GOTO1402 IF(IH.EQ.'SLAP'.AND.IH2.EQ.'PF ')GOTO1403 IF(IH.EQ.'LANC'.AND.IH2.EQ.'DF ')GOTO1411 IF(IH.EQ.'LANP'.AND.IH2.EQ.'DF ')GOTO1412 IF(IH.EQ.'LANP'.AND.IH2.EQ.'PF ')GOTO1413 IF(IH.EQ.'LANX'.AND.IH2.EQ.'M1 ')GOTO1414 IF(IH.EQ.'LANX'.AND.IH2.EQ.'M2 ')GOTO1415 IF(IH.EQ.'LAND'.AND.IH2.EQ.'IF ')GOTO1416 IF(IH.EQ.'IBCD'.AND.IH2.EQ.'F ')GOTO1421 IF(IH.EQ.'IBPD'.AND.IH2.EQ.'F ')GOTO1422 IF(IH.EQ.'IBPP'.AND.IH2.EQ.'F ')GOTO1423 IF(IH.EQ.'ERRC'.AND.IH2.EQ.'DF ')GOTO1431 IF(IH.EQ.'ERRP'.AND.IH2.EQ.'DF ')GOTO1432 IF(IH.EQ.'ERRP'.AND.IH2.EQ.'PF ')GOTO1433 IF(IH.EQ.'TRAC'.AND.IH2.EQ.'DF ')GOTO1441 IF(IH.EQ.'TRAP'.AND.IH2.EQ.'DF ')GOTO1442 IF(IH.EQ.'TRAP'.AND.IH2.EQ.'PF ')GOTO1443 IF(IH.EQ.'GTRC'.AND.IH2.EQ.'DF ')GOTO1451 IF(IH.EQ.'GTRP'.AND.IH2.EQ.'DF ')GOTO1452 IF(IH.EQ.'GTRP'.AND.IH2.EQ.'PF ')GOTO1453 IF(IH.EQ.'FTCD'.AND.IH2.EQ.'F ')GOTO1461 IF(IH.EQ.'FTPD'.AND.IH2.EQ.'F ')GOTO1462 IF(IH.EQ.'FTPP'.AND.IH2.EQ.'F ')GOTO1463 IF(IH.EQ.'SNCD'.AND.IH2.EQ.'F ')GOTO1471 IF(IH.EQ.'SNPD'.AND.IH2.EQ.'F ')GOTO1472 IF(IH.EQ.'SNPP'.AND.IH2.EQ.'F ')GOTO1473 IF(IH.EQ.'STCD'.AND.IH2.EQ.'F ')GOTO1481 IF(IH.EQ.'STPD'.AND.IH2.EQ.'F ')GOTO1482 IF(IH.EQ.'STPP'.AND.IH2.EQ.'F ')GOTO1483 IF(IH.EQ.'ZETC'.AND.IH2.EQ.'DF ')GOTO1491 IF(IH.EQ.'ZETP'.AND.IH2.EQ.'DF ')GOTO1492 IF(IH.EQ.'ZETP'.AND.IH2.EQ.'PF ')GOTO1493 IF(IMAKDF.EQ.'DLMF' .OR. IMAKDF.EQ.'MEEK')THEN IF(IH.EQ.'MAKC'.AND.IH2.EQ.'DF ')GOTO1501 IF(IH.EQ.'MAKP'.AND.IH2.EQ.'DF ')GOTO1502 IF(IH.EQ.'MAKP'.AND.IH2.EQ.'PF ')GOTO1503 IF(IH.EQ.'MAKH'.AND.IH2.EQ.'AZ ')GOTO1504 IF(IH.EQ.'MAKC'.AND.IH2.EQ.'HAZ ')GOTO1505 ELSEIF(IMAKDF.EQ.'REPA')THEN IF(IH.EQ.'MAKC'.AND.IH2.EQ.'DF ')GOTO1506 IF(IH.EQ.'MAKP'.AND.IH2.EQ.'DF ')GOTO1507 IF(IH.EQ.'MAKP'.AND.IH2.EQ.'PF ')GOTO1508 IF(IH.EQ.'MAKH'.AND.IH2.EQ.'AZ ')GOTO1509 IF(IH.EQ.'MAKC'.AND.IH2.EQ.'HAZ ')GOTO1510 ENDIF IF(IH.EQ.'LSNC'.AND.IH2.EQ.'DF ')GOTO1511 IF(IH.EQ.'LSNP'.AND.IH2.EQ.'DF ')GOTO1512 IF(IH.EQ.'LSNP'.AND.IH2.EQ.'PF ')GOTO1513 IF(IH.EQ.'LSTC'.AND.IH2.EQ.'DF ')GOTO1521 IF(IH.EQ.'LSTP'.AND.IH2.EQ.'DF ')GOTO1522 IF(IH.EQ.'LSTP'.AND.IH2.EQ.'PF ')GOTO1523 IF(IH.EQ.'HERC'.AND.IH2.EQ.'DF ')GOTO1531 IF(IH.EQ.'HERP'.AND.IH2.EQ.'DF ')GOTO1532 IF(IH.EQ.'HERP'.AND.IH2.EQ.'PF ')GOTO1533 IF(IH.EQ.'GWAC'.AND.IH2.EQ.'DF ')GOTO1541 IF(IH.EQ.'GWAP'.AND.IH2.EQ.'DF ')GOTO1542 IF(IH.EQ.'GWAP'.AND.IH2.EQ.'PF ')GOTO1543 IF(IH.EQ.'BNBC'.AND.IH2.EQ.'DF ')GOTO1541 IF(IH.EQ.'BNBP'.AND.IH2.EQ.'DF ')GOTO1542 IF(IH.EQ.'BNBP'.AND.IH2.EQ.'PF ')GOTO1543 IF(IH.EQ.'SDEC'.AND.IH2.EQ.'DF ')GOTO1551 IF(IH.EQ.'SDEP'.AND.IH2.EQ.'DF ')GOTO1552 IF(IH.EQ.'SDEP'.AND.IH2.EQ.'PF ')GOTO1553 IF(IH.EQ.'ADEC'.AND.IH2.EQ.'DF ')GOTO1561 IF(IH.EQ.'ADEP'.AND.IH2.EQ.'DF ')GOTO1562 IF(IH.EQ.'ADEP'.AND.IH2.EQ.'PF ')GOTO1563 IF(IH.EQ.'GALC'.AND.IH2.EQ.'DF ')GOTO1571 IF(IH.EQ.'GALP'.AND.IH2.EQ.'DF ')GOTO1572 IF(IH.EQ.'GALP'.AND.IH2.EQ.'PF ')GOTO1573 IF(IH.EQ.'MAXC'.AND.IH2.EQ.'DF ')GOTO1581 IF(IH.EQ.'MAXP'.AND.IH2.EQ.'DF ')GOTO1582 IF(IH.EQ.'MAXP'.AND.IH2.EQ.'PF ')GOTO1583 IF(IH.EQ.'FERC'.AND.IH2.EQ.'DF ')GOTO1591 IF(IH.EQ.'FERP'.AND.IH2.EQ.'DF ')GOTO1592 IF(IH.EQ.'FERP'.AND.IH2.EQ.'PF ')GOTO1593 IF(IH.EQ.'RAYC'.AND.IH2.EQ.'DF ')GOTO1601 IF(IH.EQ.'RAYP'.AND.IH2.EQ.'DF ')GOTO1602 IF(IH.EQ.'RAYP'.AND.IH2.EQ.'PF ')GOTO1603 IF(IH.EQ.'GIGC'.AND.IH2.EQ.'DF ')GOTO1611 IF(IH.EQ.'GIGP'.AND.IH2.EQ.'DF ')GOTO1612 IF(IH.EQ.'GIGP'.AND.IH2.EQ.'PF ')GOTO1613 IF(IH.EQ.'BEIC'.AND.IH2.EQ.'DF ')GOTO1621 IF(IH.EQ.'BEIP'.AND.IH2.EQ.'DF ')GOTO1622 IF(IH.EQ.'BEIP'.AND.IH2.EQ.'PF ')GOTO1623 IF(IH.EQ.'BEKC'.AND.IH2.EQ.'DF ')GOTO1631 IF(IH.EQ.'BEKP'.AND.IH2.EQ.'DF ')GOTO1632 IF(IH.EQ.'BEKP'.AND.IH2.EQ.'PF ')GOTO1633 IF(IH.EQ.'MCLC'.AND.IH2.EQ.'DF ')GOTO1641 IF(IH.EQ.'MCLP'.AND.IH2.EQ.'DF ')GOTO1642 IF(IH.EQ.'MCLP'.AND.IH2.EQ.'PF ')GOTO1643 IF(IH.EQ.'GMCC'.AND.IH2.EQ.'DF ')GOTO1651 IF(IH.EQ.'GMCP'.AND.IH2.EQ.'DF ')GOTO1652 IF(IH.EQ.'GMCP'.AND.IH2.EQ.'PF ')GOTO1653 IF(IH.EQ.'HBOC'.AND.IH2.EQ.'DF ')GOTO1661 IF(IH.EQ.'HBOP'.AND.IH2.EQ.'DF ')GOTO1662 IF(IH.EQ.'HBOP'.AND.IH2.EQ.'PF ')GOTO1663 IF(IH.EQ.'GL5C'.AND.IH2.EQ.'DF ')GOTO1671 IF(IH.EQ.'GL5P'.AND.IH2.EQ.'DF ')GOTO1672 IF(IH.EQ.'GL5P'.AND.IH2.EQ.'PF ')GOTO1673 IF(IH.EQ.'WAKC'.AND.IH2.EQ.'DF ')GOTO1681 IF(IH.EQ.'WAKP'.AND.IH2.EQ.'DF ')GOTO1682 IF(IH.EQ.'WAKP'.AND.IH2.EQ.'PF ')GOTO1683 IF(IH.EQ.'BNOC'.AND.IH2.EQ.'DF ')GOTO1691 IF(IH.EQ.'BNOP'.AND.IH2.EQ.'DF ')GOTO1692 IF(IH.EQ.'BNOP'.AND.IH2.EQ.'PF ')GOTO1693 IF(IH.EQ.'GL2C'.AND.IH2.EQ.'DF ')GOTO1701 IF(IH.EQ.'GL2P'.AND.IH2.EQ.'DF ')GOTO1702 IF(IH.EQ.'GL2P'.AND.IH2.EQ.'PF ')GOTO1703 IF(IH.EQ.'GL3C'.AND.IH2.EQ.'DF ')GOTO1711 IF(IH.EQ.'GL3P'.AND.IH2.EQ.'DF ')GOTO1712 IF(IH.EQ.'GL3P'.AND.IH2.EQ.'PF ')GOTO1713 IF(IH.EQ.'GL4C'.AND.IH2.EQ.'DF ')GOTO1721 IF(IH.EQ.'GL4P'.AND.IH2.EQ.'DF ')GOTO1722 IF(IH.EQ.'GL4P'.AND.IH2.EQ.'PF ')GOTO1723 IF(IH.EQ.'ALDC'.AND.IH2.EQ.'DF ')GOTO1731 IF(IH.EQ.'ALDP'.AND.IH2.EQ.'DF ')GOTO1732 IF(IH.EQ.'ALDP'.AND.IH2.EQ.'PF ')GOTO1733 IF(IH.EQ.'BGEC'.AND.IH2.EQ.'DF ')GOTO1741 IF(IH.EQ.'BGEP'.AND.IH2.EQ.'DF ')GOTO1742 IF(IH.EQ.'BGEP'.AND.IH2.EQ.'PF ')GOTO1743 IF(IH.EQ.'ZIPC'.AND.IH2.EQ.'DF ')GOTO1751 IF(IH.EQ.'ZIPP'.AND.IH2.EQ.'DF ')GOTO1752 IF(IH.EQ.'ZIPP'.AND.IH2.EQ.'PF ')GOTO1753 IF(IH.EQ.'BTAC'.AND.IH2.EQ.'DF ')GOTO1761 IF(IH.EQ.'BTAP'.AND.IH2.EQ.'DF ')GOTO1762 IF(IH.EQ.'BTAP'.AND.IH2.EQ.'PF ')GOTO1763 IF(IH.EQ.'LBEC'.AND.IH2.EQ.'DF ')GOTO1771 IF(IH.EQ.'LBEP'.AND.IH2.EQ.'DF ')GOTO1772 IF(IH.EQ.'LBEP'.AND.IH2.EQ.'PF ')GOTO1773 IF(IH.EQ.'LPOC'.AND.IH2.EQ.'DF ')GOTO1781 IF(IH.EQ.'LPOP'.AND.IH2.EQ.'DF ')GOTO1782 IF(IH.EQ.'LPOP'.AND.IH2.EQ.'PF ')GOTO1783 IF(IH.EQ.'LCTC'.AND.IH2.EQ.'DF ')GOTO1791 IF(IH.EQ.'LCTP'.AND.IH2.EQ.'DF ')GOTO1792 IF(IH.EQ.'LCTP'.AND.IH2.EQ.'PF ')GOTO1793 IF(IH.EQ.'MATC'.AND.IH2.EQ.'DF ')GOTO1801 IF(IH.EQ.'MATP'.AND.IH2.EQ.'DF ')GOTO1802 IF(IH.EQ.'MATP'.AND.IH2.EQ.'PF ')GOTO1803 IF(IH.EQ.'OCCC'.AND.IH2.EQ.'DF ')GOTO1811 IF(IH.EQ.'OCCP'.AND.IH2.EQ.'DF ')GOTO1812 IF(IH.EQ.'OCCP'.AND.IH2.EQ.'PF ')GOTO1813 IF(IH.EQ.'PAPC'.AND.IH2.EQ.'DF ')GOTO1821 IF(IH.EQ.'PAPP'.AND.IH2.EQ.'DF ')GOTO1822 IF(IH.EQ.'PAPP'.AND.IH2.EQ.'PF ')GOTO1823 IF(IH.EQ.'NEYC'.AND.IH2.EQ.'DF ')GOTO1831 IF(IH.EQ.'NEYP'.AND.IH2.EQ.'DF ')GOTO1832 IF(IH.EQ.'NEYP'.AND.IH2.EQ.'PF ')GOTO1833 IF(IH.EQ.'DXGC'.AND.IH2.EQ.'DF ')GOTO1841 IF(IH.EQ.'DXGP'.AND.IH2.EQ.'DF ')GOTO1842 IF(IH.EQ.'DXGP'.AND.IH2.EQ.'PF ')GOTO1843 IF(IH.EQ.'LOSC'.AND.IH2.EQ.'DF ')GOTO1851 IF(IH.EQ.'LOSP'.AND.IH2.EQ.'DF ')GOTO1852 IF(IH.EQ.'LOSP'.AND.IH2.EQ.'PF ')GOTO1853 IF(IH.EQ.'GLSC'.AND.IH2.EQ.'DF ')GOTO1861 IF(IH.EQ.'GLSP'.AND.IH2.EQ.'DF ')GOTO1862 IF(IH.EQ.'GLSP'.AND.IH2.EQ.'PF ')GOTO1863 IF(IH.EQ.'GETC'.AND.IH2.EQ.'DF ')GOTO1871 IF(IH.EQ.'GETP'.AND.IH2.EQ.'DF ')GOTO1872 IF(IH.EQ.'GETP'.AND.IH2.EQ.'PF ')GOTO1873 IF(IH.EQ.'GNBC'.AND.IH2.EQ.'DF ')GOTO1881 IF(IH.EQ.'GNBP'.AND.IH2.EQ.'DF ')GOTO1882 IF(IH.EQ.'GNBP'.AND.IH2.EQ.'PF ')GOTO1883 IF(IH.EQ.'PIGC'.AND.IH2.EQ.'DF ')GOTO1891 IF(IH.EQ.'PIGP'.AND.IH2.EQ.'DF ')GOTO1892 IF(IH.EQ.'PIGP'.AND.IH2.EQ.'PF ')GOTO1893 IF(IH.EQ.'QBIC'.AND.IH2.EQ.'DF ')GOTO1901 IF(IH.EQ.'QBIP'.AND.IH2.EQ.'DF ')GOTO1902 IF(IH.EQ.'QBIP'.AND.IH2.EQ.'PF ')GOTO1903 IF(IH.EQ.'CONC'.AND.IH2.EQ.'DF ')GOTO1911 IF(IH.EQ.'CONP'.AND.IH2.EQ.'DF ')GOTO1912 IF(IH.EQ.'CONP'.AND.IH2.EQ.'PF ')GOTO1913 IF(IH.EQ.'LKCD'.AND.IH2.EQ.'F ')GOTO1921 IF(IH.EQ.'LKPD'.AND.IH2.EQ.'F ')GOTO1922 IF(IH.EQ.'LKPP'.AND.IH2.EQ.'F ')GOTO1923 IF(IH.EQ.'KATC'.AND.IH2.EQ.'DF ')GOTO1931 IF(IH.EQ.'KATP'.AND.IH2.EQ.'DF ')GOTO1932 IF(IH.EQ.'KATP'.AND.IH2.EQ.'PF ')GOTO1933 IF(IH.EQ.'DIWC'.AND.IH2.EQ.'DF ')GOTO1941 IF(IH.EQ.'DIWP'.AND.IH2.EQ.'DF ')GOTO1942 IF(IH.EQ.'DIWP'.AND.IH2.EQ.'PF ')GOTO1943 IF(IH.EQ.'DIWH'.AND.IH2.EQ.'AZ ')GOTO1944 IF(IH.EQ.'GLGC'.AND.IH2.EQ.'DF ')GOTO1951 IF(IH.EQ.'GLGP'.AND.IH2.EQ.'DF ')GOTO1952 IF(IH.EQ.'GLGP'.AND.IH2.EQ.'PF ')GOTO1953 C CCCCC THE FOLLOWING LINES WERE ADDED NOVEMBER 1994 IF(IH.EQ.'FRES'.AND.IH2.EQ.'NC ')GOTO2000 IF(IH.EQ.'FRES'.AND.IH2.EQ.'NS ')GOTO2010 IF(IH.EQ.'FRES'.AND.IH2.EQ.'NF ')GOTO2020 IF(IH.EQ.'FRES'.AND.IH2.EQ.'NG ')GOTO2030 IF(IH.EQ.'PEQ '.AND.IH2.EQ.' ')GOTO2100 IF(IH.EQ.'PEQI'.AND.IH2.EQ.' ')GOTO2105 IF(IH.EQ.'PEQ1'.AND.IH2.EQ.' ')GOTO2110 IF(IH.EQ.'PEQ1'.AND.IH2.EQ.'I ')GOTO2115 IF(IH.EQ.'PLEM'.AND.IH2.EQ.' ')GOTO2120 IF(IH.EQ.'PLEM'.AND.IH2.EQ.'I ')GOTO2125 IF(IH.EQ.'PLEM'.AND.IH2.EQ.'1 ')GOTO2130 IF(IH.EQ.'PLEM'.AND.IH2.EQ.'1I ')GOTO2135 IF(IH.EQ.'SN '.AND.IH2.EQ.' ')GOTO2200 IF(IH.EQ.'CN '.AND.IH2.EQ.' ')GOTO2210 IF(IH.EQ.'DN '.AND.IH2.EQ.' ')GOTO2220 C IF(IH.EQ.'CHEB'.AND.IH2.EQ.'0 ')GOTO5000 IF(IH.EQ.'CHEB'.AND.IH2.EQ.'1 ')GOTO5010 IF(IH.EQ.'CHEB'.AND.IH2.EQ.'2 ')GOTO5020 IF(IH.EQ.'CHEB'.AND.IH2.EQ.'3 ')GOTO5030 IF(IH.EQ.'CHEB'.AND.IH2.EQ.'4 ')GOTO5040 IF(IH.EQ.'CHEB'.AND.IH2.EQ.'5 ')GOTO5050 IF(IH.EQ.'CHEB'.AND.IH2.EQ.'6 ')GOTO5060 IF(IH.EQ.'CHEB'.AND.IH2.EQ.'7 ')GOTO5070 IF(IH.EQ.'CHEB'.AND.IH2.EQ.'8 ')GOTO5080 IF(IH.EQ.'CHEB'.AND.IH2.EQ.'9 ')GOTO5090 IF(IH.EQ.'CHEB'.AND.IH2.EQ.'10 ')GOTO5100 CCCCC THE FOLLOWING SECTION ADDED JULY 1995 IF(IH.EQ.'CHEB'.AND.IH2.EQ.'T ')GOTO5110 IF(IH.EQ.'CHEB'.AND.IH2.EQ.'U ')GOTO5120 IF(IH.EQ.'NRML'.AND.IH2.EQ.'AG ')GOTO5130 IF(IH.EQ.'JACO'.AND.IH2.EQ.'BIP ')GOTO5140 IF(IH.EQ.'ULTR'.AND.IH2.EQ.'ASPH')GOTO5150 IF(IH.EQ.'LAGU'.AND.IH2.EQ.'ERRL')GOTO5160 CCCCC IF(IH.EQ.'NRML'.AND.IH2.EQ.'AGL ')GOTO5170 IF(IH.EQ.'NRML'.AND.IH2.EQ.'EG ')THEN IF(SAVE2.LT.0.)GOTO5180 IF(SAVE2.GE.0.)GOTO5200 ENDIF IF(IH.EQ.'LEGP'.AND.IH2.EQ.' ')THEN IF(SAVE2.NE.-99.9)GOTO5220 IF(SAVE2.EQ.-99.9)GOTO5220 ENDIF IF(IH.EQ.'LEGQ'.AND.IH2.EQ.' ')THEN IF(SAVE2.NE.-99.9)GOTO5240 IF(SAVE2.EQ.-99.9)GOTO5240 ENDIF IF(IH.EQ.'SPHR'.AND.IH2.EQ.'HRMR')THEN ISJUNK=0 GOTO5300 ENDIF IF(IH.EQ.'SPHR'.AND.IH2.EQ.'HRMC')THEN ISJUNK=1 GOTO5300 ENDIF C IF(IH.EQ.'BESS'.AND.IH2.EQ.'0 ')GOTO6000 IF(IH.EQ.'BESS'.AND.IH2.EQ.'1 ')GOTO6010 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 1994. IF(IH.EQ.'BESS'.AND.IH2.EQ.'J0 ')GOTO6000 IF(IH.EQ.'BESS'.AND.IH2.EQ.'J1 ')GOTO6010 IF(IH.EQ.'BESS'.AND.IH2.EQ.'Y0 ')GOTO6100 IF(IH.EQ.'BESS'.AND.IH2.EQ.'Y1 ')GOTO6150 IF(IH.EQ.'BESS'.AND.IH2.EQ.'I0 ')GOTO6200 IF(IH.EQ.'BESS'.AND.IH2.EQ.'I0E ')GOTO6230 IF(IH.EQ.'BESS'.AND.IH2.EQ.'I1 ')GOTO6250 IF(IH.EQ.'BESS'.AND.IH2.EQ.'I1E ')GOTO6280 IF(IH.EQ.'BESS'.AND.IH2.EQ.'K0 ')GOTO6300 IF(IH.EQ.'BESS'.AND.IH2.EQ.'K0E ')GOTO6330 IF(IH.EQ.'BESS'.AND.IH2.EQ.'K1 ')GOTO6350 IF(IH.EQ.'BESS'.AND.IH2.EQ.'K1E ')GOTO6380 IF(IH.EQ.'BESS'.AND.IH2.EQ.'JN ')GOTO6400 IF(IH.EQ.'BESS'.AND.IH2.EQ.'YN ')GOTO6500 IF(IH.EQ.'BESS'.AND.IH2.EQ.'IN ')GOTO6600 IF(IH.EQ.'BESS'.AND.IH2.EQ.'INE ')GOTO6650 IF(IH.EQ.'BESS'.AND.IH2.EQ.'KN ')GOTO6700 IF(IH.EQ.'BESS'.AND.IH2.EQ.'KNE ')GOTO6750 IF(IH.EQ.'AIRY'.AND.IH2.EQ.' ')GOTO6800 IF(IH.EQ.'BAIR'.AND.IH2.EQ.'Y ')GOTO6900 CCCCC FOLLOWING SECTION ADDED OCTOBER, 1994. IF(IH.EQ.'CBES'.AND.IH2.EQ.'SJR ')GOTO7000 IF(IH.EQ.'CBES'.AND.IH2.EQ.'SJI ')GOTO7010 IF(IH.EQ.'CBES'.AND.IH2.EQ.'SYR ')GOTO7020 IF(IH.EQ.'CBES'.AND.IH2.EQ.'SYI ')GOTO7030 IF(IH.EQ.'CBES'.AND.IH2.EQ.'SIR ')GOTO7040 IF(IH.EQ.'CBES'.AND.IH2.EQ.'SII ')GOTO7050 IF(IH.EQ.'CBES'.AND.IH2.EQ.'SKR ')GOTO7060 IF(IH.EQ.'CBES'.AND.IH2.EQ.'SKI ')GOTO7070 C CCCCC THE FOLLOWING 4 LINES WERE ADDED MAY 1989 IF(IH.EQ.'CP '.AND.IH2.EQ.' ')GOTO7100 IF(IH.EQ.'CPK '.AND.IH2.EQ.' ')GOTO7200 IF(IH.EQ.'PERD'.AND.IH2.EQ.'EF ')GOTO7300 IF(IH.EQ.'EXPL'.AND.IH2.EQ.'OS ')GOTO7400 C CCCCC THE FOLLOWING SECTION ADDED SEPTEMBER 1994 IF(IH.EQ.'DAWS'.AND.IH2.EQ.'ON ')GOTO7500 IF(IH.EQ.'EXPI'.AND.IH2.EQ.'NT1 ')GOTO7600 IF(IH.EQ.'EXPI'.AND.IH2.EQ.'NTE ')GOTO7650 IF(IH.EQ.'EXPI'.AND.IH2.EQ.'NTN ')GOTO7700 IF(IH.EQ.'RC '.AND.IH2.EQ.' ')GOTO7800 IF(IH.EQ.'RD '.AND.IH2.EQ.' ')GOTO7810 IF(IH.EQ.'ELLI'.AND.IH2.EQ.'PC2 ')GOTO7815 IF(IH.EQ.'ELLI'.AND.IH2.EQ.'P2 ')GOTO7818 IF(IH.EQ.'RF '.AND.IH2.EQ.' ')GOTO7820 IF(IH.EQ.'ELLI'.AND.IH2.EQ.'PC1 ')GOTO7825 IF(IH.EQ.'ELLI'.AND.IH2.EQ.'P1 ')GOTO7828 IF(IH.EQ.'RJ '.AND.IH2.EQ.' ')GOTO7830 IF(IH.EQ.'ELLI'.AND.IH2.EQ.'P3 ')GOTO7838 IF(IH.EQ.'SPEN'.AND.IH2.EQ.'CE ')GOTO7900 IF(IH.EQ.'LOGI'.AND.IH2.EQ.'NT ')GOTO8000 IF(IH.EQ.'SINI'.AND.IH2.EQ.'NT ')GOTO8100 IF(IH.EQ.'SINH'.AND.IH2.EQ.'INT ')GOTO8200 IF(IH.EQ.'COSI'.AND.IH2.EQ.'NT ')GOTO8300 IF(IH.EQ.'COSH'.AND.IH2.EQ.'INT ')GOTO8400 IF(IH.EQ.'CABS'.AND.IH2.EQ.' ')GOTO8500 IF(IH.EQ.'CCOS'.AND.IH2.EQ.' ')GOTO8600 IF(IH.EQ.'CCOS'.AND.IH2.EQ.'I ')GOTO8610 IF(IH.EQ.'CEXP'.AND.IH2.EQ.' ')GOTO8700 IF(IH.EQ.'CEXP'.AND.IH2.EQ.'I ')GOTO8710 IF(IH.EQ.'CLOG'.AND.IH2.EQ.' ')GOTO8800 IF(IH.EQ.'CLOG'.AND.IH2.EQ.'I ')GOTO8810 IF(IH.EQ.'CSIN'.AND.IH2.EQ.' ')GOTO8900 IF(IH.EQ.'CSIN'.AND.IH2.EQ.'I ')GOTO8910 IF(IH.EQ.'CSQR'.AND.IH2.EQ.'T ')GOTO8950 IF(IH.EQ.'CSQR'.AND.IH2.EQ.'TI ')GOTO8960 CCCCC FOLLOWING 5 LINES ADDED JULY 1995. IF(IH.EQ.'HERM'.AND.IH2.EQ.'ITE ')GOTO8970 IF(IH.EQ.'LNHE'.AND.IH2.EQ.'RMIT')GOTO8975 IF(IH.EQ.'HERM'.AND.IH2.EQ.'SGN ')GOTO8978 IF(IH.EQ.'LAGU'.AND.IH2.EQ.'ERRE')GOTO8980 IF(IH.EQ.'LEGE'.AND.IH2.EQ.'NDRE')THEN IF(SAVE2.LT.0.)GOTO8990 IF(SAVE2.GE.0.)GOTO5280 ENDIF IF(IH.EQ.'BN '.AND.IH2.EQ.' ')GOTO8010 IF(IH.EQ.'EN '.AND.IH2.EQ.' ')GOTO8020 IF(IH.EQ.'BINO'.AND.IH2.EQ.'M ')GOTO8030 IF(IH.EQ.'BINO'.AND.IH2.EQ.'MIAL')GOTO8030 C IF(IH.EQ.'ABRA'.AND.IH2.EQ.'M ')GOTO8040 IF(IH.EQ.'CLAU'.AND.IH2.EQ.'SN ')GOTO8045 IF(IH.EQ.'DEBY'.AND.IH2.EQ.'E ')GOTO8050 IF(IH.EQ.'EXP3'.AND.IH2.EQ.' ')GOTO8055 IF(IH.EQ.'GOOD'.AND.IH2.EQ.'ST ')GOTO8060 IF(IH.EQ.'LOBA'.AND.IH2.EQ.'CH ')GOTO8065 IF(IH.EQ.'STRO'.AND.IH2.EQ.'M ')GOTO8070 IF(IH.EQ.'SYNC'.AND.IH2.EQ.'H1 ')GOTO8075 IF(IH.EQ.'SYNC'.AND.IH2.EQ.'H2 ')GOTO8080 IF(IH.EQ.'TRAN'.AND.IH2.EQ.' ')GOTO8085 C IF(IH.EQ.'AIRI'.AND.IH2.EQ.'NT ')GOTO18090 IF(IH.EQ.'AIRY'.AND.IH2.EQ.'GI ')GOTO18095 IF(IH.EQ.'AIRY'.AND.IH2.EQ.'HI ')GOTO18100 IF(IH.EQ.'ATNI'.AND.IH2.EQ.'NT ')GOTO18105 IF(IH.EQ.'BIRI'.AND.IH2.EQ.'NT ')GOTO18110 IF(IH.EQ.'I0IN'.AND.IH2.EQ.'T ')GOTO18115 IF(IH.EQ.'I0ML'.AND.IH2.EQ.'0 ')GOTO18120 IF(IH.EQ.'I1ML'.AND.IH2.EQ.'1 ')GOTO18125 IF(IH.EQ.'J0IN'.AND.IH2.EQ.'T ')GOTO18130 IF(IH.EQ.'K0IN'.AND.IH2.EQ.'T ')GOTO18135 IF(IH.EQ.'Y0IN'.AND.IH2.EQ.'T ')GOTO18140 C IFOUND='NO' GOTO9000 C 551 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 559 FORMAT('**** ERROR: NEGATIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C CCCCC CALL NORCDF(ARG1,RESULT) CALL NODCDF(DBLE(ARG1),DRESLT) TERM=REAL(DRESLT) GOTO9000 C 552 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CCCCC CALL NORPDF(ARG1,RESULT) CALL NODPDF(DBLE(ARG1),DRESLT) TERM=REAL(DRESLT)/ZSCALE GOTO9000 C 553 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CCCCC CALL NORPPF(ARG1,RESULT) CALL NODPPF(DBLE(ARG1),DRESLT) TERM=ZLOC + ZSCALE*REAL(DRESLT) GOTO9000 C 554 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL NORSF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 555 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=DBLE((ARG1-ZLOC)/ZSCALE) CALL NODPDF(DARG1,DTERM2) CALL NODCDF(-DARG1,DTERM1) IF(DTERM1.NE.0.0D0)THEN TERM=REAL(DTERM2/DTERM1)/ZSCALE ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557)X CALL DPWRST('XXX','BUG ') TERM=0.0 ENDIF 557 FORMAT('*****WARNING: FOR ARGUMENT = ',F15.7,' CDF TERM ', 1'ESSENTIALLY 1, VALUE SET TO 0') GOTO9000 C 556 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=-DBLE((ARG1-ZLOC)/ZSCALE) CALL NODCDF(DARG1,DTERM1) IF(DTERM1.GT.0.0D0)THEN TERM=REAL(-DLOG(DTERM1)) ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557)X CALL DPWRST('XXX','BUG ') TERM=0.0 ENDIF GOTO9000 C 8557 CONTINUE ARG1=X C ZLOC1=0.0 IF(SAVE1.NE.-99.9)ZLOC1=SAVE1 ZSCAL1=1.0 IF(SAVE2.NE.-99.9)ZSCAL1=SAVE2 ZLOC2=0.0 IF(SAVE3.NE.-99.9)ZLOC2=SAVE3 ZSCAL2=1.0 IF(SAVE4.NE.-99.9)ZSCAL2=SAVE4 P=0.5 IF(SAVE5.GE.0.0 .AND. SAVE5.LE.1.0)P=SAVE5 CALL NMXCDF(ARG1,ZLOC1,ZSCAL1,ZLOC2,ZSCAL2,P,RESULT) TERM=RESULT GOTO9000 C 8558 CONTINUE ARG1=X C ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL NORPDF(ARG1,RESLT1) RESLT1=RESLT1/ZSCALE C ARG1=X ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL NORPDF(ARG1,RESLT2) RESLT2=RESLT2/ZSCALE C P=0.5 IF(SAVE5.GE.0.0 .AND. SAVE5.LE.1.0)P=SAVE5 TERM=P*RESLT1 + (1.0-P)*RESLT2 GOTO9000 C 8559 CONTINUE ARG1=X ZLOC1=0.0 IF(SAVE1.NE.-99.9)ZLOC1=SAVE1 ZSCAL1=1.0 IF(SAVE2.NE.-99.9)ZSCAL1=SAVE2 ZLOC2=0.0 IF(SAVE3.NE.-99.9)ZLOC2=SAVE3 ZSCAL2=1.0 IF(SAVE4.NE.-99.9)ZSCAL2=SAVE4 P=0.5 IF(SAVE5.GE.0.0 .AND. SAVE5.LE.1.0)P=SAVE5 C IF(ZSCAL1.LE.0.0.OR.ZSCAL2.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL NMXPPF(ARG1,ZLOC1,ZSCAL1,ZLOC2,ZSCAL2,P,RESULT) TERM=RESULT GOTO9000 C 561 CONTINUE ARG1=X CCCCC IARG2=SAVE1+0.5 ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CCCCC CALL TCDF(ARG1,IARG2,RESULT) CALL TCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 562 CONTINUE ARG1=X CCCCC IARG2=SAVE1+0.5 ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CCCCC CALL TPDF(ARG1,IARG2,RESULT) CALL TPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 563 CONTINUE ARG1=X CCCCC IARG2=SAVE1+0.5 ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CCCCC CALL TPPF(ARG1,IARG2,RESULT) CALL TPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 571 CONTINUE ARG1=X IARG2=SAVE1+0.5 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL CHSCDF(ARG1,IARG2,RESULT) TERM=RESULT GOTO9000 C 572 CONTINUE ARG1=X IARG2=SAVE1+0.5 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL CHSPDF(ARG1,IARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 573 CONTINUE ARG1=X IARG2=SAVE1+0.5 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL CHSPPF(ARG1,IARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 581 CONTINUE ARG1=X IARG2=SAVE1+0.5 IARG3=SAVE2+0.5 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL FCDF(ARG1,IARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C 582 CONTINUE ARG1=X IARG2=SAVE1+0.5 IARG3=SAVE2+0.5 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL FPDF(ARG1,IARG2,IARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 583 CONTINUE ARG1=X IARG2=SAVE1+0.5 IARG3=SAVE2+0.5 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL FPPF(ARG1,IARG2,IARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 591 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 599 FORMAT('**** ERROR: NEGATIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CCCCC THE FOLLOWING LINE WAS ADDED MAY 1993 CCCCC IARG3=SAVE2+0.5 (BUT INCORRECT) CCCCC THE FOLLOWING LINE FIXED THE ABOVE LINE JANUARY 1994 IARG3=MINMAX CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1993 CCCCC CALL WEICDF(ARG1,ARG2,RESULT) CALL WEICDF(ARG1,ARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C 592 CONTINUE ARG1=X ARG2=SAVE1 CCCCC THE FOLLOWING LINE WAS ADDED MAY 1993 CCCCC IARG3=SAVE2+0.5 (BUT INCORRECT) CCCCC THE FOLLOWING LINE FIXED THE ABOVE LINE JANUARY 1994 IARG3=MINMAX CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1993 CCCCC CALL WEIPDF(ARG1,ARG2,RESULT) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL WEIPDF(ARG1,ARG2,IARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 593 CONTINUE ARG1=X ARG2=SAVE1 CCCCC THE FOLLOWING LINE WAS ADDED MAY 1993 CCCCC IARG3=SAVE2+0.5 (BUT INCORRECT) CCCCC THE FOLLOWING LINE FIXED THE ABOVE LINE JANUARY 1994 IARG3=MINMAX CCCCC THE FOLLOWING LINE WAS CHANGED MAY 1993 CCCCC CALL WEIPPF(ARG1,ARG2,RESULT) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL WEIPPF(ARG1,ARG2,IARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 594 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL WEIHAZ(ARG1,ARG2,IARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 595 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL WEICHA(ARG1,ARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C 596 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IARG3=MINMAX ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 CALL WEIAFR(ARG1,ARG2,ARG3,ZLOC,ZSCALE,IARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED MAY 1990 601 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,609) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 609 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL IGCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 602 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,609) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL IGPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 603 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,609) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL IGPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 604 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,609) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL IGHAZ(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 605 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,609) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL IGCHA(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED MAY 1990 611 CONTINUE ARG1=X ARG2=SAVE1 C ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL WALCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 612 CONTINUE ARG1=X ARG2=SAVE1 C ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL WALPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 613 CONTINUE ARG1=X ARG2=SAVE1 C ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL WALPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 614 CONTINUE ARG1=X ARG2=SAVE1 AMU=1.0 C ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL IGHAZ(ARG1,ARG2,AMU,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 615 CONTINUE ARG1=X ARG2=SAVE1 AMU=1.0 C ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL IGCHA(ARG1,ARG2,AMU,RESULT) TERM=RESULT GOTO9000 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED MAY 1990 621 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,629) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 629 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL RIGCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 622 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,629) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL RIGPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 623 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,629) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL RIGPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 624 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,629) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL RIGHAZ(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 625 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,629) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL RIGCHA(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED MAY 1990 631 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,639) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 639 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL FLCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 632 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,639) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL FLPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 633 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,639) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL FLPPF(ARG1,ARG2,RESULT) TERM=ZLOC + RESULT GOTO9000 C 634 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,639) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL FLHAZ(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 635 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,639) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL FLCHA(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC THE FOLLOWING 3 SECTIONS WERE ADDED DECEMBER 1993 641 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,649) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 649 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL GEPCDF(ARG1,ARG2,IARG3,IGEPDF,RESULT) TERM=RESULT GOTO9000 C 642 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,649) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GEPPDF(ARG1,ARG2,IARG3,IGEPDF,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 643 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,649) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GEPPPF(ARG1,ARG2,IARG3,IGEPDF,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 644 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,649) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GEPHAZ(ARG1,ARG2,IARG3,IGEPDF,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 645 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,649) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GEPCHA(ARG1,ARG2,IARG3,IGEPDF,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 651 CONTINUE ARG1=X ARG2=SAVE1 IARG3=SAVE2+0.5 CALL BINCDF(ARG1,ARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C 652 CONTINUE ARG1=X ARG2=SAVE1 IARG3=SAVE2+0.5 CALL BINCDF(ARG1,ARG2,IARG3,RESLT1) IF(ARG1.LE.0.1)THEN TERM=RESLT1 ELSE ARG1=X-1.0 CALL BINCDF(ARG1,ARG2,IARG3,RESLT2) TERM=RESLT1-RESLT2 ENDIF GOTO9000 C 653 CONTINUE ARG1=X ARG2=SAVE1 IARG3=SAVE2+0.5 CALL BINPPF(ARG1,ARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 661 CONTINUE ARG1=X ARG2=SAVE1 CALL POICDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 662 CONTINUE ARG1=X ARG2=SAVE1 CALL POICDF(ARG1,ARG2,RESLT1) IF(ARG1.LE.0.1)THEN TERM=RESLT1 ELSE ARG1=X-1.0 CALL POICDF(ARG1,ARG2,RESLT2) TERM=RESLT1-RESLT2 ENDIF GOTO9000 C 663 CONTINUE ARG1=X ARG2=SAVE1 CALL POIPPF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 671 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=ARG1-ZLOC C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,649) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL SEMCDF(ARG1,ZSCALE,RESULT) TERM=RESULT GOTO9000 C 672 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=ARG1-ZLOC C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,649) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL SEMPDF(ARG1,ZSCALE,RESULT) TERM=RESULT GOTO9000 C 673 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,649) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL SEMPPF(ARG1,ZSCALE,RESULT) TERM=ZLOC + RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 681 CONTINUE ARG1=X ARG2=SAVE1 CCCCC IARG3=SAVE2+0.5 ARG3=SAVE2 CALL NBCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 682 CONTINUE ARG1=X ARG2=SAVE1 CCCCC IARG3=SAVE2+0.5 ARG3=SAVE2 CALL NBPDF(ARG1,ARG2,ARG3,RESLT1) TERM=RESLT1 CCCCC IF(ARG1.LE.0.1)THEN CCCCC TERM=RESLT1 CCCCC ELSE CCCCC ARG1=X-1.0 CCCCC CALL NBCDF(ARG1,ARG2,IARG3,RESLT2) CCCCC TERM=RESLT1-RESLT2 CCCCC ENDIF GOTO9000 C 683 CONTINUE ARG1=X ARG2=SAVE1 CCCCC IARG3=SAVE2+0.5 ARG3=SAVE2 CALL NBPPF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 691 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,699) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 699 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL CAUCDF(ARG1,RESULT) TERM=RESULT GOTO9000 C 692 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,699) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL CAUPDF(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 693 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,699) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL CAUPPF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 694 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,699) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL CAUSF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 701 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,709) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 709 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL DEXCDF(ARG1,RESULT) TERM=RESULT GOTO9000 C 702 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,709) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL DEXPDF(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 703 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,709) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL DEXPPF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 704 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,709) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL DEXSF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 711 CONTINUE ARG1=X IARG3=MINMAX ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,719) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 719 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL EV1CDF(ARG1,IARG3,RESULT) TERM=RESULT GOTO9000 C 712 CONTINUE ARG1=X IARG3=MINMAX ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,719) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL EV1PDF(ARG1,IARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 713 CONTINUE ARG1=X IARG3=MINMAX ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,719) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL EV1PPF(ARG1,IARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 714 CONTINUE ARG1=X IARG3=MINMAX ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,719) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL EV1HAZ(ARG1,IARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 715 CONTINUE ARG1=X IARG3=MINMAX ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,719) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL EV1CHA(ARG1,IARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 721 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,729) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 729 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL EV2CDF(ARG1,ARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C 722 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,729) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL EV2PDF(ARG1,ARG2,IARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 723 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,729) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL EV2PPF(ARG1,ARG2,IARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 724 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,729) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL EV2HAZ(ARG1,ARG2,IARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 725 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,729) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL EV2CHA(ARG1,ARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 731 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,739) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 739 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C CALL EXPCDF(ARG1,RESULT) TERM=RESULT GOTO9000 C 732 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,739) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL EXPPDF(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 733 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,739) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL EXPPPF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 734 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,739) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL EXPSF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 735 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,739) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL EXPHAZ(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 736 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,739) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL EXPCHA(ARG1,RESULT) TERM=RESULT GOTO9000 C 737 CONTINUE ARG1=X ARG2=SAVE1 ZSCALE=SAVE2 CALL EXPAFR(ARG1,ARG2,ZSCALE,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 741 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,749) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 749 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL GAMCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 742 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,749) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GAMPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 743 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,749) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GAMPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 744 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,749) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE C IF(ARG1.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11747)X CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 11747 FORMAT('**** ERROR FROM GAMHAZ: VALUE OF ',E15.7,' YIELDS ', 1'A NEGATIVE ARGUMENT FOR GAMPDF AND GAMCDF.') C IF(ARG2.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11748) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 11748 FORMAT('**** ERROR FROM GAMHAZ: NEGATIVE VALUES FOR SHAPE ', 1'PARAMETER NOT ALLOWED.') C IF(ARG2.EQ.1.0)THEN TERM=1.0/ZSCALE GOTO9000 ENDIF CALL GAMPDF(ARG1,ARG2,PDF) CALL GAMCDF(ARG1,ARG2,CDF) TERM1=1.0-CDF IF(TERM1.NE.0.0)THEN TERM=(PDF/TERM1)/ZSCALE ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,747)X CALL DPWRST('XXX','BUG ') TERM=0.0 ENDIF 747 FORMAT('*****WARNING: FOR ARGUMENT = ',F15.7,' CDF TERM ', 1'ESSENTIALLY 1, VALUE SET TO 0') GOTO9000 C 745 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ARG1.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12747)X CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 12747 FORMAT('**** ERROR FROM GAMCHAZ: VALUE OF ',E15.7,' YIELDS ', 1'A NEGATIVE ARGUMENT FOR GAMCDF.') C IF(ARG2.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12748) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 12748 FORMAT('**** ERROR FROM GAMCHAZ: NEGATIVE VALUES FOR SHAPE ', 1'PARAMETER NOT ALLOWED.') C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,12749) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 12749 FORMAT('**** ERROR FROM GAMCHAZ: NEGATIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C CALL GAMCDF(ARG1,ARG2,CDF) TERM1=1.0-CDF IF(TERM1.GT.0.0)THEN TERM=-LOG(TERM1) ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,747)X CALL DPWRST('XXX','BUG ') TERM=0.0 ENDIF GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 751 CONTINUE ARG1=X ARG2=SAVE1 CALL GEOCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 752 CONTINUE ARG1=X ARG2=SAVE1 CALL GEOPDF(ARG1,ARG2,RESLT1) TERM=RESLT1 GOTO9000 C 753 CONTINUE ARG1=X ARG2=SAVE1 CALL GEOPPF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MARCH, 2004. 756 CONTINUE ARG1=X ARG2=SAVE1 CALL GE2CDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 757 CONTINUE ARG1=X ARG2=SAVE1 CALL GE2PDF(ARG1,ARG2,RESLT1) TERM=RESLT1 GOTO9000 C 758 CONTINUE ARG1=X ARG2=SAVE1 CALL GE2PPF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 761 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 769 FORMAT('**** ERROR: NEGATIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL HFNCDF(ARG1,RESULT) TERM=RESULT GOTO9000 C 762 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL HFNPDF(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 763 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL HFNPPF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 771 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL LAMCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 772 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL LAMPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 773 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL LAMPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 774 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL LAMSF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. CCCCC APRIL 1995. SUPPORT STANDARD DEVIATION SHAPE PARAMETER. 781 CONTINUE ARG1=X ARG2=SAVE1 IF(ARG2.LE.0.0)ARG2=1.0 CCCCC CALL LGNCDF(ARG1,RESULT) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,789) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 789 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL LGNCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC APRIL 1995. SUPPORT STANDARD DEVIATION SHAPE PARAMETER. 782 CONTINUE ARG1=X ARG2=SAVE1 IF(ARG2.LE.0.0)ARG2=1.0 CCCCC CALL LGNPDF(ARG1,RESULT) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,789) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LGNPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C CCCCC APRIL 1995. SUPPORT STANDARD DEVIATION SHAPE PARAMETER. 783 CONTINUE ARG1=X ARG2=SAVE1 IF(ARG2.LE.0.0)ARG2=1.0 CCCCC CALL LGNPPF(ARG1,RESULT) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,789) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL LGNPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 784 CONTINUE ARG1=X ARG2=SAVE1 IF(ARG2.LE.0.0)ARG2=1.0 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,789) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LGNHAZ(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 785 CONTINUE ARG1=X ARG2=SAVE1 IF(ARG2.LE.0.0)ARG2=1.0 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,789) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LGNCHA(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 786 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 CALL LGNAFR(ARG1,ARG2,ARG3,ZLOC,ZSCALE,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 791 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 799 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL LOGCDF(ARG1,RESULT) TERM=RESULT GOTO9000 C 792 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LOGPDF(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 793 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL LOGPPF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 794 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL LOGSF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 795 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LOGHAZ(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 796 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LOGCHA(ARG1,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. CCCCC OCTOBER 2004: TREAT A "LOCATION" PARAMETER AS A CCCCC A SHAPE PARAMETER (AND ADJUST TRUE LOCATION AND CCCCC SCALE PARAMETERS ACCORDINGLY). HOWEVER, DEFAULT IT CCCCC TO 1 IF NOT SPECIFIED. C 801 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE C CALL PARCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 802 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL PARPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 803 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL PARPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 804 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE C CALL PARHAZ(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 805 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE C CALL PARCHA(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1994. 811 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2-ZLOC ARG1=(ARG1-ZLOC)/ZSCALE CALL UNICDF(ARG1,RESULT) TERM=RESULT GOTO9000 C 812 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2-ZLOC ARG1=(ARG1-ZLOC)/ZSCALE CALL UNIPDF(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 813 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2-ZLOC CALL UNIPPF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 814 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2-ZLOC CALL UNISF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 815 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2-ZLOC ARG1=(ARG1-ZLOC)/ZSCALE CALL UNIHAZ(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 816 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2-ZLOC ARG1=(ARG1-ZLOC)/ZSCALE CALL UNICHA(ARG1,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 1994. 821 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4-ZLOC ARG1=(ARG1-ZLOC)/ZSCALE CALL BETCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 822 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4-ZLOC ARG1=(ARG1-ZLOC)/ZSCALE CALL BETPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 823 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4-ZLOC CALL BETPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 831 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5-ZLOC ARG1=(ARG1-ZLOC)/ZSCALE CALL NCBCDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C 832 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5-ZLOC ARG1=(ARG1-ZLOC)/ZSCALE CALL NCBPDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 833 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5-ZLOC CALL NCBPPF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 1994. 841 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL NCCCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JANUARY, 1996. 842 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL NCCPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 843 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL NCCPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 844 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL NCCNCP(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 1994. 851 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL NCFCDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 1994. 852 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL NCFPDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 853 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL NCFPPF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 1994. 861 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL NCTCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MAY 1995. 862 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL NCTPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 863 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL NCTPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 1994. 871 CONTINUE IARG1=INT(X+0.5) IARG2=INT(SAVE1+0.5) CALL DISCDF(IARG1,IARG2,RESULT) TERM=RESULT GOTO9000 C 872 CONTINUE IARG1=INT(X+0.5) IARG2=INT(SAVE1+0.5) CALL DISPDF(IARG1,IARG2,RESULT) TERM=RESULT GOTO9000 C 873 CONTINUE ARG1=X IARG2=INT(SAVE1+0.5) CALL DISPPF(ARG1,IARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 1994. 881 CONTINUE ARG1=X ARG2=SAVE1 ZLOWLM=-1.0 IF(SAVE2.NE.-99.9)ZLOWLM=SAVE2 ZUPPLM=1.0 IF(SAVE3.NE.-99.9)ZUPPLM=SAVE3 C CALL TRICDF(ARG1,ARG2,ZLOWLM,ZUPPLM,RESULT) TERM=RESULT GOTO9000 C 882 CONTINUE ARG1=X ARG2=SAVE1 ZLOWLM=-1.0 IF(SAVE2.NE.-99.9)ZLOWLM=SAVE2 ZUPPLM=1.0 IF(SAVE3.NE.-99.9)ZUPPLM=SAVE3 C CALL TRIPDF(ARG1,ARG2,ZLOWLM,ZUPPLM,RESULT) TERM=RESULT GOTO9000 C 883 CONTINUE ARG1=X ARG2=SAVE1 ZLOWLM=-1.0 IF(SAVE2.NE.-99.9)ZLOWLM=SAVE2 ZUPPLM=1.0 IF(SAVE3.NE.-99.9)ZUPPLM=SAVE3 C CALL TRIPPF(ARG1,ARG2,ZLOWLM,ZUPPLM,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 1994. 891 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL DNTCDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MAY, 2004. 892 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL DNTPDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 893 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL DNTPPF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 1994. 901 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ZLOC=0.0 IF(SAVE5.NE.-99.9)ZLOC=SAVE5 ZSCALE=1.0 IF(SAVE6.NE.-99.9)ZSCALE=SAVE6 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL DNFCDF(ARG1,ARG2,ARG3,ARG4,ARG5,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MAY 2004. 902 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ZLOC=0.0 IF(SAVE5.NE.-99.9)ZLOC=SAVE5 ZSCALE=1.0 IF(SAVE6.NE.-99.9)ZSCALE=SAVE6 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL DNFPDF(ARG1,ARG2,ARG3,ARG4,ARG5,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 903 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ZLOC=0.0 IF(SAVE5.NE.-99.9)ZLOC=SAVE5 ZSCALE=1.0 IF(SAVE6.NE.-99.9)ZSCALE=SAVE6 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL DNFPPF(ARG1,ARG2,ARG3,ARG4,ARG5,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 1994. 911 CONTINUE IARG1=X+0.5 IARG2=SAVE1+0.5 IARG3=SAVE2+0.5 IARG4=SAVE3+0.5 HYPPNT=.FALSE. CALL HYPCDF(IARG1,IARG2,IARG3,IARG4,HYPPNT,RESULT) TERM=RESULT GOTO9000 C 912 CONTINUE IARG1=X+0.5 IARG2=SAVE1+0.5 IARG3=SAVE2+0.5 IARG4=SAVE3+0.5 HYPPNT=.TRUE. CALL HYPCDF(IARG1,IARG2,IARG3,IARG4,HYPPNT,RESULT) TERM=RESULT GOTO9000 C 913 CONTINUE ARG1=X IARG2=SAVE1+0.5 IARG3=SAVE2+0.5 IARG4=SAVE3+0.5 CALL HYPPPF(ARG1,IARG2,IARG3,IARG4,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1994. 921 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 IF(ZLOC.LT.0.0 .OR. ZLOC.GT.2*REALPI)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,926) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF C ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL VONCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 922 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 IF(ZLOC.LT.0.0 .OR. ZLOC.GT.2*REALPI)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,926) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF 926 FORMAT('***** ERROR: FOR VON MISES, LOCATION PARAMETER MUST ', 1'BE IN THE INTERVAL (0,2*PI).') C ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL VONPDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 923 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 IF(ZLOC.LT.0.0 .OR. ZLOC.GT.2*REALPI)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,926) CALL DPWRST('XXX','BUG') TERM=0.0 GOTO9000 ENDIF C ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL VONPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1994. 931 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL BVNCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MAY 1995. 932 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CCCCC SEPTEMBER 1995. ACTIVATE FOLLOWING LINE. CALL BVNPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1995. 941 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL COSCDF(ARG1,RESULT) TERM=RESULT GOTO9000 C 942 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL COSPDF(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 943 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL COSPPF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1995. 951 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL ALPCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 952 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL ALPPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 953 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL ALPPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 954 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL ALPHAZ(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 955 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL ALPCHA(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1995. 961 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CCCCC CALL PNRCDF(ARG1,ARG2,ARG3,RESULT) CALL PNRCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 962 CONTINUE ARG1=X ARG2=SAVE1 CCCCC ARG3=SAVE2 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CCCCC CALL PNRPDF(ARG1,ARG2,ARG3,RESULT) CALL PNRPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 963 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,749) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG3=1.0 CALL PNRPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 964 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,749) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL PNRHAZ(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 965 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,749) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL PNRCHA(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1995. 971 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG3.LE.0.0)ARG3=1.0 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,979) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 979 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL PLNCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 972 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG3.LE.0.0)ARG3=1.0 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,979) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL PLNPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 973 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG3.LE.0.0)ARG3=1.0 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,979) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL PLNPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 974 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG3.LE.0.0)ARG3=1.0 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,979) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL PLNHAZ(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 975 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG3.LE.0.0)ARG3=1.0 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,979) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL PLNCHA(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1995. 981 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG3.LE.0.0)ARG3=1.0 C ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL FNRCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 982 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG3.LE.0.0)ARG3=1.0 C ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL FNRPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 983 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG3.LE.0.0)ARG3=1.0 C ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL FNRPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1995. 991 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,998) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 998 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C CALL POWCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 992 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,998) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL POWPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 993 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,998) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL POWPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1995. 1011 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 IF(ARG4.EQ.-99.9)ARG4=0.0 IF(ARG5.EQ.-99.9)ARG5=1.0 C ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL TNRCDF(ARG1,ARG2,ARG3,ARG4,ARG5,RESULT) TERM=RESULT GOTO9000 C 1012 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 IF(ARG4.EQ.-99.9)ARG4=0.0 IF(ARG5.EQ.-99.9)ARG5=1.0 C ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL TNRPDF(ARG1,ARG2,ARG3,ARG4,ARG5,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1013 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 IF(ARG4.EQ.-99.9)ARG4=0.0 IF(ARG5.EQ.-99.9)ARG5=1.0 C ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL TNRPPF(ARG1,ARG2,ARG3,ARG4,ARG5,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1995. 1021 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL CHCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1022 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL CHPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1023 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL CHPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1995. 1031 CONTINUE ARG1=X ARG2=SAVE1 CALL DLGCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1032 CONTINUE ARG1=X ARG2=SAVE1 CALL DLGPDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1033 CONTINUE ARG1=X ARG2=SAVE1 CALL DLGPPF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1995. 1041 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG3.LE.0.)ARG3=1.0 CCCCC JUNE 1995. ADD 'TRUN' ARGUMENT CALL WARCDF(ARG1,ARG2,ARG3,RESULT,'NOTR') TERM=RESULT GOTO9000 C 1042 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG3.LE.0.)ARG3=1.0 CALL WARPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1043 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG3.LE.0.)ARG3=1.0 IFLAG2='OFF' CALL WARPPF(ARG1,ARG2,ARG3,RESULT,IFLAG2) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 2004. 1046 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) CALL YULCDF(DARG1,DARG2,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1047 CONTINUE ARG1=X ARG2=SAVE1 CALL YULPDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1048 CONTINUE ARG1=X ARG2=SAVE1 CALL YULPPF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1995. 1051 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1059) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 1059 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL LLGCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1052 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1059) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LLGPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1053 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1059) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL LLGPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1995. 1061 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11069) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 11069 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL GGDCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1062 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11069) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GGDPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1063 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11069) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GGDPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1998. 1064 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11069) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GGDHAZ(ARG1,ARG2,ARG3,HAZ) TERM=HAZ/ZSCALE GOTO9000 C 1065 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11069) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GGDCHA(ARG1,ARG2,ARG3,HAZ) TERM=HAZ GOTO9000 C 1066 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11069) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL IGACDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1067 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11069) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL IGAPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1068 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11069) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL IGAPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 1998. 1069 CONTINUE ARG1=X ARG2=SAVE1 ARG3=-1.0 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11069) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GGDHAZ(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 9065 CONTINUE ARG1=X ARG2=SAVE1 ARG3=-1.0 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11069) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GGDCHA(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 1995. 1071 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL ANGCDF(ARG1,RESULT) TERM=RESULT GOTO9000 C 1072 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL ANGPDF(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1073 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL ANGPPF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 1995. 1081 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2-ZLOC ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL ARSCDF(ARG1,RESULT) TERM=RESULT GOTO9000 C 1082 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2-ZLOC ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL ARSPDF(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1083 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2-ZLOC C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL ARSPPF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1995. 1091 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1099) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 1099 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL DWECDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1092 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1099) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL DWEPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1093 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1099) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL DWEPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1995. 1101 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1169) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 1169 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL LGACDF(ARG1,ARG2,ILGADF,RESULT) TERM=RESULT GOTO9000 C 1102 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1169) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LGAPDF(ARG1,ARG2,ILGADF,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1103 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1169) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL LGAPPF(ARG1,ARG2,ILGADF,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1995. 1111 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL HSECDF(ARG1,RESULT) TERM=RESULT GOTO9000 C 1112 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL HSEPDF(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1113 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL HSEPPF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1995. 1121 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1129) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 1129 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL HFCCDF(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1122 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1129) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL HFCPDF(ARG1,RESULT) TERM=RESULT GOTO9000 C 1123 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1129) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL HFCPPF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1995. 1131 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL HFLCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1132 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL HFLPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1133 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL HFLPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1995. 1141 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1149) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 1149 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL GEVCDF(ARG1,ARG2,MINMAX,RESULT) TERM=RESULT GOTO9000 C 1142 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1149) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GEVPDF(ARG1,ARG2,MINMAX,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1143 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1149) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GEVPPF(ARG1,ARG2,MINMAX,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1144 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GEVHAZ(ARG1,ARG2,IARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1145 CONTINUE ARG1=X ARG2=SAVE1 IARG3=MINMAX ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GEVCHA(ARG1,ARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1995. 1151 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GOMCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1152 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL GOMPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1153 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL GOMPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1995. CCCCC DECEMBER 2004. ALTHOUGH THE A PARAMETER IS TYPICALLY CALLED CCCCC A LOCATION PARAMETER, IT IS NOT IN THE TECHNICAL SENSE OF CCCCC LOCATION/SCALE PARAMETERS: f(X,A,B) = (1/B)f((X-A)/B,0,1). CCCCC THEREFORE, WE TREAT IT AS A SHAPE PARAMETER (DEFAULTS TO 1 IF CCCCC NOT SPECIFIED). C 1161 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE C CALL PA2CDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1162 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE C CALL PA2PDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1163 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,799) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL PA2PPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1995. 1171 CONTINUE ARG1=X ARG2=SAVE1 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1149) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL WCACDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1172 CONTINUE ARG1=X ARG2=SAVE1 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1149) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL WCAPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1173 CONTINUE ARG1=X ARG2=SAVE1 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1149) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL WCAPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1995. 1181 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IARG1=1 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1189) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 1189 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL EWECDF(ARG1,ARG2,ARG3,IARG1,RESULT) TERM=RESULT GOTO9000 C 1182 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IARG1=1 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1189) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL EWEPDF(ARG1,ARG2,ARG3,IARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1183 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IARG1=1 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1189) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL EWEPPF(ARG1,ARG2,ARG3,IARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1184 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IARG1=1 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1189) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL EWEHAZ(ARG1,ARG2,ARG3,IARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1185 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IARG1=1 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1189) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL EWECHA(ARG1,ARG2,ARG3,IARG1,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1995. 1191 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 IF(ARG3.EQ.-99.9)ARG3=0.0 IF(ARG4.EQ.-99.9)ARG4=1.0 C ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL TNECDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C 1192 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 IF(ARG3.EQ.-99.9)ARG3=0.0 IF(ARG4.EQ.-99.9)ARG4=1.0 C ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL TNEPDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1193 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 IF(ARG3.EQ.-99.9)ARG3=0.0 IF(ARG4.EQ.-99.9)ARG4=1.0 C ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL TNEPPF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1995. 1201 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1209) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 1209 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL GLOCDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1202 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1209) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GLOPDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1203 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1209) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GLOPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED OCTOBER, 1995. 1211 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 C ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL PEXCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1212 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 C ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL PEXPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1213 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 C ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL PEXPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1214 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ARG1=ARG1-ZLOC CALL PEXHAZ(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1215 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ARG1=ARG1-ZLOC CALL PEXCHA(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JANUARY, 1996. 1221 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1229) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 1229 FORMAT('**** ERROR: NON-POSITIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C ARG1=(ARG1-ZLOC)/ZSCALE CALL DGACDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1222 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1229) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL DGAPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1223 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1229) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL DGAPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JANUARY, 1996. 1231 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL KAPCDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C 1232 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL KAPPDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1233 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL KAPPPF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JANUARY, 1996. 1241 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 C ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL FCACDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1242 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 C ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL FCAPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1243 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 C ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL FCAPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JANUARY, 1996. 1251 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IARG4=INT(SAVE3+0.5) CALL BBNCDF(ARG1,ARG2,ARG3,IARG4,RESULT) TERM=RESULT GOTO9000 C 1252 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IARG4=INT(SAVE3+0.5) CALL BBNPDF(ARG1,ARG2,ARG3,IARG4,RESULT) TERM=RESULT GOTO9000 C 1253 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IARG4=INT(SAVE3+0.5) CALL BBNPPF(ARG1,ARG2,ARG3,IARG4,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MARCH 2004. 1256 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IARG4=INT(SAVE3+0.5) CALL POLCDF(ARG1,ARG2,ARG3,IARG4,RESULT) TERM=RESULT GOTO9000 C 1257 CONTINUE ARG1=X ARG2=INT(SAVE1+0.5) ARG3=INT(SAVE2+0.5) ARG4=INT(SAVE3+0.5) IARG5=INT(SAVE4+0.5) CALL POLPDF(ARG1,ARG2,ARG3,ARG4,IARG5,RESULT) TERM=RESULT GOTO9000 C 1258 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IARG4=INT(SAVE3+0.5) CALL POLPPF(ARG1,ARG2,ARG3,IARG4,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JANUARY, 1996. 1261 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL BRACDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1262 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL BRAPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1263 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL BRAPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JANUARY, 1996. 1271 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 C ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL GEXCDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C 1272 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 C ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ARG1=(ARG1-ZLOC)/ZSCALE C CALL GEXPDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1273 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 C ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GEXPPF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JANUARY, 1996. 1281 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL RECCDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1282 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL RECPDF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1283 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CALL RECPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MARCH, 1999. 1291 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ARG1.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11291)ARG1 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 11291 FORMAT( 1'***** ERROR FROM SRACDF. ARGUMENT 1 MUST BE POSITIVE. IT ', 1'WAS ',G15.7) IF(ARG2.LT.1.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,21291)ARG2 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 21291 FORMAT( 1'***** ERROR FROM SRACDF. ARGUMENT 2 MUST BE >= 1. IT ', 1'WAS ',G15.7) IF(ARG3.LT.2.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31291)ARG3 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 31291 FORMAT( 1'***** ERROR FROM SRACDF. ARGUMENT 3 MUST BE >= 2. IT ', 1'WAS ',G15.7) IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CCCCC CALL SRACDF(ARG1,ARG2,ARG3,RESULT) DRESLT=PRTRNG(DBLE(ARG1),DBLE(ARG2),DBLE(ARG3),IFAULT) RESULT=REAL(DRESLT) TERM=RESULT/ZSCALE GOTO9000 C 1292 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF CCCCC CALL SRAPDF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1293 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF IF(ARG1.LT.0.90.OR.ARG1.GT.0.99)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11293) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,11294)ARG1 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 11293 FORMAT( 1'***** ERROR FROM SRAPPF. ARGUMENT 1 MUST BE IN THE INTERVAL ', 1'(0.90,0.99).') 11294 FORMAT( 1' IT WAS ',G15.7) IF(ARG2.LT.1.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,21293)ARG2 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 21293 FORMAT( 1'***** ERROR FROM SRAPPF. ARGUMENT 2 MUST BE >= 1. IT ', 1'WAS ',G15.7) IF(ARG3.LT.2.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,31293)ARG3 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 31293 FORMAT( 1'***** ERROR FROM SRAPPF. ARGUMENT 3 MUST BE >= 2. IT ', 1'WAS ',G15.7) C DRESLT=QTRNG(DBLE(ARG1),DBLE(ARG2),DBLE(ARG3),IFAULT) RESULT=REAL(DRESLT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED AUGUST, 2001. 1301 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=0.0D0 DARG5=1.0D0 IF(SAVE3.NE.-99.9)DARG4=DBLE(SAVE3) IF(SAVE4.NE.-99.9)DARG5=DBLE(SAVE4) DARG1=(DARG1-DARG4)/DARG5 C IF(DARG5.LE.0.0D0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C IWRITE='ERRO' CALL GLDCDF(DARG1,DARG2,DARG3,DRESLT,IGLDDF,IWRITE) TERM=REAL(DRESLT) GOTO9000 C 1302 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=0.0D0 DARG5=1.0D0 IF(SAVE3.NE.-99.9)DARG4=DBLE(SAVE3) IF(SAVE4.NE.-99.9)DARG5=DBLE(SAVE4) DARG1=(DARG1-DARG4)/DARG5 C IF(DARG5.LE.0.0D0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GLDPDF(DARG1,DARG2,DARG3,DRESLT,IGLDDF,IWRITE) TERM=REAL(DRESLT)/DARG5 GOTO9000 C 1303 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=0.0D0 DARG5=1.0D0 IF(SAVE3.NE.-99.9)DARG4=DBLE(SAVE3) IF(SAVE4.NE.-99.9)DARG5=DBLE(SAVE4) C IF(DARG5.LE.0.0D0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C IWRITE='ERRO' CALL GLDPPF(DARG1,DARG2,DARG3,DRESLT,IGLDDF,IWRITE) TERM=DARG4 + DARG5*DRESLT GOTO9000 C C1304 CONTINUE CCCCC ARG1=X CCCCC ARG2=SAVE1 CCCCC IWRITE='ON' CCCCC CALL GLDCHK(ARG1,ARG2,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE) CCCCC TERM=0.0 CCCCC IF(IFLAG.EQ.1)TERM=1.0 CCCCC GOTO9000 C 1305 CONTINUE C C DETERMINE LOWER LIMIT FOR GENERALIZED TUKEY LAMBDA. C FIND GLDPPF OF 0. C DARG1=0.0D0 DARG2=DBLE(X) DARG3=DBLE(SAVE1) DARG4=0.0D0 DARG5=1.0D0 IF(SAVE2.NE.-99.9)DARG4=DBLE(SAVE2) IF(SAVE3.NE.-99.9)DARG5=DBLE(SAVE3) C IF(DARG5.LE.0.0D0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C IWRITE='ERRO' CALL GLDPPF(DARG1,DARG2,DARG3,DRESLT,IGLDDF,IWRITE) TERM=DARG4 + DARG5*DRESLT GOTO9000 C CCCCC ARG1=X CCCCC ARG2=SAVE1 CCCCC ARG3=SAVE2 CCCCC ARG4=SAVE3 CCCCC ZLOC=0.0 CCCCC IF(SAVE2.NE.-99.9)ZLOC=SAVE2 CCCCC ZSCALE=1.0 CCCCC CALL GLDCHK(ARG2,ARG3,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE) CCCCC IF(ISIGN.LT.0)ZSCALE=-1.0 CCCCC IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C CCCCC IF(ISIGN.GT.0 .AND. ZSCALE.LE.0.0)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,559) CCCCC CALL DPWRST('XXX','BUG ') CCCCC TERM=0.0 CCCCC GOTO9000 CCCCC ELSEIF(ISIGN.LT.0 .AND. ZSCALE.GE.0.0)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1309) CCCCC CALL DPWRST('XXX','BUG ') CCCCC TERM=0.0 CCCCC GOTO9000 CCCCC ENDIF C CCCCC IWRITE='OFF' CCCCC CALL GLDCHK(ARG1,ARG2,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE) CCCCC TERM=ZLOC + ABS(ZSCALE)*ALOWER CCCCC GOTO9000 C 1306 CONTINUE C C DETERMINE UPPER LIMIT FOR GENERALIZED TUKEY LAMBDA. C FIND GLDPPF OF 1. C DARG1=1.0D0 DARG2=DBLE(X) DARG3=DBLE(SAVE1) DARG4=0.0D0 DARG5=1.0D0 IF(SAVE2.NE.-99.9)DARG4=DBLE(SAVE2) IF(SAVE3.NE.-99.9)DARG5=DBLE(SAVE3) C IF(DARG5.LE.0.0D0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,559) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C IWRITE='ERRO' CALL GLDPPF(DARG1,DARG2,DARG3,DRESLT,IGLDDF,IWRITE) TERM=DARG4 + DARG5*DRESLT GOTO9000 C CCCCC ARG1=X CCCCC ARG2=SAVE1 CCCCC ARG3=SAVE2 CCCCC ARG4=SAVE3 CCCCC ZLOC=0.0 CCCCC IF(SAVE2.NE.-99.9)ZLOC=SAVE2 CCCCC ZSCALE=1.0 CCCCC CALL GLDCHK(ARG2,ARG3,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE) CCCCC IF(ISIGN.LT.0)ZSCALE=-1.0 CCCCC IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C CCCCC IF(ISIGN.GT.0 .AND. ZSCALE.LE.0.0)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,559) CCCCC CALL DPWRST('XXX','BUG ') CCCCC TERM=0.0 CCCCC GOTO9000 CCCCC ELSEIF(ISIGN.LT.0 .AND. ZSCALE.GE.0.0)THEN CCCCC WRITE(ICOUT,999) CCCCC CALL DPWRST('XXX','BUG ') CCCCC WRITE(ICOUT,1309) CCCCC CALL DPWRST('XXX','BUG ') CCCCC TERM=0.0 CCCCC GOTO9000 CCCCC ENDIF C CCCCC IWRITE='OFF' CCCCC CALL GLDCHK(ARG1,ARG2,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE) CCCCC TERM=ZLOC + ABS(ZSCALE)*AUPPER CCCCC GOTO9000 C C1307 CONTINUE CCCCC ARG1=X CCCCC ARG2=SAVE1 CCCCC IWRITE='OFF' CCCCC CALL GLDCHK(ARG1,ARG2,ALOWER,AUPPER,IFLAG,ISIGN,IWRITE) CCCCC TERM=REAL(ISIGN) CCCCC GOTO9000 C 1321 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LDECDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1322 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LDEPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1323 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL LDEPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1331 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL IWECDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1332 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL IWEPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1333 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL IWEPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1334 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,749) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE C IF(ARG1.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1337)X CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 1337 FORMAT('**** ERROR FROM IWEHAZ: VALUE OF ',E15.7,' YIELDS ', 1'A NEGATIVE ARGUMENT FOR IWEPDF AND IWECDF.') C IF(ARG2.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1338) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 1338 FORMAT('**** ERROR FROM IWEHAZ: NEGATIVE VALUES FOR SHAPE ', 1'PARAMETER NOT ALLOWED.') C IF(ARG2.EQ.1.0)THEN TERM=1.0/ZSCALE GOTO9000 ENDIF CALL IWEPDF(ARG1,ARG2,PDF) CALL IWECDF(ARG1,ARG2,CDF) TERM1=1.0-CDF IF(TERM1.NE.0.0)THEN TERM=(PDF/TERM1)/ZSCALE ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1349)X CALL DPWRST('XXX','BUG ') TERM=0.0 ENDIF 1349 FORMAT('*****WARNING: FOR ARGUMENT = ',F15.7,' CDF TERM ', 1'ESSENTIALLY 1, VALUE SET TO 0') GOTO9000 C 1335 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ARG1.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,13337)X CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 13337 FORMAT('**** ERROR FROM IWECHAZ: VALUE OF ',E15.7,' YIELDS ', 1'A NEGATIVE ARGUMENT FOR IWECDF.') C IF(ARG2.LT.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,13338) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 13338 FORMAT('**** ERROR FROM IWECHAZ: NEGATIVE VALUES FOR SHAPE ', 1'PARAMETER NOT ALLOWED.') C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,13339) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 13339 FORMAT('**** ERROR FROM IWECHAZ: NEGATIVE VALUES FOR SCALE ', 1'PARAMETER NOT ALLOWED.') C CALL IWECDF(ARG1,ARG2,CDF) TERM1=1.0-CDF IF(TERM1.GT.0.0)THEN TERM=-LOG(TERM1) ELSE WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,13337)X CALL DPWRST('XXX','BUG ') TERM=0.0 ENDIF GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 2001. 1341 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4-ZLOC C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL JSBCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1342 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4-ZLOC C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL JSBPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1343 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4-ZLOC C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL JSBPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER, 2001. 1351 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4-ZLOC ARG1=(ARG1-ZLOC)/ZSCALE CALL JSUCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1352 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4-ZLOC ARG1=(ARG1-ZLOC)/ZSCALE CALL JSUPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1353 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4-ZLOC CALL JSUPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1361 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GEECDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1362 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GEEPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1363 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GEEPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1364 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GEEHAZ(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1365 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GEECHA(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MAY 2002. 1371 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL TSPCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1372 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL TSPPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1373 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL TSPPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MAY 2002. CCCCC NOTE: FOR THIS DISTRIBUTION, LOCATION AND SCALE ARE CCCCC PART OF THE DEFINITION, SO NO SEPARATE LOCATION CCCCC AND SCALE. 1381 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ARG6=SAVE5 ZLOC=0.0 ZSCALE=1.0 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL BWECDF(ARG1,ARG2,ARG3,ARG4,ARG5,ARG6,RESULT,DRSLT2) TERM=RESULT GOTO9000 C 1382 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ARG6=SAVE5 ZLOC=0.0 ZSCALE=1.0 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL BWECDF(ARG1,ARG2,ARG3,ARG4,ARG5,ARG6,RESULT,DTERM1) CALL BWEHAZ(ARG1,ARG2,ARG3,ARG4,ARG5,ARG6,RESULT,DTERM2) DRSLT2=DTERM2*(1.0D0-DTERM1) TERM=REAL(DRSLT2)/ZSCALE GOTO9000 C 1383 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ARG6=SAVE5 ZLOC=0.0 ZSCALE=1.0 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL BWEPPF(ARG1,ARG2,ARG3,ARG4,ARG5,ARG6,RESULT,DTERM1) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1384 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ARG6=SAVE5 ZLOC=0.0 ZSCALE=1.0 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL BWEHAZ(ARG1,ARG2,ARG3,ARG4,ARG5,ARG6,RESULT,DRSLT2) TERM=RESULT/ZSCALE GOTO9000 C 1385 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ARG6=SAVE5 ZLOC=0.0 ZSCALE=1.0 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL BWECDF(ARG1,ARG2,ARG3,ARG4,ARG5,ARG6,RESULT,DTERM1) DTERM2=1.0D0-DTERM1 DRSLT2=0.0D0 IF(DTERM2.GE.0.0D0)THEN DRSLT2=-DLOG(DTERM2) ELSE WRITE(ICOUT,1386) CALL DPWRST('XXX','BUG ') ENDIF 1386 FORMAT('**** WARNING FROM BWECHAZ: OVERFLOW IN COMPUTATION, ', 1 'CUMULATIVE HAZARD SET TO 0') TERM=REAL(DRSLT2)/ZSCALE GOTO9000 C 1391 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG2.EQ.-99.9)ARG2=0.0 IF(ARG3.EQ.-99.9)ARG3=0.0 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GHCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1392 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG2.EQ.-99.9)ARG2=0.0 IF(ARG3.EQ.-99.9)ARG3=0.0 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL GHPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1393 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(ARG2.EQ.-99.9)ARG2=0.0 IF(ARG3.EQ.-99.9)ARG3=0.0 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GHPPF(ARG1,ARG2,ARG3,RESULT,DBLE(ARG1),DTERM1) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1401 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL SLACDF(ARG1,RESULT) TERM=RESULT GOTO9000 C 1402 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL SLAPDF(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1403 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL SLAPPF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC APRIL 2003: ADD SUPPORT FOR LANDAU DISTRIBUTION 1411 CONTINUE DARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 DARG1=(DARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DRESLT=LANCDF(DARG1) TERM=REAL(DRESLT) GOTO9000 C 1412 CONTINUE DARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 DARG1=(DARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DRESLT=LANPDF(DARG1) TERM=REAL(DRESLT)/ZSCALE GOTO9000 C 1413 CONTINUE DARG1=0.0D0 DARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DRESLT=LANPPF(DARG1) TERM=ZLOC + ZSCALE*REAL(DRESLT) GOTO9000 C 1414 CONTINUE DARG1=DBLE(X) C DRESLT=LANXM1(DARG1) TERM=REAL(DRESLT) GOTO9000 C 1415 CONTINUE DARG1=DBLE(X) C DRESLT=LANXM2(DARG1) TERM=REAL(DRESLT) GOTO9000 C 1416 CONTINUE DARG1=DBLE(X) C DRESLT=LANDIF(DARG1) TERM=REAL(DRESLT) GOTO9000 C 1421 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL IBCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1422 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL IBPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1423 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL IBPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1431 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL ERRCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1432 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 ARG1=(ARG1-ZLOC)/ZSCALE C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL ERRPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1433 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,599) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL ERRPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1441 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 C CALL TRACDF(ARG1,ARG2,ARG3,ARG4,ARG5,RESULT) TERM=RESULT GOTO9000 C 1442 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 C CALL TRAPDF(ARG1,ARG2,ARG3,ARG4,ARG5,RESULT) TERM=RESULT GOTO9000 C 1443 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 C CALL TRAPPF(ARG1,ARG2,ARG3,ARG4,ARG5,RESULT) TERM=RESULT GOTO9000 C 1451 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ARG6=SAVE5 ARG7=SAVE6 ARG8=SAVE7 C CALL GTRCDF(ARG1,ARG2,ARG3,ARG4,ARG5,ARG6,ARG7,ARG8,RESULT) TERM=RESULT GOTO9000 C 1452 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ARG6=SAVE5 ARG7=SAVE6 ARG8=SAVE7 C CALL GTRPDF(ARG1,ARG2,ARG3,ARG4,ARG5,ARG6,ARG7,ARG8,RESULT) TERM=RESULT GOTO9000 C 1453 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ARG6=SAVE5 ARG7=SAVE6 ARG8=SAVE7 C CALL GTRPPF(ARG1,ARG2,ARG3,ARG4,ARG5,ARG6,ARG7,ARG8,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 2003. 1461 CONTINUE ARG1=X ARG2=SAVE1 IARG2=INT(ARG2+0.5) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL FTCDF(ARG1,IARG2,RESULT) TERM=RESULT GOTO9000 C 1462 CONTINUE ARG1=X ARG2=SAVE1 IARG2=INT(ARG2+0.5) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL FTPDF(ARG1,IARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1463 CONTINUE ARG1=X ARG2=SAVE1 IARG2=INT(ARG2+0.5) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL FTPPF(ARG1,IARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 2003. 1471 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL SNCDF(ARG1,ARG2,ISKNDF,RESULT) TERM=RESULT GOTO9000 C 1472 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL SNPDF(ARG1,ARG2,ISKNDF,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1473 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL SNPPF(ARG1,ARG2,ISKNDF,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 2003. 1481 CONTINUE ARG1=X ARG2=SAVE1 IARG2=INT(ARG2+0.5) ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL STCDF(ARG1,IARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1482 CONTINUE ARG1=X ARG2=SAVE1 IARG2=INT(ARG2+0.5) ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL STPDF(ARG1,IARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1483 CONTINUE ARG1=X ARG2=SAVE1 IARG2=INT(ARG2+0.5) ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL STPPF(ARG1,IARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1995. 1491 CONTINUE ARG1=X ARG2=SAVE1 CALL ZETCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1492 CONTINUE ARG1=X ARG2=SAVE1 CALL ZETPDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1493 CONTINUE ARG1=X ARG2=SAVE1 CALL ZETPPF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED DECEMBER, 2003. 1501 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C IF(IMAKDF.EQ.'MEEK')THEN ARG1Z=ARG1/ARG2 ARG2Z=ARG2 ARG3Z=ARG3/ARG1 ARG1=ARG1Z ARG2=ARG2Z ARG3=ARG3Z ENDIF ARG1=(ARG1-ZLOC)/ZSCALE CALL MAKCDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C 1502 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C IF(IMAKDF.EQ.'MEEK')THEN ARG1Z=ARG1/ARG2 ARG2Z=ARG2 ARG3Z=ARG3/ARG1 ARG1=ARG1Z ARG2=ARG2Z ARG3=ARG3Z ENDIF ARG1=(ARG1-ZLOC)/ZSCALE CALL MAKPDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1503 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C IF(IMAKDF.EQ.'MEEK')THEN ARG1Z=ARG1/ARG2 ARG2Z=ARG2 ARG3Z=ARG3/ARG1 ARG1=ARG1Z ARG2=ARG2Z ARG3=ARG3Z ENDIF CALL MAKPPF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1504 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C IF(IMAKDF.EQ.'MEEK')THEN ARG1Z=ARG1/ARG2 ARG2Z=ARG2 ARG3Z=ARG3/ARG1 ARG1=ARG1Z ARG2=ARG2Z ARG3=ARG3Z ENDIF ARG1=(ARG1-ZLOC)/ZSCALE CALL MAKHAZ(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1505 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C IF(IMAKDF.EQ.'MEEK')THEN ARG1Z=ARG1/ARG2 ARG2Z=ARG2 ARG3Z=ARG3/ARG1 ARG1=ARG1Z ARG2=ARG2Z ARG3=ARG3Z ENDIF ARG1=(ARG1-ZLOC)/ZSCALE CALL MAKCHA(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JULY, 2004. 1506 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL MA2CDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1507 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL MA2PDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1508 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL MA2PPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1509 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL MA2HAZ(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1510 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL MA2CHA(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MARCH, 2004. 1511 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LSNCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1512 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LSNPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1513 CONTINUE ARG1=X ARG2=SAVE1 ARG3=1.0 IF(SAVE2.NE.-99.9)ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL LSNPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MARCH, 2004. 1521 CONTINUE ARG1=X IARG1=INT(SAVE1+0.5) ARG2=SAVE2 ARG3=1.0 IF(SAVE3.NE.-99.9)ARG3=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LSTCDF(ARG1,IARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1522 CONTINUE ARG1=X IARG1=INT(SAVE1+0.5) ARG2=SAVE2 ARG3=1.0 IF(SAVE3.NE.-99.9)ARG3=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL LSTPDF(ARG1,IARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1523 CONTINUE ARG1=X IARG1=INT(SAVE1+0.5) ARG2=SAVE2 ARG3=1.0 IF(SAVE3.NE.-99.9)ARG3=SAVE3 ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL LSTPPF(ARG1,IARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C 1531 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL HERCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1532 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL HERPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1533 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL HERPPF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED APRIL, 2004. 1541 CONTINUE DARG1=X DARG2=SAVE1 DARG3=SAVE2 DARG4=SAVE3 CALL GWACDF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1542 CONTINUE DARG1=X DARG2=SAVE1 DARG3=SAVE2 DARG4=SAVE3 CALL GWAPDF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1543 CONTINUE DARG1=X DARG2=SAVE1 DARG3=SAVE2 DARG4=SAVE3 CALL GWAPPF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=DBLE(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 2003. 1551 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL SDECDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1552 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL SDEPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1553 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL SDEPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2004 1561 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL ADECDF(ARG1,ARG2,IADEDF,RESULT) TERM=RESULT GOTO9000 C 1562 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL ADEPDF(ARG1,ARG2,IADEDF,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1563 CONTINUE ARG1=X ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL ADEPPF(ARG1,ARG2,IADEDF,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2004 1571 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL GALCDF(DARG1,DARG2,DARG3,IADEDF,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1572 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL GALPDF(DARG1,DARG2,DARG3,IADEDF,DRESLT) TERM=REAL(DRESLT)/ZSCALE GOTO9000 C 1573 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GALPPF(DARG1,DARG2,DARG3,IADEDF,DRESLT) TERM=ZLOC + ZSCALE*REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2004 1581 CONTINUE ARG1=X ARG2=1.0 IF(SAVE1.NE.-99.9)ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL MAXCDF(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 1582 CONTINUE ARG1=X ARG2=1.0 IF(SAVE1.NE.-99.9)ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL MAXPDF(ARG1,ARG2,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1583 CONTINUE ARG1=X ARG2=1.0 IF(SAVE1.NE.-99.9)ARG2=SAVE1 ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL MAXPPF(ARG1,ARG2,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2004 1591 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CCCCC CALL FERCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1592 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CCCCC CALL FERPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1593 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CCCCC CALL FERPPF(ARG1,ARG2,ARG3,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2004 1601 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL RAYCDF(ARG1,RESULT) TERM=RESULT GOTO9000 C 1602 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C ARG1=(ARG1-ZLOC)/ZSCALE CALL RAYPDF(ARG1,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1603 CONTINUE ARG1=X ZLOC=0.0 IF(SAVE1.NE.-99.9)ZLOC=SAVE1 ZSCALE=1.0 IF(SAVE2.NE.-99.9)ZSCALE=SAVE2 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL RAYPPF(ARG1,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED AUGUST 2004 1611 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL GIGCDF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1612 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL GIGPDF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=REAL(DRESLT)/ZSCALE GOTO9000 C 1613 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GIGPPF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=ZLOC + ZSCALE*REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED AUGUST 2004 1621 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL BEICDF(DARG1,DARG2,DARG3,DARG4,IBEIDF,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1622 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL BEIPDF(DARG1,DARG2,DARG3,DARG4,IBEIDF,DRESLT) TERM=REAL(DRESLT)/ZSCALE GOTO9000 C 1623 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL BEIPPF(DARG1,DARG2,DARG3,DARG4,IBEIDF,DRESLT) TERM=ZLOC + ZSCALE*REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED AUGUST 2004 1631 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CCCCC CALL BEKCDF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1632 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CCCCC CALL BEKPDF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=REAL(DRESLT)/ZSCALE GOTO9000 C 1633 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) ZLOC=0.0 IF(SAVE4.NE.-99.9)ZLOC=SAVE4 ZSCALE=1.0 IF(SAVE5.NE.-99.9)ZSCALE=SAVE5 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CCCCC CALL BEKPPF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=ZLOC + ZSCALE*REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED AUGUST 2004 1641 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL MCLCDF(DARG1,DARG2,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1642 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL MCLPDF(DARG1,DARG2,DRESLT) TERM=REAL(DRESLT)/ZSCALE GOTO9000 C 1643 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL MCLPPF(DARG1,DARG2,DRESLT) TERM=ZLOC + ZSCALE*REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER 2004 1651 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL GMCCDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1652 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL GMCPDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT)/ZSCALE GOTO9000 C 1653 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GMCPPF(DARG1,DARG2,DARG3,DRESLT) TERM=ZLOC + ZSCALE*REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED SEPTEMBER 2004 1661 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL HBOCDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1662 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL HBOPDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT)/ZSCALE GOTO9000 C 1663 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CCCCC CALL HBOPPF(DARG1,DARG2,DARG3,DRESLT) TERM=ZLOC + ZSCALE*REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED FEBRUARY 2006 1671 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=0.0D0 IF(SAVE2.NE.-99.9)DARG3=DBLE(SAVE2) DARG4=1.0D0 IF(SAVE3.NE.-99.9)DARG4=DBLE(SAVE3) C XPAR(1)=DARG3 XPAR(2)=DARG4 XPAR(3)=DARG2 DRESLT=CDFGLO(DARG1,XPAR) TERM=REAL(DRESLT) GOTO9000 C 1672 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=0.0D0 IF(SAVE2.NE.-99.9)DARG3=DBLE(SAVE2) DARG4=1.0D0 IF(SAVE3.NE.-99.9)DARG4=DBLE(SAVE3) C IF(DARG4.LE.0.0D0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DARG3)/DARG4 CALL GL5PDF(DARG1,DARG2,DRESLT) TERM=REAL(DRESLT/DARG4) GOTO9000 C 1673 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=0.0D0 IF(SAVE2.NE.-99.9)DARG3=DBLE(SAVE2) DARG4=1.0D0 IF(SAVE3.NE.-99.9)DARG4=DBLE(SAVE3) C XPAR(1)=DARG3 XPAR(2)=DARG4 XPAR(3)=DARG2 DRESLT=QUAGLO(DARG1,XPAR) TERM=REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED FEBRUARY 2006 1681 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) DARG5=0.0D0 IF(SAVE4.NE.-99.9)DARG5=DBLE(SAVE4) DARG6=1.0D0 IF(SAVE5.NE.-99.9)DARG6=DBLE(SAVE5) C XPAR(1)=DARG5 XPAR(2)=DARG6 XPAR(3)=DARG2 XPAR(4)=DARG3 XPAR(5)=DARG4 DRESLT=CDFWAK(DARG1,XPAR) TERM=REAL(DRESLT) GOTO9000 C 1682 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) DARG5=0.0D0 IF(SAVE4.NE.-99.9)DARG5=DBLE(SAVE4) DARG6=1.0D0 IF(SAVE5.NE.-99.9)DARG6=DBLE(SAVE5) C XPAR(1)=DARG5 XPAR(2)=DARG6 XPAR(3)=DARG2 XPAR(4)=DARG3 XPAR(5)=DARG4 CCCCC DRESLT=CDFGLO(DARG1,XPAR) TERM=REAL(DRESLT) GOTO9000 C 1683 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) DARG5=0.0D0 IF(SAVE4.NE.-99.9)DARG5=DBLE(SAVE4) DARG6=1.0D0 IF(SAVE5.NE.-99.9)DARG6=DBLE(SAVE5) C XPAR(1)=DARG5 XPAR(2)=DARG6 XPAR(3)=DARG2 XPAR(4)=DARG3 XPAR(5)=DARG4 DRESLT=QUAWAK(DARG1,XPAR) TERM=REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED MARCH 2006 1691 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=0.0D0 IF(SAVE3.NE.-99.9)DARG4=DBLE(SAVE3) DARG5=1.0D0 IF(SAVE4.NE.-99.9)DARG5=DBLE(SAVE4) C IF(DARG5.LE.0.0D0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DARG4)/DARG5 CALL BNOCDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1692 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=0.0D0 IF(SAVE3.NE.-99.9)DARG4=DBLE(SAVE3) DARG5=1.0D0 IF(SAVE4.NE.-99.9)DARG5=DBLE(SAVE4) C IF(DARG5.LE.0.0D0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DARG4)/DARG5 CALL BNOPDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT/DARG5) GOTO9000 C 1693 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=0.0D0 IF(SAVE3.NE.-99.9)DARG4=DBLE(SAVE3) DARG5=1.0D0 IF(SAVE4.NE.-99.9)DARG5=DBLE(SAVE4) C IF(DARG5.LE.0.0D0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL BNOPPF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DARG4 + DARG5*DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED MARCH 2006. 1701 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1209) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL GL2CDF(DARG1,DARG2,DRESLT) TERM=REAL(DRESLT/DBLE(ZSCALE)) GOTO9000 C 1702 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1209) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL GL2PDF(DARG1,DARG2,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1703 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1209) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GL2PPF(DARG1,DARG2,DRESLT) DRESLT=DBLE(ZLOC) + DBLE(ZSCALE)*DRESLT TERM=REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED MARCH 2006. 1711 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1209) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL GL3CDF(DARG1,DARG2,DRESLT) TERM=REAL(DRESLT/DBLE(ZSCALE)) GOTO9000 C 1712 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1209) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL GL3PDF(DARG1,DARG2,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1713 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) ZLOC=0.0 IF(SAVE2.NE.-99.9)ZLOC=SAVE2 ZSCALE=1.0 IF(SAVE3.NE.-99.9)ZSCALE=SAVE3 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1209) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GL3PPF(DARG1,DARG2,DRESLT) DRESLT=DBLE(ZLOC) + DBLE(ZSCALE)*DRESLT TERM=REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED MARCH 2006. 1721 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1209) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL GL4CDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT/DBLE(ZSCALE)) GOTO9000 C 1722 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1209) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DBLE(ZLOC))/DBLE(ZSCALE) CALL GL4PDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1723 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) ZLOC=0.0 IF(SAVE3.NE.-99.9)ZLOC=SAVE3 ZSCALE=1.0 IF(SAVE4.NE.-99.9)ZSCALE=SAVE4 C IF(ZSCALE.LE.0.0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,1209) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL GL4PPF(DARG1,DARG2,DARG3,DRESLT) DRESLT=DBLE(ZLOC) + DBLE(ZSCALE)*DRESLT TERM=REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED MARCH 2006 1731 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=0.0D0 IF(SAVE3.NE.-99.9)DARG4=DBLE(SAVE3) DARG5=1.0D0 IF(SAVE4.NE.-99.9)DARG5=DBLE(SAVE4) C IF(DARG5.LE.0.0D0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DARG4)/DARG5 CALL ALDCDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1732 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=0.0D0 IF(SAVE3.NE.-99.9)DARG4=DBLE(SAVE3) DARG5=1.0D0 IF(SAVE4.NE.-99.9)DARG5=DBLE(SAVE4) C IF(DARG5.LE.0.0D0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C DARG1=(DARG1-DARG4)/DARG5 CALL ALDPDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT/DARG5) GOTO9000 C 1733 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=0.0D0 IF(SAVE3.NE.-99.9)DARG4=DBLE(SAVE3) DARG5=1.0D0 IF(SAVE4.NE.-99.9)DARG5=DBLE(SAVE4) C IF(DARG5.LE.0.0D0)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,769) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF C CALL ALDPPF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DARG4 + DARG5*DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED JANUARY, 1996. 1741 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(IBGEDF.EQ.'UNSH')THEN CALL BGECDF(ARG1,ARG2,ARG3,RESULT) ELSE CALL BG2CDF(ARG1,ARG2,ARG3,RESULT) ENDIF TERM=RESULT GOTO9000 C 1742 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(IBGEDF.EQ.'UNSH')THEN CALL BGEPDF(ARG1,ARG2,ARG3,RESULT) ELSE CALL BG2PDF(ARG1,ARG2,ARG3,RESULT) ENDIF TERM=RESULT GOTO9000 C 1743 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 IF(IBGEDF.EQ.'UNSH')THEN CALL BGEPPF(ARG1,ARG2,ARG3,RESULT) ELSE CALL BG2PPF(ARG1,ARG2,ARG3,RESULT) ENDIF TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MAY 2006 1751 CONTINUE ARG1=X ARG2=SAVE1 IARG3=INT(SAVE2) CALL ZIPCDF(ARG1,ARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C 1752 CONTINUE ARG1=X ARG2=SAVE1 IARG3=INT(SAVE2) CALL ZIPPDF(ARG1,ARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C 1753 CONTINUE ARG1=X ARG2=SAVE1 IARG3=INT(SAVE2) CALL ZIPPPF(ARG1,ARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MAY 2006 1761 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL BTACDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1762 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL BTAPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1763 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL BTAPPF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED MAY 2006 1771 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ZLOC=0.0 IF(SAVE5.NE.-99.9)ZLOC=SAVE5 ZSCALE=1.0 IF(SAVE6.NE.-99.9)ZSCALE=SAVE6 ARG1=(ARG1-ZLOC)/ZSCALE CALL LBECDF(ARG1,ARG2,ARG3,ARG4,ARG5,RESULT) TERM=RESULT GOTO9000 C 1772 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ZLOC=0.0 IF(SAVE5.NE.-99.9)ZLOC=SAVE5 ZSCALE=1.0 IF(SAVE6.NE.-99.9)ZSCALE=SAVE6 ARG1=(ARG1-ZLOC)/ZSCALE CALL LBEPDF(ARG1,ARG2,ARG3,ARG4,ARG5,RESULT) TERM=RESULT/ZSCALE GOTO9000 C 1773 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG3=SAVE2 ARG4=SAVE3 ARG5=SAVE4 ZLOC=0.0 IF(SAVE5.NE.-99.9)ZLOC=SAVE5 ZSCALE=1.0 IF(SAVE6.NE.-99.9)ZSCALE=SAVE6 CALL LBEPPF(ARG1,ARG2,ARG3,ARG4,ARG5,RESULT) TERM=ZLOC + ZSCALE*RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2006 1781 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL LPOCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1782 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL LPOPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1783 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL LPOPPF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2006 1791 CONTINUE ARG1=X IARG2=INT(SAVE1+0.5) CALL LCTCDF(ARG1,IARG2,RESULT) TERM=RESULT GOTO9000 C 1792 CONTINUE ARG1=X IARG2=INT(SAVE1+0.5) CALL LCTPDF(ARG1,IARG2,RESULT) TERM=RESULT GOTO9000 C 1793 CONTINUE ARG1=X IARG2=INT(SAVE1+0.5) CALL LCTPPF(ARG1,IARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2006 1801 CONTINUE ARG1=X IARG2=INT(SAVE1+0.5) CALL MATCDF(ARG1,IARG2,RESULT) TERM=RESULT GOTO9000 C 1802 CONTINUE ARG1=X IARG2=INT(SAVE1+0.5) CALL MATPDF(ARG1,IARG2,RESULT) TERM=RESULT GOTO9000 C 1803 CONTINUE ARG1=X IARG2=INT(SAVE1+0.5) CALL MATPPF(ARG1,IARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2006 1811 CONTINUE ARG1=X IARG2=INT(SAVE1+0.5) IARG3=INT(SAVE2+0.5) CCCCC CALL OCCCDF(ARG1,IARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C 1812 CONTINUE ARG1=X IARG2=INT(SAVE1+0.5) IARG3=INT(SAVE2+0.5) CALL OCCPDF(ARG1,IARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C 1813 CONTINUE ARG1=X IARG2=INT(SAVE1+0.5) IARG3=INT(SAVE2+0.5) CCCCC CALL OCCPPF(ARG1,IARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2006 1821 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL PAPCDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1822 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL PAPPDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1823 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL PAPPPF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2006 1831 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CCCCC CALL NEYCDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1832 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CCCCC CALL NEYPDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1833 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CCCCC CALL NEYPPF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2006 1841 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CCCCC CALL DXGCDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1842 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CCCCC CALL DXGPDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1843 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CCCCC CALL DXGPPF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2006 1851 CONTINUE ARG1=X ARG2=SAVE1 IARG3=INT(SAVE2+0.5) CALL LOSCDF(ARG1,ARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C 1852 CONTINUE ARG1=X ARG2=SAVE1 IARG3=INT(SAVE2+0.5) CALL LOSPDF(ARG1,ARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C 1853 CONTINUE ARG1=X ARG2=SAVE1 IARG3=INT(SAVE2+0.5) CALL LOSPPF(ARG1,ARG2,IARG3,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2006 1861 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL GLSCDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1862 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL GLSPDF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1863 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL GLSPPF(ARG1,ARG2,ARG3,RESULT) TERM=RESULT GOTO9000 C 1871 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL GETCDF(DARG1,DARG2,DARG3,IGETDF,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1872 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL GETPDF(DARG1,DARG2,DARG3,IGETDF,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1873 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL GETPPF(DARG1,DARG2,DARG3,IGETDF,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1881 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 CALL GNBCDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C 1882 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 CALL GNBPDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C 1883 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 CALL GNBPPF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2006 1891 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CCCCC CALL PIGCDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1892 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL PIGPDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1893 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CCCCC CALL PIGPPF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1901 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 CALL QBICDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C 1902 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 CALL QBIPDF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C 1903 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 CALL QBIPPF(ARG1,ARG2,ARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C 1911 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL CONCDF(DARG1,DARG2,DARG3,ICONDF,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1912 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL CONPDF(DARG1,DARG2,DARG3,ICONDF,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1913 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL CONPPF(DARG1,DARG2,DARG3,ICONDF,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1921 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) CALL LKCDF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1922 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) CALL LKPDF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1923 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) DARG4=DBLE(SAVE3) CALL LKPPF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1931 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=0.0D0 DARG4=DBLE(SAVE2) CALL LKCDF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1932 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=0.0D0 DARG4=DBLE(SAVE2) CALL LKPDF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1933 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=0.0D0 DARG4=DBLE(SAVE2) CALL LKPPF(DARG1,DARG2,DARG3,DARG4,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1941 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL DIWCDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1942 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL DIWPDF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1943 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL DIWPPF(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C 1944 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) DARG3=DBLE(SAVE2) CALL DIWHAZ(DARG1,DARG2,DARG3,DRESLT) TERM=REAL(DRESLT) GOTO9000 C CCCCC FOLLOWING SECTION ADDED JUNE 2006 1951 CONTINUE ARG1=X ARG2=SAVE1 IARG3=INT(SAVE2+0.5) ARG4=SAVE3 CALL GLGCDF(ARG1,ARG2,IARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C 1952 CONTINUE ARG1=X ARG2=SAVE1 IARG3=INT(SAVE2+0.5) ARG4=SAVE3 CALL GLGPDF(ARG1,ARG2,IARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C 1953 CONTINUE ARG1=X ARG2=SAVE1 IARG3=INT(SAVE2+0.5) ARG4=SAVE3 CALL GLGPPF(ARG1,ARG2,IARG3,ARG4,RESULT) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2000 CONTINUE DARG1=DBLE(X) IARG2=1 RESULT=DFRENC(DARG1,IARG2) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2010 CONTINUE DARG1=DBLE(X) IARG2=2 RESULT=DFRENC(DARG1,IARG2) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2020 CONTINUE DARG1=DBLE(X) IARG2=3 RESULT=DFRENC(DARG1,IARG2) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2030 CONTINUE DARG1=DBLE(X) IARG2=4 RESULT=DFRENC(DARG1,IARG2) TERM=RESULT GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2100 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=REAL(PEQ(Z1)) GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2105 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=AIMAG(PEQ(Z1)) GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2110 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=REAL(PEQ1(Z1)) GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2115 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=AIMAG(PEQ1(Z1)) GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2120 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=REAL(PLEM(Z1)) GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2125 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=AIMAG(PLEM(Z1)) GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2130 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=REAL(PLEM1(Z1)) GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2135 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=AIMAG(PLEM1(Z1)) GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2200 CONTINUE ARG1=X ARG2=SAVE1 CALL JACELL(ARG1,ARG2,RESLT1,RESLT2,RESLT3) TERM=RESLT1 GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2210 CONTINUE ARG1=X ARG2=SAVE1 CALL JACELL(ARG1,ARG2,RESLT1,RESLT2,RESLT3) TERM=RESLT2 GOTO9000 C CCCCC FOLLOWING SECTION ADDED NOVEMBER, 1994. 2220 CONTINUE ARG1=X ARG2=SAVE1 CALL JACELL(ARG1,ARG2,RESLT1,RESLT2,RESLT3) TERM=RESLT3 GOTO9000 C 5000 CONTINUE ARG=X TERM=C00 GOTO9000 C 5010 CONTINUE ARG=X TERM=(C11*ARG) GOTO9000 C 5020 CONTINUE ARG=X TERM=(C22*ARG**2)+C20 GOTO9000 C 5030 CONTINUE ARG=X TERM=(C33*ARG**3)+(C31*ARG) GOTO9000 C 5040 CONTINUE ARG=X TERM=(C44*ARG**4)+(C42*ARG**2)+C40 GOTO9000 C 5050 CONTINUE ARG=X TERM=(C55*ARG**5)+(C53*ARG**3)+(C51*ARG) GOTO9000 C 5060 CONTINUE ARG=X TERM=(C66*ARG**6)+(C64*ARG**4)+(C62*ARG**2)+C60 GOTO9000 C 5070 CONTINUE ARG=X TERM=(C77*ARG**7)+(C75*ARG**5)+(C73*ARG**3)+(C71*ARG) GOTO9000 C 5080 CONTINUE ARG=X TERM=(C88*ARG**8)+(C86*ARG**6)+(C84*ARG**4)+(C82*ARG**2) 1 +C80 GOTO9000 C 5090 CONTINUE ARG=X TERM=(C99*ARG**9)+(C97*ARG**7)+(C95*ARG**5)+(C93*ARG**3) 1 +(C91*ARG) GOTO9000 C 5100 CONTINUE ARG=X TERM=(C1010*ARG**10)+(C108*ARG**8)+(C106*ARG**6) 1 +(C104*ARG**4)+(C102*ARG**2)+C100 GOTO9000 C CCCCC JULY 1995. ADD CHEBCHEV T POLYNOMIAL 5110 CONTINUE ARG1=X ARG2=SAVE1 CALL CHEBT(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC JULY 1995. ADD CHEBCHEV U POLYNOMIAL 5120 CONTINUE ARG1=X ARG2=SAVE1 CALL CHEBU(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC JULY 1995. ADD NORMALIZED LAGUERRE POLYNOMIAL 5130 CONTINUE ARG1=X ARG2=SAVE1 CALL NRMLAG(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC JULY 1995. ADD JACOBI POLYNOMIAL 5140 CONTINUE DARG1=DBLE(X) IARG1=INT(SAVE1+0.5) DARG2=DBLE(SAVE2) DARG3=DBLE(SAVE3) C C NOTE THAT JACOBP RETURNS DERIVATIVE AND RELATIVE OR ABSOLUTE C ERROR TERMS. AT THIS POINT, DATAPLOT DOESN'T MAKE USE OF THIS C INFORMATION. HOWEVER, LEAVE OUTPUT ARGUMENTS IN CASE WE DECIDE C TO IMPLEMENT SOME THINGS LATER. C CALL JACOBP(IARG1,DARG2,DARG3,DARG1,DRESLT,DRSLT2, 1E,ED,IOUT1,IOUT2) TERM=SNGL(DRESLT) GOTO9000 C CCCCC JULY 1995. ADD ULTRASPHERICAL (OR GEGENBAUER) POLYNOMIAL 5150 CONTINUE DARG1=DBLE(X) IARG1=INT(SAVE1+0.5) DARG2=DBLE(SAVE2-0.5) DARG3=DBLE(SAVE2-0.5) C C NOTE THAT JACOBP RETURNS DERIVATIVE AND RELATIVE OR ABSOLUTE C ERROR TERMS. AT THIS POINT, DATAPLOT DOESN'T MAKE USE OF THIS C INFORMATION. HOWEVER, LEAVE OUTPUT ARGUMENTS IN CASE WE DECIDE C TO IMPLEMENT SOME THINGS LATER. C CALL JACOBP(IARG1,DARG2,DARG3,DARG1,DRESLT,DRSLT2, 1E,ED,IOUT1,IOUT2) C DTERM1=DGAMMA(DBLE(SAVE2+0.5)) DTERM2=DGAMMA(DBLE(2.*SAVE2+REAL(IARG1))) DTERM3=DGAMR(DBLE(2.0*SAVE2)) DTERM4=DGAMR(DBLE(SAVE2+REAL(IARG1)+0.5)) DTERM5=DTERM1*DTERM2*DTERM3*DTERM4 DTERM5=DTERM5*DRESLT C TERM=SNGL(DTERM5) GOTO9000 C CCCCC JULY 1995. ADD GENERALIZED LAGUERRE POLYNOMIAL 5160 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL LAGUEL(ARG1,ARG2,ARG3,'NONO',RESULT) TERM=RESULT GOTO9000 C CCCCC JULY 1995. ADD NORMALIZED GENERALIZED LAGUERRE POLYNOMIAL 5170 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 CALL LAGUEL(ARG1,ARG2,ARG3,'NORM',RESULT) TERM=RESULT GOTO9000 C CCCCC JULY 1995. ADD LEGENDRE POLYNOMIAL (NORMALIZED) CCCCC NOTE THAT IN THIS CASE THE INPUT IS THETA (I.E., THE CCCCC ANGLE) RATHER THAN X. THIS IS BECAUSE USING THETA GIVES CCCCC BETTER ACCURACY. 5180 CONTINUE DARG1=DBLE(X) IF(IANGLU.EQ.'DEGR')DARG1=DARG1*DPI/180.D0 C IF(DARG1.LT.-DPI .OR. DARG1.GT.DPI)THEN WRITE(ICOUT,5181) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5182)X CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF ISWTCH=0.0 IF(DARG1.GT.(DPI/2.D0))ISWTCH=1 IF(ISWTCH.EQ.1)DARG1=DPI-DARG1 5181 FORMAT('***** ERROR FOR NRMLEG. THE FIRST INPUT ARGUMENT IS ', 1'OUTSIDE THE ALLOWABLE (-PI,PI) INTERVAL.') 5182 FORMAT(' IT HAS THE VALUE ',E15.7) IARG1=INT(SAVE1+0.5) IF(IARG1.LT.0)THEN WRITE(ICOUT,5183) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5184)IARG1 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5183 FORMAT('***** ERROR FOR NRMLEG. THE SECOND INPUT ARGUMENT IS ', 1'NEGATIVE.') 5184 FORMAT(' IT HAS THE VALUE ',I15) C IARG2=0 IARG3=2 CALL DXNRMP(IARG1,IARG2,IARG2,DARG1,IARG3,DPN,IPN,ISIG,IERR2) IF(ISWTCH.EQ.1)DPN(1)=DPN(1)*(-1.D0)**(IARG1+IARG2) TERM=0.0 IF(IERR2.EQ.0)THEN DRESLT=DPN(1) IF(IPN(1).EQ.0)THEN IF(ABS(DRESLT).GT.DBLE(R1MACH(2)))THEN IF(DRESLT.GE.0.D0)TERM=R1MACH(2) IF(DRESLT.LT.0.D0)TERM=-R1MACH(2) ELSE TERM=SNGL(DRESLT) ENDIF ELSE IF(IPN(1).GT.0)THEN TERM=R1MACH(2) WRITE(ICOUT,5185) CALL DPWRST('XXX','BUG ') ELSE TERM=0. WRITE(ICOUT,5189) CALL DPWRST('XXX','BUG ') ENDIF ENDIF ELSEIF(IERR2.EQ.212 .OR. IERR2.EQ.213)THEN TERM=0.0 WRITE(ICOUT,5186) CALL DPWRST('XXX','BUG ') ELSEIF(IERR2.GE.201.AND.IERR2.LE.204)THEN TERM=0.0 WRITE(ICOUT,5187) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,5188) CALL DPWRST('XXX','BUG ') TERM=0.0 ENDIF GOTO9000 5185 FORMAT('***** WARNING FROM NRMLEG. CALCULATED VALUE OUTSIDE ', 1'VALID MACHINE RANGE. VALUE SET TO MACHINE MAXIMUM.') 5186 FORMAT('***** ERROR FROM NRMLEG. INVALID INPUT.') 5187 FORMAT('***** ERROR FROM NRMLEG. INVALID DXSET, CONTACT YOUR ', 1'LOCAL SITE INSTALLER.') 5188 FORMAT('***** ERROR FROM NRMLEG. UNABLE TO PERFORM THE ', 1'CALCULATIONS CORRECTLY, OUTPUT SET TO ZERO.') 5189 FORMAT('***** WARNING FROM NRMLEG. CALCULATED VALUE OUTSIDE ', 1'VALID MACHINE RANGE. VALUE SET TO 0.') C CCCCC JULY 1995. ADD ASSOCIATED LEGENDRE POLYNOMIAL (NORMALIZED) CCCCC NOTE THAT IN THIS CASE THE INPUT IS THEATA (I.E., THE CCCCC ANGLE) RATHER THAN X. THIS IS BECAUSE USING THETA GIVES CCCCC BETTER ACCURACY. 5200 CONTINUE DARG1=DBLE(X) IF(IANGLU.EQ.'DEGR')DARG1=DARG1*DPI/180.D0 C IF(DARG1.LT.-DPI.OR.DARG1.GT.DPI)THEN WRITE(ICOUT,5201) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5202)X CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5201 FORMAT('***** ERROR FOR NRMLEG. THE FIRST INPUT ARGUMENT IS ', 1'OUTSIDE THE ALLOWABLE (-DPI,DPI) INTERVAL.') 5202 FORMAT(' IT HAS THE VALUE ',E15.7) ISWTCH=0.0 IF(DARG1.GT.(DPI/2.D0))ISWTCH=1 IF(ISWTCH.EQ.1)DARG1=DPI-DARG1 C IARG1=INT(SAVE1+0.5) IF(IARG1.LT.0)THEN WRITE(ICOUT,5203) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5204)IARG1 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5203 FORMAT('***** ERROR FOR NRMLEG. THE SECOND INPUT ARGUMENT IS ', 1'NEGATIVE.') 5204 FORMAT(' IT HAS THE VALUE ',I15) C IARG2=INT(SAVE2+0.5) IF(IARG2.LT.0)THEN WRITE(ICOUT,5213) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5204)IARG1 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5213 FORMAT('***** ERROR FOR NRMLEG. THE THIRD INPUT ARGUMENT IS ', 1'NEGATIVE.') IARG3=IARG2 IARG4=2 CALL DXNRMP(IARG1,IARG2,IARG3,DARG1,IARG4,DPN,IPN,ISIG,IERR2) IF(ISWTCH.EQ.1)DPN(1)=DPN(1)*(-1.D0)**(IARG1+IARG2) TERM=0.0 IF(IERR2.EQ.0)THEN DRESLT=DPN(1) IF(IPN(1).EQ.0)THEN IF(ABS(DRESLT).GT.DBLE(R1MACH(2)))THEN IF(DRESLT.GE.0.D0)TERM=R1MACH(2) IF(DRESLT.LT.0.D0)TERM=-R1MACH(2) ELSE TERM=SNGL(DRESLT) ENDIF ELSE IF(IPN(1).GT.0)THEN TERM=R1MACH(2) WRITE(ICOUT,5205) CALL DPWRST('XXX','BUG ') ELSE TERM=0. WRITE(ICOUT,5209) CALL DPWRST('XXX','BUG ') ENDIF ENDIF ELSEIF(IERR2.EQ.212 .OR. IERR2.EQ.213)THEN TERM=0.0 WRITE(ICOUT,5206) CALL DPWRST('XXX','BUG ') ELSEIF(IERR2.GE.201.AND.IERR2.LE.204)THEN TERM=0.0 WRITE(ICOUT,5207) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,5208) CALL DPWRST('XXX','BUG ') TERM=0.0 ENDIF GOTO9000 5205 FORMAT('***** WARNING FROM NRMLEG. CALCULATED VALUE OUTSIDE ', 1'VALID MACHINE RANGE. VALUE SET TO MACHINE MAXIMUM.') 5206 FORMAT('***** ERROR FROM NRMLEG. INVALID INPUT.') 5207 FORMAT('***** ERROR FROM NRMLEG. INVALID DXSET, CONTACT YOUR', 1' LOCAL SITE INSTALLER.') 5208 FORMAT('***** ERROR FROM NRMLEG. UNABLE TO PERFORM THE ', 1'CALCULATIONS CORRECTLY, OUTOUT SET TO ZERO.') 5209 FORMAT('***** WARNING FROM NRMLEG. CALCULATED VALUE OUTSIDE ', 1'VALID MACHINE RANGE. VALUE SET TO 0.') C CCCCC JULY 1995. ADD ASSOCIATED LEGENDRE FUNCTION OF THE FIRST KIND. CCCCC REDUCES TO LEGENDRE FUNCTION OF FIRST KIND IF M NOT SPECIFIED CCCCC (OR IS EQUAL TO ZERO). CCCCC NOTE THAT IN THIS CASE THE INPUT IS THEATA (I.E., THE CCCCC ANGLE) RATHER THAN X. THIS IS BECAUSE USING THETA GIVES CCCCC BETTER ACCURACY. 5220 CONTINUE DARG1=DBLE(X) IF(IANGLU.EQ.'DEGR')DARG1=DARG1*DPI/180.D0 C IF(DARG1.LT.0.D0.OR.DARG1.GE.DPI/2.0D0)THEN WRITE(ICOUT,5221) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5222)X CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5221 FORMAT('***** ERROR FOR LEGP. THE FIRST INPUT ARGUMENT IS ', 1'OUTSIDE THE ALLOWABLE (0,PI/2) INTERVAL.') 5222 FORMAT(' IT HAS THE VALUE ',E15.7) C DARG2=DBLE(SAVE1) IF(DARG2.LT.-0.5D0)THEN WRITE(ICOUT,5223) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5224)DARG2 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5223 FORMAT('***** ERROR FOR LEGP. THE SECOND INPUT ARGUMENT IS ', 1'LESS THAN -0.5.') 5224 FORMAT(' IT HAS THE VALUE ',I15) C IF(SAVE2.EQ.-99.9)THEN IARG2=0 ELSE IARG2=INT(SAVE2+0.5) ENDIF IARG1=0 IARG3=IARG2 IARG4=3 IF(DARG2.LT.0.D0)IARG4=1 IF(IARG2.LT.0)THEN IARG2=-IARG2 IARG3=IARG2 IARG4=1 ENDIF CALL DXLEGF(DARG2,IARG1,IARG2,IARG3,DARG1,IARG4,DPN,IPN,IERR2) TERM=0.0 IF(IERR2.EQ.0)THEN DRESLT=DPN(1) IF(IPN(1).EQ.0)THEN IF(DRESLT.GT.R1MACH(2))TERM=R1MACH(2) IF(DRESLT.LE.R1MACH(2))TERM=SNGL(DRESLT) ELSE TERM=R1MACH(2) WRITE(ICOUT,5225) CALL DPWRST('XXX','BUG ') ENDIF ELSEIF(IERR2.EQ.212 .OR. IERR2.EQ.213)THEN TERM=0.0 WRITE(ICOUT,5226) CALL DPWRST('XXX','BUG ') ELSEIF(IERR2.GE.201.AND.IERR2.LE.204)THEN TERM=0.0 WRITE(ICOUT,5227) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,5228) CALL DPWRST('XXX','BUG ') TERM=0.0 ENDIF GOTO9000 5225 FORMAT('***** WARNING FROM LEGP. CALCULATED VALUE OUTSIDE ', 1'VALID MACHINE RANGE. VALUE SET TO MACHINE MAXIMUM.') 5226 FORMAT('***** ERROR FROM LEGP. INVALID INPUT.') 5227 FORMAT('***** ERROR FROM LEGP. INVALID DXSET, CONTACT YOUR ', 1'LOCAL SITE INSTALLER.') 5228 FORMAT('***** ERROR FROM LEGP. UNABLE TO PERFORM THE ', 1'CALCULATIONS CORRECTLY, OUTOUT SET TO ZERO.') C CCCCC JULY 1995. ADD ASSOCIATED LEGENDRE FUNCTION OF THE SECOND KIND. CCCCC REDUCES TO LEGENDRE FUNCTION OF FIRST KIND IF M NOT SPECIFIED CCCCC (OR IS EQUAL TO ZERO). CCCCC NOTE THAT IN THIS CASE THE INPUT IS THEATA (I.E., THE CCCCC ANGLE) RATHER THAN X. THIS IS BECAUSE USING THETA GIVES CCCCC BETTER ACCURACY. 5240 CONTINUE DARG1=DBLE(X) IF(IANGLU.EQ.'DEGR')DARG1=DARG1*DPI/180.D0 C IF(DARG1.LE.0.D0.OR.DARG1.GE.DPI/2.D0)THEN WRITE(ICOUT,5241) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5242)X CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5241 FORMAT('***** ERROR FOR LEGQ. THE FIRST INPUT ARGUMENT IS ', 1'OUTSIDE THE ALLOWABLE (0,PI/2) INTERVAL.') 5242 FORMAT(' IT HAS THE VALUE ',E15.7) C DARG2=DBLE(SAVE1) IF(DARG2.LT.-0.5D0)THEN WRITE(ICOUT,5243) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5244)DARG2 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5243 FORMAT('***** ERROR FOR LEGQ. THE SECOND INPUT ARGUMENT IS ', 1'LESS THAN -0.5.') 5244 FORMAT(' IT HAS THE VALUE ',I15) C IF(SAVE2.EQ.-99.9)THEN IARG2=0 ELSE IARG2=INT(SAVE2+0.5) ENDIF IF(IARG2.LT.0)THEN WRITE(ICOUT,5253) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5254)SAVE2 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5253 FORMAT('***** ERROR FOR LEGQ. THE THIRD INPUT ARGUMENT IS ', 1'NEGATIVE.') 5254 FORMAT(' IT HAS THE VALUE ',E15.7) C IARG1=0 IARG3=IARG2 IARG4=2 CALL DXLEGF(DARG2,IARG1,IARG2,IARG3,DARG1,IARG4,DPN,IPN,IERR2) TERM=0.0 IF(IERR2.EQ.0)THEN DRESLT=DPN(1) IF(IPN(1).EQ.0)THEN IF(DRESLT.GT.R1MACH(2))TERM=R1MACH(2) IF(DRESLT.LE.R1MACH(2))TERM=SNGL(DRESLT) ELSE TERM=R1MACH(2) WRITE(ICOUT,5245) CALL DPWRST('XXX','BUG ') ENDIF ELSEIF(IERR2.EQ.212 .OR. IERR2.EQ.213)THEN TERM=0.0 WRITE(ICOUT,5246) CALL DPWRST('XXX','BUG ') ELSEIF(IERR2.GE.201.AND.IERR2.LE.204)THEN TERM=0.0 WRITE(ICOUT,5247) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,5248) CALL DPWRST('XXX','BUG ') TERM=0.0 ENDIF GOTO9000 5245 FORMAT('***** WARNING FROM LEGQ. CALCULATED VALUE OUTSIDE ', 1'VALID MACHINE RANGE. VALUE SET TO MACHINE MAXIMUM.') 5246 FORMAT('***** ERROR FROM LEGQ. INVALID INPUT.') 5247 FORMAT('***** ERROR FROM LEGQ. INVALID DXSET, CONTACT YOUR ', 1'LOCAL SITE INSTALLER.') 5248 FORMAT('***** ERROR FROM LEGQ. UNABLE TO PERFORM THE ', 1'CALCULATIONS CORRECTLY, OUTOUT SET TO ZERO.') C CCCCC JULY 1995. ADD ASSOCIATED LEGENDRE POLYNOMIAL OF THE FIRST KIND. CCCCC REDUCES TO LEGENDRE POLYNOMIAL OF FIRST KIND IF M NOT SPECIFIED CCCCC (OR IS EQUAL TO ZERO). THIS IS THE UNNORMALIZED CASE. CCCCC NOTE THAT IN THIS CASE THE INPUT IS THEATA (I.E., THE CCCCC ANGLE) RATHER THAN X. THIS IS BECAUSE USING THETA GIVES CCCCC BETTER ACCURACY. 5280 CONTINUE DARG1=DBLE(X) IF(IANGLU.EQ.'DEGR')DARG1=DARG1*DPI/180.D0 C IF(DARG1.LE.-DPI.OR.DARG1.GE.DPI)THEN WRITE(ICOUT,5281) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5282)X CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5281 FORMAT('***** ERROR FOR LEGENDRE. THE FIRST INPUT ARGUMENT IS ', 1'OUTSIDE THE ALLOWABLE (-PI,PI) INTERVAL.') 5282 FORMAT(' IT HAS THE VALUE ',E15.7) ISWTCH=0.0 IF(DARG1.GT.(DPI/2.D0))ISWTCH=1 IF(ISWTCH.EQ.1)DARG1=DPI-DARG1 C ITEMP=INT(SAVE1+0.5) DARG2=DBLE(ITEMP) IF(DARG2.LT.-0.1D0)THEN WRITE(ICOUT,5283) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5284)DARG2 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5283 FORMAT('***** ERROR FOR LEGENDRE. THE SECOND INPUT ARGUMENT IS', 1' NEGATIVE.') 5284 FORMAT(' IT HAS THE VALUE ',I15) C IF(SAVE2.EQ.-99.9)THEN IARG2=0 ELSE IARG2=INT(SAVE2+0.5) ENDIF IARG1=0 IARG3=IARG2 IARG4=3 CALL DXLEGF(DARG2,IARG1,IARG2,IARG3,DARG1,IARG4,DPN,IPN,IERR2) IF(ISWTCH.EQ.1)DPN(1)=DPN(1)*(-1.D0)**(INT(DARG2)+IARG2) TERM=0.0 IF(IERR2.EQ.0)THEN DRESLT=DPN(1) IF(IPN(1).EQ.0)THEN IF(DRESLT.GT.R1MACH(2))TERM=R1MACH(2) IF(DRESLT.LE.R1MACH(2))TERM=SNGL(DRESLT) ELSE TERM=R1MACH(2) WRITE(ICOUT,5285) CALL DPWRST('XXX','BUG ') ENDIF ELSEIF(IERR2.EQ.212 .OR. IERR2.EQ.213)THEN TERM=0.0 WRITE(ICOUT,5286) CALL DPWRST('XXX','BUG ') ELSEIF(IERR2.GE.201.AND.IERR2.LE.204)THEN TERM=0.0 WRITE(ICOUT,5287) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,5288) CALL DPWRST('XXX','BUG ') TERM=0.0 ENDIF GOTO9000 5285 FORMAT('***** WARNING FROM LEGENDRE. CALCULATED VALUE OUTSIDE ', 1'VALID MACHINE RANGE. VALUE SET TO MACHINE MAXIMUM.') 5286 FORMAT('***** ERROR FROM LEGENDRE. INVALID INPUT.') 5287 FORMAT('***** ERROR FROM LEGENDRE. INVALID DXSET, CONTACT YOUR', 1' LOCAL SITE INSTALLER.') 5288 FORMAT('***** ERROR FROM LEGENDRE. UNABLE TO PERFORM THE ', 1'CALCULATIONS CORRECTLY, OUTOUT SET TO ZERO.') C CCCCC JULY 1995. ADD SHPERICAL HARMONICS. BASED ON ASSOCIATED CCCCC LEGENDRE POLYNOMIALS. 5300 CONTINUE DARG1=DBLE(X) IF(IANGLU.EQ.'DEGR')DARG1=DARG1*DPI/180.D0 C IF(DARG1.LT.-DPI.OR.DARG1.GT.DPI)THEN WRITE(ICOUT,5301) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5302)X CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5301 FORMAT('***** ERROR FOR SPHRHRMR. THE FIRST INPUT ARGUMENT IS ', 1'OUTSIDE THE ALLOWABLE (-DPI,DPI) INTERVAL.') 5302 FORMAT(' IT HAS THE VALUE ',E15.7) DARG2=DBLE(SAVE1) IF(IANGLU.EQ.'DEGR')DARG2=DARG2*DPI/180.D0 C IF(DARG2.LT.0.OR.DARG2.GT.2.0D0*DPI)THEN WRITE(ICOUT,5311) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5302)SAVE1 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5311 FORMAT('***** ERROR FOR SPHRHRMR. THE SECOND INPUT ARGUMENT IS', 1' OUTSIDE THE ALLOWABLE (0,2*PI) INTERVAL.') C IARG1=INT(SAVE2+0.5) IF(IARG1.LT.0)THEN WRITE(ICOUT,5303) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5304)IARG1 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5303 FORMAT('***** ERROR FOR SPHRHRM. THE THIRD INPUT ARGUMENT IS', 1' NEGATIVE.') 5304 FORMAT(' IT HAS THE VALUE ',I15) C IARG2=INT(SAVE3+0.5) IF(ABS(IARG2).GT.IARG1)THEN WRITE(ICOUT,5313) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,5314)IARG1,IARG2 CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 5313 FORMAT('***** ERROR FOR SPHRHRM. THE FOURTH INPUT ARGUMENT IS ', 1'LARGER THAN THE THIRD ARGUMENT.') 5314 FORMAT(' THEY HAVE THE VALUES: ',I15,1X,I15) IF(IARG2.LT.0)THEN ISWTCH=1 IARG2=-IARG2 ELSE ISWTCH=0 ENDIF IARG3=IARG2 IARG4=2 CALL DXNRMP(IARG1,IARG2,IARG3,DARG1,IARG4,DPN,IPN,ISIG,IERR2) C TERM=0.0 C IF(IERR2.EQ.0)THEN IF(IPN(1).EQ.0)THEN IF(ABS(DRESLT).GT.DBLE(R1MACH(2)))THEN IF(DRESLT.GE.0.D0)TERM=R1MACH(2) IF(DRESLT.LT.0.D0)TERM=-R1MACH(2) ELSE DTERM1=(-1.D0)**IARG2*DSQRT(1.0D0/(2.D0*DPI)) DRESLT=DTERM1*DPN(1) DTERM1=DBLE(IARG2)*DARG2 IF(ISJUNK.EQ.0)THEN DTERM2=DRESLT*DCOS(DTERM1) TERM=REAL(DTERM2) ELSE DTERM2=DRESLT*DSIN(DTERM1) TERM=REAL(DTERM2) ENDIF IF(ISWTCH.EQ.1)TERM=(-1.**IARG2)*TERM ENDIF ELSE IF(IPN(1).GT.0)THEN TERM=R1MACH(2) WRITE(ICOUT,5305) CALL DPWRST('XXX','BUG ') ELSE TERM=0. WRITE(ICOUT,5309) CALL DPWRST('XXX','BUG ') ENDIF ENDIF ELSEIF(IERR2.EQ.212 .OR. IERR2.EQ.213)THEN TERM=0.0 WRITE(ICOUT,5306) CALL DPWRST('XXX','BUG ') ELSEIF(IERR2.GE.201.AND.IERR2.LE.204)THEN TERM=0.0 WRITE(ICOUT,5307) CALL DPWRST('XXX','BUG ') ELSE WRITE(ICOUT,5308) CALL DPWRST('XXX','BUG ') TERM=0.0 ENDIF GOTO9000 5305 FORMAT('***** WARNING FROM SPHRHRM. CALCULATED VALUE OUTSIDE ', 1'VALID MACHINE RANGE. VALUE SET TO MACHINE MAXIMUM.') 5306 FORMAT('***** ERROR FROM SPHRHRM. INVALID INPUT.') 5307 FORMAT('***** ERROR FROM SPHRHRM. INVALID DXSET, CONTACT YOUR', 1' LOCAL SITE INSTALLER.') 5308 FORMAT('***** ERROR FROM SPHRHRM. UNABLE TO PERFORM THE ', 1'CALCULATIONS CORRECTLY, OUTOUT SET TO ZERO.') 5309 FORMAT('***** WARNING FROM SPHRHRM. CALCULATED VALUE OUTSIDE ', 1'VALID MACHINE RANGE. VALUE SET TO 0.') C CCCCC USE SLATEC ROUTINE SINCE IT HANDLES ANY REAL X (NOT LIMITED TO CCCCC (-3,INF). 6000 CONTINUE ARG=X RESULT=BESJ0(X) TERM=RESULT CCCCC IF(-3.0.LE.ARG.AND.ARG.LE.3.0)GOTO6001 CCCCC IF(3.0.LE.ARG)GOTO6002 CCCCC WRITE(ICOUT,6009) 6009 FORMAT('BESS0 BESSEL FUNCTION ARGUMENT NOT IN (-3,INFINITY) ') CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO9000 C 6001 CONTINUE CCCCC ARG1=ARG/3.0 CCCCC RESULT=(D012*ARG1**12)+(D010*ARG1**10)+(D08*ARG1**8) CCCCC1 +(D06*ARG1**6)+(D04*ARG1**4)+(D02*ARG1**2)+D00 CCCCC TERM=RESULT CCCCC GOTO9000 C 6002 CONTINUE CCCCC ARG2=3.0/ARG CCCCC F0=(F06*ARG2**6)+(F05*ARG2**5)+(F04*ARG2**4) CCCCC1 +(F03*ARG2**3)+(F02*ARG2**2)+(F01*ARG2**1)+F00 CCCCC G0=(G06*ARG2**6)+(G05*ARG2**5)+(G04*ARG2**4) CCCCC1 +(G03*ARG2**3)+(G02*ARG2**2)+(G01*ARG2**1)+G00 CCCCC THETA0=ARG+G0 CCCCC RESULT=(1.0/SQRT(ARG))*F0*COS(THETA0) CCCCC TERM=RESULT GOTO9000 C CCCCC USE SLATEC ROUTINE SINCE IT HANDLES ANY REAL X (NOT LIMITED TO CCCCC (-3,INF). 6010 CONTINUE ARG=X RESULT=BESJ1(X) TERM=RESULT CCCCC IF(-3.0.LE.ARG.AND.ARG.LE.3.0)GOTO6011 CCCCC IF(3.0.LE.ARG)GOTO6012 CCCCC WRITE(ICOUT,6019) 6019 FORMAT('BESS1 BESSEL FUNCTION ARGUMENT NOT IN (-3,INFINITY) ') CCCCC CALL DPWRST('XXX','BUG ') CCCCC GOTO9000 6011 CONTINUE CCCCC ARG1=ARG/3.0 CCCCC RESULT=(D112*ARG1**12)+(D110*ARG1**10)+(D18*ARG1**8) CCCCC1 +(D16*ARG1**6)+(D14*ARG1**4)+(D12*ARG1**2)+D10 CCCCC RESULT=ARG*RESULT CCCCC TERM=RESULT CCCCC GOTO9000 6012 CONTINUE CCCCC ARG2=3.0/ARG CCCCC F1=(F16*ARG2**6)+(F15*ARG2**5)+(F14*ARG2**4) CCCCC1 +(F13*ARG2**3)+(F12*ARG2**2)+(F11*ARG2**1)+F10 CCCCC G1=(G16*ARG2**6)+(G15*ARG2**5)+(G14*ARG2**4) CCCCC1 +(G13*ARG2**3)+(G12*ARG2**2)+(G11*ARG2**1)+G10 CCCCC THETA1=ARG+G1 CCCCC RESULT=(1.0/SQRT(ARG))*F1*COS(THETA1) CCCCC TERM=RESULT GOTO9000 C CCCCC THE FOLLOWING SECTIONS (6100 TO 6700) WERE ADDED SEPTEMBER 1994 6100 CONTINUE ARG1=X RESULT=BESY0(ARG1) TERM=RESULT GOTO9000 C 6150 CONTINUE ARG1=X RESULT=BESY1(ARG1) TERM=RESULT GOTO9000 C 6200 CONTINUE DARG1=DBLE(X) DRESLT=DBESI0(DARG1) TERM=SNGL(DRESLT) GOTO9000 C 6230 CONTINUE DARG1=DBLE(X) DRESLT=DBSI0E(DARG1) TERM=SNGL(DRESLT) GOTO9000 C 6250 CONTINUE DARG1=DBLE(X) DRESLT=DBESI1(DARG1) TERM=SNGL(DRESLT) GOTO9000 C 6280 CONTINUE DARG1=DBLE(X) DRESLT=DBSI1E(DARG1) TERM=SNGL(DRESLT) GOTO9000 C 6300 CONTINUE ARG1=X RESULT=BESK0(ARG1) TERM=RESULT GOTO9000 C 6330 CONTINUE ARG1=X RESULT=BESK0E(ARG1) TERM=RESULT GOTO9000 C 6350 CONTINUE ARG1=X RESULT=BESK1(ARG1) TERM=RESULT GOTO9000 C 6380 CONTINUE ARG1=X RESULT=BESK1E(ARG1) TERM=RESULT GOTO9000 C CCCCC NOTE: 2 CASES FOR BESSJ(X,ALPHA) CCCCC 1) ALPHA IS INTEGER CCCCC 2) ALPHA IS REAL CCCCC HOWEVER, CALL TO BESJ IS SAME. BESJ ACTUALLY CCCCC COMPUTES A SEQUENCE OF BESJ VALUES, BUT WE ARE CCCCC ONLY COMPUTING 1 (SET ALPHA TO THIS VALUE). 6400 CONTINUE ARG1=X ARG2=SAVE1 IF(ARG2.EQ.0.0)THEN RESULT=BESJ0(ARG1) ELSEIF(ARG2.EQ.1.0)THEN RESULT=BESJ1(ARG1) ELSE IARG1=1 CALL BESJ(ARG1,ARG2,IARG1,TEMP1,NZERO) RESULT=TEMP1(IARG1) ENDIF TERM=RESULT GOTO9000 C 6500 CONTINUE ARG1=X ARG2=SAVE1 IF(ARG2.EQ.0.0)THEN RESULT=BESY0(ARG1) ELSEIF(ARG2.EQ.1.0)THEN RESULT=BESY1(ARG1) ELSE IARG1=1 CALL BESY(ARG1,ARG2,IARG1,TEMP1) RESULT=TEMP1(IARG1) ENDIF TERM=RESULT GOTO9000 C 6600 CONTINUE DARG1=DBLE(X) DARG2=DBLE(SAVE1) CCCCC APRIL 1995. FIX BUG CCCCC IF(ARG2.EQ.0.0)THEN IF(DARG2.EQ.0.D0)THEN DRESLT=DBESI0(DARG1) CCCCC ELSEIF(ARG2.EQ.1.0)THEN ELSEIF(DARG2.EQ.1.D0)THEN DRESLT=DBESI1(DARG1) ELSE IARG1=1 ISCALE=1 CALL DBESI(DARG1,DARG2,ISCALE,IARG1,DTEMP1,NZERO) DRESLT=DTEMP1(IARG1) ENDIF TERM=SNGL(DRESLT) GOTO9000 C 6650 CONTINUE ARG1=X ARG2=SAVE1 IF(ARG2.EQ.0.0)THEN RESULT=BESI0E(ARG1) ELSEIF(ARG2.EQ.1.0)THEN RESULT=BESI1E(ARG1) ELSE IARG1=1 ISCALE=2 CALL BESI(ARG1,ARG2,ISCALE,IARG1,TEMP1,NZERO) RESULT=TEMP1(IARG1) ENDIF TERM=RESULT GOTO9000 C 6700 CONTINUE ARG1=X ARG2=SAVE1 IF(ARG2.EQ.0.0)THEN RESULT=BESK0(ARG1) ELSEIF(ARG2.EQ.1.0)THEN RESULT=BESK1(ARG1) ELSE IARG1=1 ISCALE=1 CALL BESK(ARG1,ARG2,ISCALE,IARG1,TEMP1,NZERO) RESULT=TEMP1(IARG1) ENDIF TERM=RESULT GOTO9000 C 6750 CONTINUE ARG1=X ARG2=SAVE1 IF(ARG2.EQ.0.0)THEN RESULT=BESK0E(ARG1) ELSEIF(ARG2.EQ.1.0)THEN RESULT=BESK1E(ARG1) ELSE IARG1=1 ISCALE=2 CALL BESK(ARG1,ARG2,ISCALE,IARG1,TEMP1,NZERO) RESULT=TEMP1(IARG1) ENDIF TERM=RESULT GOTO9000 C 6800 CONTINUE ARG1=X RESULT=AI(ARG1) TERM=RESULT GOTO9000 C 6900 CONTINUE ARG1=X RESULT=BI(ARG1) TERM=RESULT GOTO9000 C 7000 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) IARG1=INT(SAVE2) ARG4=SAVE2-REAL(IARG1) IF(ARG4.GT.0.5)THEN IARG1=IARG1+1 ARG4=-ARG4 ENDIF CCCCC IF(IARG1.GT.100.OR.SAVE.LT.0.0)THEN IF(IARG1.GT.100.OR.SAVE2.LT.0)THEN WRITE(ICOUT,7001) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 7001 FORMAT('***** ORDER OF COMPLEX BESSEL FUNCTION NOT IN THE RANGE', 1 ' (0,100). *****') CALL BESJCF(Z1,ARG4,IARG1,CTEMP1) TERM=REAL(CTEMP1(IARG1+2)) GOTO9000 C 7010 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) IARG1=INT(SAVE2) ARG4=SAVE2-REAL(IARG1) IF(ARG4.GT.0.5)THEN IARG1=IARG1+1 ARG4=-ARG4 ENDIF IF(IARG1.GT.100.OR.SAVE2.LT.0.0)THEN WRITE(ICOUT,7011) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 7011 FORMAT('***** ORDER OF COMPLEX BESSEL FUNCTION NOT IN THE RANGE', 1 ' (0,100). *****') CALL BESJCF(Z1,ARG4,IARG1,CTEMP1) TERM=AIMAG(CTEMP1(IARG1+2)) GOTO9000 C 7020 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) IARG1=INT(SAVE2) ARG4=SAVE2-REAL(IARG1) IF(ARG4.GT.0.5)THEN IARG1=IARG1+1 ARG4=-ARG4 ENDIF IF(IARG1.GT.100.OR.SAVE2.LT.0.0)THEN WRITE(ICOUT,7021) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 7021 FORMAT('***** ORDER OF COMPLEX BESSEL FUNCTION NOT IN THE RANGE', 1 ' (0,100). *****') CALL BESYCF(Z1,ARG4,IARG1,CTEMP1) TERM=REAL(CTEMP1(IARG1+2)) GOTO9000 C 7030 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) IARG1=INT(SAVE2) ARG4=SAVE2-REAL(IARG1) IF(ARG4.GT.0.5)THEN IARG1=IARG1+1 ARG4=-ARG4 ENDIF IF(IARG1.GT.100.OR.SAVE2.LT.0.0)THEN WRITE(ICOUT,7031) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 7031 FORMAT('***** ORDER OF COMPLEX BESSEL FUNCTION NOT IN THE RANGE', 1 ' (0,100). *****') CALL BESYCF(Z1,ARG4,IARG1,CTEMP1) TERM=AIMAG(CTEMP1(IARG1+2)) GOTO9000 C 7040 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) IARG1=INT(SAVE2) ARG4=SAVE2-REAL(IARG1) IF(ARG4.GT.0.5)THEN IARG1=IARG1+1 ARG4=-ARG4 ENDIF IF(IARG1.GT.100.OR.SAVE2.LT.0.0)THEN WRITE(ICOUT,7041) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 7041 FORMAT('***** ORDER OF COMPLEX BESSEL FUNCTION NOT IN THE RANGE', 1 ' (0,100). *****') CALL BESICF(Z1,ARG4,IARG1,CTEMP1) TERM=REAL(CTEMP1(IARG1+2)) GOTO9000 C 7050 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) IARG1=INT(SAVE2) ARG4=SAVE2-REAL(IARG1) IF(ARG4.GT.0.5)THEN IARG1=IARG1+1 ARG4=-ARG4 ENDIF IF(IARG1.GT.100.OR.SAVE2.LT.0.0)THEN WRITE(ICOUT,7051) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 7051 FORMAT('***** ORDER OF COMPLEX BESSEL FUNCTION NOT IN THE RANGE', 1 ' (0,100). *****') CALL BESICF(Z1,ARG4,IARG1,CTEMP1) TERM=AIMAG(CTEMP1(IARG1+2)) GOTO9000 C 7060 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) IARG1=INT(SAVE2) ARG4=SAVE2-REAL(IARG1) IF(ARG4.GT.0.5)THEN IARG1=IARG1+1 ARG4=-ARG4 ENDIF IF(IARG1.GT.100.OR.SAVE2.LT.0.0)THEN WRITE(ICOUT,7061) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 7061 FORMAT('***** ORDER OF COMPLEX BESSEL FUNCTION NOT IN THE RANGE', 1 ' (0,100). *****') CALL BESKCF(Z1,ARG4,IARG1,CTEMP1) TERM=REAL(CTEMP1(IARG1+2)) GOTO9000 C 7070 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) IARG1=INT(SAVE2) ARG4=SAVE2-REAL(IARG1) IF(ARG4.GT.0.5)THEN IARG1=IARG1+1 ARG4=-ARG4 ENDIF IF(IARG1.GT.100.OR.SAVE2.LT.0.0)THEN WRITE(ICOUT,7071) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 7071 FORMAT('***** ORDER OF COMPLEX BESSEL FUNCTION NOT IN THE RANGE', 1 ' (0,100). *****') CALL BESKCF(Z1,ARG4,IARG1,CTEMP1) TERM=AIMAG(CTEMP1(IARG1+2)) GOTO9000 C CCCCC THE FOLLOWING 4 SECTIONS (7100 TO 7400) WAS ADDED MAY 1989 7100 CONTINUE ARG1=X IF(ARG1.GT.0.0)GOTO7109 IF(ARG1.EQ.0.0)WRITE(ICOUT,7101) 7101 FORMAT('ERROR--ARGUMENT OF CP FUNCTION IS 0') IF(ARG1.EQ.0.0)CALL DPWRST('XXX','BUG ') IF(ARG1.EQ.0.0)WRITE(ICOUT,7102) 7102 FORMAT('ERROR--ARGUMENT OF CP FUNCTION IS NEGATIVE') IF(ARG1.EQ.0.0)CALL DPWRST('XXX','BUG ') GOTO9000 7109 CONTINUE RESULT=1.0/(3.0*ARG1) TERM=RESULT GOTO9000 C 7200 CONTINUE ARG1=X IF(X.LT.0.0)ARG1=(-X) ARG2=SAVE1 IF(ARG2.GT.0.0)GOTO7209 IF(ARG2.EQ.0.0)WRITE(ICOUT,7201) 7201 FORMAT('ERROR--2ND ARGUMENT OF PERDEF FUNCTION IS 0') IF(ARG2.EQ.0.0)CALL DPWRST('XXX','BUG ') IF(ARG2.EQ.0.0)WRITE(ICOUT,7202) 7202 FORMAT('ERROR--2ND ARGUMENT OF PERDEF FUNCTION IS NEGATIVE') IF(ARG2.EQ.0.0)CALL DPWRST('XXX','BUG ') GOTO9000 7209 CONTINUE RESULT=(1.0-ARG1)/(3.0*ARG2) TERM=RESULT GOTO9000 C 7300 CONTINUE ARG1=X IF(X.LT.0.0)ARG1=(-X) ARG2=SAVE1 IF(ARG2.GT.0.0)GOTO7309 IF(ARG2.EQ.0.0)WRITE(ICOUT,7301) 7301 FORMAT('ERROR--2ND ARGUMENT OF PERDEF FUNCTION IS 0') IF(ARG2.EQ.0.0)CALL DPWRST('XXX','BUG ') IF(ARG2.EQ.0.0)WRITE(ICOUT,7302) 7302 FORMAT('ERROR--2ND ARGUMENT OF PERDEF FUNCTION IS NEGATIVE') IF(ARG2.EQ.0.0)CALL DPWRST('XXX','BUG ') GOTO9000 7309 CONTINUE CCCCC Z1=(1.0-ARG1)/ARG2 ARG3=(1.0-ARG1)/ARG2 Z2=(-1.0-ARG1)/ARG2 CALL NORCDF(ARG3,CDF1) CALL NORCDF(Z2,CDF2) RESULT=100.0*(1.0-(CDF1-CDF2)) TERM=RESULT GOTO9000 C 7400 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 RESULT=ARG3*(ARG1*ARG1+ARG2*ARG2) TERM=RESULT GOTO9000 CCCCC FOLLOWING SECTIONS ADDED SEPTEMBER 1994. C 7500 CONTINUE ARG1=X RESULT=DAWS(ARG1) TERM=RESULT GOTO9000 C 7600 CONTINUE ARG1=X RESULT=E1(ARG1) TERM=RESULT GOTO9000 C 7650 CONTINUE ARG1=X RESULT=EI(ARG1) TERM=RESULT GOTO9000 C 7700 CONTINUE ARG1=X IARG2=INT(SAVE1+0.5) IARG3=1 ISCALE=1 TOL=1.0E-4 IERR=0 C C APRIL 1995. THE N=0 CASE HANDLED SEPARATELY. C IF(X.GT.0.0 .AND. IARG2.EQ.0)THEN RESULT=EXP(-ARG1/ARG1) GOTO9000 ENDIF C CALL EXINT(ARG1,IARG2,ISCALE,IARG3,TOL,TEMP1,NZERO,IERR) IF(IERR.EQ.0)THEN RESULT=TEMP1(1) ELSEIF(IERR.EQ.1)THEN WRITE(ICOUT,7701) CALL DPWRST('XXX','BUG ') RESULT=0.0 ELSEIF(IERR.EQ.2)THEN WRITE(ICOUT,7702) CALL DPWRST('XXX','BUG ') RESULT=0.0 ELSEIF(IERR.EQ.3)THEN WRITE(ICOUT,7703) CALL DPWRST('XXX','BUG ') RESULT=0.0 ENDIF 7701 FORMAT('*****ERROR IN THE INPUT ARGUMENTS IN CALCULATING THE ', * 'EXPONENTIAL INTEGRAL. ****') 7702 FORMAT('*****ERROR IN CALCULATING THE EXPONENTIAL INTEGRAL, THE', * ' ALGORITHM TERMINATION CONDITION NOT MET. ****') 7703 FORMAT('*****ERROR IN CALCULATING THE EXPONENTIAL INTEGRAL. ***') TERM=RESULT GOTO9000 C 7800 CONTINUE ARG1=X ARG2=SAVE1 RESULT=RC(ARG1,ARG2,IERR) TERM=RESULT GOTO9000 C 7810 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 RESULT=RD(ARG1,ARG2,ARG3,IERR) TERM=RESULT GOTO9000 C 7815 CONTINUE ARG1=X IF(ARG1.LT.0.0.OR.ARG1.GE.1.0)THEN WRITE(ICOUT,7816) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 7816 FORMAT('**** ERROR FROM ELLIPC2, ARGUMENT IS NOT IN THE (0,1)', 1 ' INTERVAL. ****') ARG2=1.0-ARG1 ARG3=0.0 ARG4=1.0 RESULT1=RF(ARG3,ARG2,ARG4,IERR) RESULT2=RD(ARG3,ARG2,ARG4,IERR) RESULT=RESULT1-(1.0/3.0)*ARG1*RESULT2 TERM=RESULT GOTO9000 C 7818 CONTINUE IF(X.LE.0.0.OR.X.GT.0.5*REALPI)THEN WRITE(ICOUT,7819) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 7819 FORMAT('**** ERROR FROM ELLIP2, FIRST ARGUMENT IS NOT IN THE ', 1 '(0,PI/2) INTERVAL. ****') ARG5=SIN(SAVE1)*SIN(SAVE1) ARG1=SIN(X) ARG2=COS(X)*COS(X) ARG3=1.0-ARG5*ARG1*ARG1 ARG4=1.0 RESULT1=RF(ARG2,ARG3,ARG4,IERR) RESULT2=RD(ARG2,ARG3,ARG4,IERR) RESULT=RESULT1-ARG1*ARG1*ARG5*RESULT2/3.0 TERM=ARG1*RESULT GOTO9000 C 7820 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 RESULT=RF(ARG1,ARG2,ARG3,IERR) TERM=RESULT GOTO9000 C 7825 CONTINUE IF(ARG1.LT.0.0.OR.ARG1.GE.1.0)THEN WRITE(ICOUT,7826) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 7826 FORMAT('**** ERROR FROM ELLIPC1, ARGUMENT IS NOT IN THE (0,1)', 1 ' INTERVAL. ****') ARG1=0.0 ARG2=1.0-X ARG3=1.0 RESULT=RF(ARG1,ARG2,ARG3,IERR) TERM=RESULT GOTO9000 C 7828 CONTINUE IF(X.LE.0.0.OR.X.GT.0.5*REALPI)THEN WRITE(ICOUT,7829) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 7829 FORMAT('**** ERROR FROM ELLIP1, FIRST ARGUMENT IS NOT IN THE ', 1 '(0,PI/2) INTERVAL. ****') ARG1=SIN(X) ARG2=COS(X)**2 ARG3=(1.0-ARG1*SIN(SAVE1))*(1.0+ARG1*SIN(SAVE1)) ARG4=1.0 RESULT=RF(ARG2,ARG3,ARG4,IERR) TERM=ARG1*RESULT GOTO9000 C 7830 CONTINUE ARG1=X ARG2=SAVE1 ARG3=SAVE2 ARG4=SAVE3 RESULT=RJ(ARG1,ARG2,ARG3,ARG4,IERR) TERM=RESULT GOTO9000 C 7838 CONTINUE IF(X.LE.0.0.OR.X.GT.0.5*REALPI)THEN WRITE(ICOUT,7839) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ENDIF 7839 FORMAT('**** ERROR FROM ELLIP3, FIRST ARGUMENT IS NOT IN THE ', 1 '(0,PI/2) INTERVAL. ****') ARG6=-SAVE1 ARG1=SIN(X) ARG2=COS(X)*COS(X) ARG3=1.0-SIN(SAVE2)*SIN(SAVE2)*ARG1*ARG1 ARG4=1.0+ARG6*ARG1*ARG1 ARG5=1.0 RESULT1=RF(ARG2,ARG3,ARG5,IERR) RESULT2=RJ(ARG2,ARG3,ARG5,ARG4,IERR) RESULT=(ARG6/3.0)*(ARG1**3)*RESULT2 TERM=ARG1*RESULT1-RESULT GOTO9000 C 7900 CONTINUE DARG1=DBLE(X) DRESLT=DSPENC(DARG1) TERM=SNGL(DRESLT) GOTO9000 C 8000 CONTINUE ARG1=X RESULT=ALI(ARG1) TERM=RESULT GOTO9000 C CCCCC ADD FOLLOWING SECTION (BN) SEPTEMBER 1997 8010 CONTINUE IARG1=INT(X+0.5) ARG2=SAVE1 IF(ARG2.EQ.-99.9)THEN CALL BERNOB(IARG1,DTEMP1(1)) TERM=SNGL(DTEMP1(IARG1+1)) ELSE DARG1=X IARG2=INT(ARG2+0.5) CALL BERNPN(DARG1,IARG2,DRESLT) TERM=SNGL(DRESLT) ENDIF GOTO9000 C CCCCC ADD FOLLOWING SECTION (EN) SEPTEMBER 1997 8020 CONTINUE IARG1=INT(X+0.5) ARG2=SAVE1 IF(ARG2.EQ.-99.9)THEN CALL EULERB(IARG1,DTEMP1(1)) TERM=SNGL(DTEMP1(IARG1+1)) ELSE DARG1=X IARG2=INT(ARG2+0.5) CALL EULERP(DARG1,IARG2,DRESLT) TERM=SNGL(DRESLT) ENDIF GOTO9000 C CCCCC ADD FOLLOWING SECTION (BINOM) SEPTEMBER 1997 8030 CONTINUE IARG1=INT(X+0.5) IARG2=INT(SAVE1+0.5) RESULT=BINOM(IARG1,IARG2) TERM=RESULT GOTO9000 C 8040 CONTINUE DARG1=DBLE(X) IARG2=INT(SAVE1+0.5) IF(IARG2.LT.0)IARG2=0 IF(IARG2.EQ.0)THEN DRESLT=ABRAM0(DARG1) TERM=REAL(DRESLT) ELSEIF(IARG2.EQ.1)THEN DRESLT=ABRAM1(DARG1) TERM=REAL(DRESLT) ELSEIF(IARG2.EQ.2)THEN DRESLT=ABRAM2(DARG1) TERM=REAL(DRESLT) ELSEIF(IARG2.LE.100)THEN DABRAM(0)=ABRAM0(DARG1) DABRAM(1)=ABRAM1(DARG1) DABRAM(2)=ABRAM2(DARG1) DO8041I=3,IARG2 DABRAM(I)=(DBLE(I-1)*DABRAM(I-2) + DARG1*DABRAM(I-3))/2.0D0 8041 CONTINUE DRESLT=DABRAM(IARG2) TERM=REAL(DRESLT) ELSE TERM=0.0 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8043)IARG2 CALL DPWRST('XXX','BUG ') ENDIF 8043 FORMAT('***** ERROR FROM ABRAM: MAXIMUM ORDER OF 100 ', 1 'EXCEEDED.') GOTO9000 C 8045 CONTINUE DARG1=DBLE(X) DRESLT=CLAUSN(DARG1) TERM=REAL(DRESLT) GOTO9000 C 8050 CONTINUE DARG1=DBLE(X) IARG2=INT(SAVE1+0.5) IF(IARG2.LT.1)IARG2=1 IF(IARG2.EQ.1)THEN DRESLT=DEBYE1(DARG1) TERM=REAL(DRESLT) ELSEIF(IARG2.EQ.2)THEN DRESLT=DEBYE2(DARG1) TERM=REAL(DRESLT) ELSEIF(IARG2.EQ.3)THEN DRESLT=DEBYE3(DARG1) TERM=REAL(DRESLT) ELSEIF(IARG2.EQ.4)THEN DRESLT=DEBYE4(DARG1) TERM=REAL(DRESLT) ELSE TERM=0.0 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8053)IARG2 CALL DPWRST('XXX','BUG ') ENDIF 8053 FORMAT('***** ERROR FROM DEBYE: MAXIMUM ORDER OF 4 ', 1 'EXCEEDED.') GOTO9000 C 8055 CONTINUE DARG1=DBLE(X) DRESLT=EXP3(DARG1) TERM=REAL(DRESLT) GOTO9000 C 8060 CONTINUE DARG1=DBLE(X) DRESLT=GOODST(DARG1) TERM=REAL(DRESLT) GOTO9000 C 8065 CONTINUE DARG1=DBLE(X) DRESLT=LOBACH(DARG1) TERM=REAL(DRESLT) GOTO9000 C 8070 CONTINUE DARG1=DBLE(X) DRESLT=STROM(DARG1) TERM=REAL(DRESLT) GOTO9000 C 8075 CONTINUE DARG1=DBLE(X) DRESLT=SYNCH1(DARG1) TERM=REAL(DRESLT) GOTO9000 C 8080 CONTINUE DARG1=DBLE(X) DRESLT=SYNCH2(DARG1) TERM=REAL(DRESLT) GOTO9000 C 8085 CONTINUE DARG1=DBLE(X) IARG2=INT(SAVE1+0.5) IF(IARG2.LT.2)IARG2=2 IF(IARG2.EQ.2)THEN DRESLT=TRAN02(DARG1) TERM=REAL(DRESLT) ELSEIF(IARG2.EQ.3)THEN DRESLT=TRAN03(DARG1) TERM=REAL(DRESLT) ELSEIF(IARG2.EQ.4)THEN DRESLT=TRAN04(DARG1) TERM=REAL(DRESLT) ELSEIF(IARG2.EQ.5)THEN DRESLT=TRAN05(DARG1) TERM=REAL(DRESLT) ELSEIF(IARG2.EQ.6)THEN DRESLT=TRAN06(DARG1) TERM=REAL(DRESLT) ELSEIF(IARG2.EQ.7)THEN DRESLT=TRAN07(DARG1) TERM=REAL(DRESLT) ELSEIF(IARG2.EQ.8)THEN DRESLT=TRAN08(DARG1) TERM=REAL(DRESLT) ELSEIF(IARG2.EQ.9)THEN DRESLT=TRAN09(DARG1) TERM=REAL(DRESLT) ELSE TERM=0.0 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,8088)IARG2 CALL DPWRST('XXX','BUG ') ENDIF 8088 FORMAT('***** ERROR FROM TRAN: MAXIMUM ORDER OF 9 ', 1 'EXCEEDED.') GOTO9000 C 8100 CONTINUE DARG1=DBLE(X) C C APRIL 1995. SI(-X)=-SI(X) C AFACT=1.0 IF(DARG1.LT.0.D0)THEN AFACT=-1.0 DARG1=-DARG1 ENDIF C IERR=0 IOPT=1 CALL SICIEI(IOPT,DARG1,DARG2,DARG3,DARG4,DARG5,DARG6,DARG7, 1DARG8,DARG9,IERR) IF(IERR.GT.0)THEN WRITE(ICOUT,8101) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ELSE TERM=SNGL(DARG2) TERM=TERM*AFACT ENDIF 8101 FORMAT('**** ERROR IN COMPUTING THE SINE INTEGRAL. ****') GOTO9000 C 8200 CONTINUE DARG1=DBLE(X) C C APRIL 1995. SHI(-X)=-SHI(X) C AFACT=1.0 IF(DARG1.LT.0.D0)THEN AFACT=-1.0 DARG1=-DARG1 ENDIF C IOPT=3 IERR=0 CALL SICIEI(IOPT,DARG1,DARG2,DARG3,DARG4,DARG5,DARG6,DARG7, 1DARG8,DARG9,IERR) IF(IERR.GT.0)THEN WRITE(ICOUT,8201) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ELSE TERM=SNGL(DARG7) TERM=TERM*AFACT ENDIF 8201 FORMAT('**** ERROR IN COMPUTING THE HYPERBOLIC SINE ', 1'INTEGRAL. *****') GOTO9000 C 8300 CONTINUE IF(X.EQ.0.0)THEN WRITE(ICOUT,8302) CALL DPWRST('XXX','BUG ') TERM=-R1MACH(2) GOTO9000 ENDIF 8302 FORMAT('**** ERROR, THE COSINE INTEGRAL IS UNDEFINED FOR 0.', 1' ****') DARG1=DBLE(X) IOPT=1 IERR=0 CALL SICIEI(IOPT,DARG1,DARG2,DARG3,DARG4,DARG5,DARG6,DARG7, 1DARG8,DARG9,IERR) IF(IERR.GT.0)THEN WRITE(ICOUT,8301) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ELSE TERM=SNGL(DARG3) ENDIF 8301 FORMAT('**** ERROR IN COMPUTING THE COSINE INTEGRAL. ****') GOTO9000 C 8400 CONTINUE IF(X.EQ.0.0)THEN WRITE(ICOUT,8402) CALL DPWRST('XXX','BUG ') TERM=-R1MACH(2) GOTO9000 ENDIF 8402 FORMAT('**** ERROR, THE HYPERBOLIC COSINE INTEGRAL IS UNDEFINED', 1' FOR 0. ****') DARG1=DBLE(X) IF(X.LT.0.0)DARG1=-DBLE(X) IOPT=3 IERR=0 CALL SICIEI(IOPT,DARG1,DARG2,DARG3,DARG4,DARG5,DARG6,DARG7, 1DARG8,DARG9,IERR) IF(IERR.GT.0)THEN WRITE(ICOUT,8401) CALL DPWRST('XXX','BUG ') TERM=0.0 GOTO9000 ELSE TERM=SNGL(DARG8) ENDIF 8401 FORMAT('**** ERROR IN COMPUTING THE HYPERBOLIC COSINE ', 1'INTEGRAL. ****') GOTO9000 C 8500 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=REAL(CABS(Z1)) GOTO9000 C 8600 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=REAL(CCOS(Z1)) GOTO9000 C 8610 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=AIMAG(CCOS(Z1)) GOTO9000 C 8700 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=REAL(CEXP(Z1)) GOTO9000 C 8710 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=AIMAG(CEXP(Z1)) GOTO9000 C 8800 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=REAL(CLOG(Z1)) GOTO9000 C 8810 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=AIMAG(CLOG(Z1)) GOTO9000 C 8900 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=REAL(CSIN(Z1)) GOTO9000 C 8910 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=AIMAG(CSIN(Z1)) GOTO9000 C 8950 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=REAL(CSQRT(Z1)) GOTO9000 C 8960 CONTINUE ARG1=X ARG2=SAVE1 Z1=CMPLX(ARG1,ARG2) TERM=AIMAG(CSQRT(Z1)) GOTO9000 C CCCCC JULY 1995. ADD HERMITE POLYNOMIAL 8970 CONTINUE ARG1=X ARG2=SAVE1 CALL HERMIT(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC JULY 1995. ADD LOG HERMITE POLYNOMIAL 8975 CONTINUE ARG1=X ARG2=SAVE1 CALL LNHERM(ARG1,ARG2,RESULT,ISIGN) TERM=RESULT GOTO9000 C CCCCC JULY 1995. ADD SIGN OF LOG HERMITE POLYNOMIAL 8978 CONTINUE ARG1=X ARG2=SAVE1 CALL LNHERM(ARG1,ARG2,RESULT,ISIGN) TERM=REAL(ISIGN) GOTO9000 C CCCCC JULY 1995. ADD LAGUERRE POLYNOMIAL 8980 CONTINUE ARG1=X ARG2=SAVE1 CALL LAGUE(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C CCCCC JULY 1995. ADD LEGENDRE POLYNOMIAL (UNNORMALIZED) CCCCC NOTE THAT IN THIS CASE THE INPUT IS THETA (I.E., THE CCCCC ANGLE) RATHER THAN X. THIS IS TO BE CONSISTENT WITH CCCCC ASSOCIATED LEGENDRE POLYNOMILS AND FUNCTIONS. CONVERT CCCCC TO (-1,1) FOR LEGNDR ROUTINE. 8990 CONTINUE IF(IANGLU.EQ.'DEGR')THEN ARG1=COS(X*REALPI/180.) ELSE ARG1=COS(X) ENDIF ARG2=SAVE1 CALL LEGNDR(ARG1,ARG2,RESULT) TERM=RESULT GOTO9000 C 18090 CONTINUE DARG1=DBLE(X) DRESLT=AIRINT(DARG1) TERM=REAL(DRESLT) GOTO9000 C 18095 CONTINUE DARG1=DBLE(X) DRESLT=AIRYGI(DARG1) TERM=REAL(DRESLT) GOTO9000 C 18100 CONTINUE DARG1=DBLE(X) DRESLT=AIRYHI(DARG1) TERM=REAL(DRESLT) GOTO9000 C 18105 CONTINUE DARG1=DBLE(X) DRESLT=ATNINT(DARG1) TERM=REAL(DRESLT) GOTO9000 C 18110 CONTINUE DARG1=DBLE(X) DRESLT=BIRINT(DARG1) TERM=REAL(DRESLT) GOTO9000 C 18115 CONTINUE DARG1=DBLE(X) DRESLT=I0INT(DARG1) TERM=REAL(DRESLT) GOTO9000 C 18120 CONTINUE DARG1=DBLE(X) DRESLT=I0ML0(DARG1) TERM=REAL(DRESLT) GOTO9000 C 18125 CONTINUE DARG1=DBLE(X) DRESLT=I1ML1(DARG1) TERM=REAL(DRESLT) GOTO9000 C 18130 CONTINUE DARG1=DBLE(X) DRESLT=J0INT(DARG1) TERM=REAL(DRESLT) GOTO9000 C 18135 CONTINUE DARG1=DBLE(X) DRESLT=K0INT(DARG1) TERM=REAL(DRESLT) GOTO9000 C 18140 CONTINUE DARG1=DBLE(X) DRESLT=Y0INT(DARG1) TERM=REAL(DRESLT) GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGEV.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF DPLIB3--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IH,IH2,X 9012 FORMAT('IH,IH2,X = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)SAVE1,SAVE2,I,IANGLU 9013 FORMAT('SAVE1,SAVE2,I,IANGLU = ',E15.7,E15.7,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)RESULT,TERM,IBUGEV 9014 FORMAT('RESULT,TERM,IBUGEV = ',2E15.7,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUND,IERROR 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPLIBF(IH,IH2,X,SAVE1,SAVE2,SAVE3,SAVE4,SAVE5, 1SAVE6,SAVE7,SAVE8, 1I,IANGLU, CCCCC MAY 1998. ADD SAVE5 PARAMETER TO CALL LIST. CCCCC SUBROUTINE DPLIBF(IH,IH2,X,SAVE1,SAVE2,SAVE3,SAVE4,I,IANGLU, 1TERM,IBUGEV,IERROR) CCCCC SAVE4 ARGUMENT ADDED SEPTEMBER 1994 (FOR DNFCDF ROUTINE). CCCCC SUBROUTINE DPLIBF(IH,IH2,X,SAVE1,SAVE2,SAVE3,I,IANGLU, C C PURPOSE--PERFORM A LIBRARY FUNCTION EVALUATION. C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--JANUARY 1979. C UPDATED --NOVEMBER 1979. C UPDATED --FEBRUARY 1981. C UPDATED --JUNE 1981. C UPDATED --JULY 1981. C UPDATED --NOVEMBER 1981. C UPDATED --MARCH 1982. C UPDATED --MAY 1982. C UPDATED --MARCH 1989. INPUT ARG SAVE3 & SAVE3 IN CALL C UPDATED --SEPTEMBER 1994. ADD SAVE3,SAVE4 TO DPLIB3. C UPDATED --MAY 1998. ADD SAVE5 TO DPLIB3. C UPDATED --JUNE 2003. ADD SAVE6, SAVE7, SAVE8 TO C DPLIB3. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IANGLU CHARACTER*4 IBUGEV CHARACTER*4 IERROR C CHARACTER*4 IFOUNZ C 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 IFOUNZ='NO' IERROR='NO' C ISUBN1='DPLI' ISUBN2='BF ' C IF(IBUGEV.EQ.'OFF')GOTO90 WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('AT THE BEGINNING OF DPLIBF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)IH,IH2,X 52 FORMAT('IH,IH2,X = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,53)SAVE1,SAVE2,SAVE3,I,IANGLU 53 FORMAT('SAVE1,SAVE2,SAVE3,I,IANGLU = ',3E15.7,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,54)TERM,IBUGEV,NUMBPW 54 FORMAT('TERM,IBUGEV,NUMBPW = ',E15.7,2X,A4,I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,55)IERROR 55 FORMAT('IERROR = ',A4) CALL DPWRST('XXX','BUG ') 90 CONTINUE C IFOUNZ='NO' CCCCC THE SAVE3 ARGUEMNT WAS ADDED MARCH 1989 CALL DPLIB1(IH,IH2,X,SAVE1,SAVE2,SAVE3,I,IANGLU, 1TERM,IBUGEV,IFOUNZ,IERROR) IF(IFOUNZ.EQ.'YES')GOTO9000 C IFOUNZ='NO' CALL DPLIB2(IH,IH2,X,SAVE1,SAVE2,I,IANGLU, 1TERM,IBUGEV,IFOUNZ,IERROR) IF(IFOUNZ.EQ.'YES')GOTO9000 C IFOUNZ='NO' CCCCC SEPTEMBER 1994. ADD SAVE3, SAVE4 FOR NON-CENTRAL DISTRIBUTIONS. CCCCC MAY 1998. ADD SAVE5 FOR MIXTURE DISTRIBUTIONS CCCCC CALL DPLIB3(IH,IH2,X,SAVE1,SAVE2,I,IANGLU, CALL DPLIB3(IH,IH2,X,SAVE1,SAVE2,SAVE3,SAVE4,SAVE5, 1SAVE6,SAVE7,SAVE8, 1I,IANGLU, 1TERM,IBUGEV,IFOUNZ,IERROR) IF(IFOUNZ.EQ.'YES')GOTO9000 C WRITE(ICOUT,419) 419 FORMAT('***** ERROR IN DPLIBF--', 1'UNKNOWN LIBRARY FUNCTION') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,396)I,IH,IH2 396 FORMAT('I,IH,IH2 = ',I8,2X,A4,A4) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGEV.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('AT THE END OF DPLIBF--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IH,IH2,X 9012 FORMAT('IH,IH2,X = ',A4,2X,A4,E15.7) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9013)SAVE1,SAVE2,SAVE3,I,IANGLU 9013 FORMAT('SAVE1,SAVE2,SAVE3,I,IANGLU = ',3E15.7,I8,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)TERM,IBUGEV 9014 FORMAT('TERM,IBUGEV = ',E15.7,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9015)IFOUNZ,IERROR 9015 FORMAT('IFOUNZ,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') 9090 CONTINUE C RETURN END SUBROUTINE DPLICA(ICAPSW,ISEED,ISUBRO,IBUGA2,IBUGA3,IBUGQ, 1 IFOUND,IERROR) C C PURPOSE--PERFORM A LINEAR CALIBRATRION ANALYSIS. C A LINEAR CALIBRATION WILL BE PERFORMED USING THE C FOLLOWING TECHNIQUES: C 1) CLASSICAL (EISENHART: INVERSE PREDICTION LIMITS) C 2) GRAYBILL-IYER METHOD C 3) NETER, WASSERMAN, AND KUTNER C 4) PROPOGATION OF ERROR C 5) INVERSE (KRUTCHKOFF) C 6) MAXIMUM LIKELIHOOD C 7) BOOTSTRAP (EFRON--RESAMPLE RESIDUALS) C 8) BOOTSTRAP (WU--RESAMPLE DATA) C 9) BAYESIAN, CONTROLLED X'S, IMPROPER PRIOR (HOADLEY) C (NOT ON INITIAL IMPLEMENTATION) C 10) BAYESIAN, RANDOM X'S, IMPROPER PRIOR (HOADLEY) C (NOT ON INITIAL IMPLEMENTATION) C --YOU CAN ALSO SPECIFY A QUADRATIC CALIBRATION. THE C FOLLOWING TECHNIQUES ARE SUPPORTED: C 1) INVERSE PREDICTION LIMITS C 2) BOOTSTRAP (EFRON--RESAMPLE RESIDUALS) C 3) BOOTSTRAP (WU--RESAMPLE DATA) C WRITTEN BY--JIM FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY 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 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-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------- C CHARACTER*4 ICAPSW CHARACTER*4 ISUBRO CHARACTER*4 IWRITE CHARACTER*4 IBUGA2 CHARACTER*4 IBUGA3 CHARACTER*4 IBUGQ CHARACTER*4 IFOUND CHARACTER*4 IERROR C CHARACTER*4 IH CHARACTER*4 IH2 CHARACTER*4 IHWUSE CHARACTER*4 MESSAG CHARACTER*4 ICASEQ CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 CHARACTER*4 IHFACT CHARACTER*4 IHFAC2 C CHARACTER*4 ITYPE CHARACTER*4 ICASAN CHARACTER*10 ICALTY C CHARACTER*4 ISUBN0 CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C---------------------------------------------------------------- C INCLUDE 'DPCOPA.INC' C DIMENSION Y1(MAXOBV) DIMENSION Y2(MAXOBV) DIMENSION Y3(MAXOBV) C DIMENSION Z1(MAXOBV) DIMENSION Z2(MAXOBV) DIMENSION Z3(MAXOBV) DIMENSION Z4(MAXOBV) DIMENSION Z5(MAXOBV) DIMENSION Z6(MAXOBV) DIMENSION IZ(MAXOBV) C CCCCC NOTE: EQUIVALENCE TO DOUBLE PRECISION COMMON SINCE DPLIC3 CCCCC CALLS DPFIT WHICH ESSENTIALLY UTILIZES ALL THE SINGLE CCCCC PRECISION STORAGE. C INCLUDE 'DPCOZD.INC' EQUIVALENCE (DGARBG(IDGAR2),Y1(1)) EQUIVALENCE (DGARBG(IDGAR3),Y2(1)) EQUIVALENCE (DGARBG(IDGAR4),Y3(1)) EQUIVALENCE (DGARBG(IDGAR5),Z1(1)) EQUIVALENCE (DGARBG(IDGAR6),Z2(1)) EQUIVALENCE (DGARBG(IDGAR7),Z3(1)) EQUIVALENCE (DGARBG(IDGAR8),Z4(1)) EQUIVALENCE (DGARBG(IDGAR9),Z5(1)) EQUIVALENCE (DGARBG(IDGAR10),Z6(1)) C INCLUDE 'DPCOZI.INC' EQUIVALENCE (IGARBG(IIGAR1),IZ(1)) C C-----COMMON---------------------------------------------------- C INCLUDE 'DPCOSU.INC' INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOHK.INC' INCLUDE 'DPCODA.INC' C C---------------------------------------------------------------- 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='DPLI' ISUBN2='CA ' C MAXCP1=MAXCOL+1 MAXCP2=MAXCOL+2 MAXCP3=MAXCOL+3 MAXCP4=MAXCOL+4 MAXCP5=MAXCOL+5 MAXCP6=MAXCOL+6 C IERROR='NO' C MAXV2=3 MINN2=2 C ICASEQ='UNKN' ICASAN='LICA' C C ***************************************** C ** TREAT THE LINEAR CALIBRATION CASE ** C ***************************************** C IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'LICA')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPLICA--') 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 ') ENDIF C C *************************** C ** STEP 1-- ** C ** EXTRACT THE COMMAND ** C *************************** C ISTEPN='1' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'LICA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.GE.2.AND.ICOM.EQ.'LINE'.AND. 1IHARG(1).EQ.'CALI'.AND.IHARG(2).EQ.'ANAL')GOTO112 IF(NUMARG.GE.2.AND.ICOM.EQ.'QUAD'.AND. 1IHARG(1).EQ.'CALI'.AND.IHARG(2).EQ.'ANAL')THEN ICASAN='QUCA' GOTO112 ENDIF C IF(NUMARG.GE.1.AND.ICOM.EQ.'LINE'.AND. 1IHARG(1).EQ.'CALI')GOTO111 IF(NUMARG.GE.1.AND.ICOM.EQ.'QUAD'.AND. 1IHARG(1).EQ.'CALI')THEN ICASAN='QUCA' GOTO111 ENDIF 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 ICALTY='LINEAR' IF(ICASAN.EQ.'QUCA')ICALTY='QUADRATIC' C C ************************************************** C ** STEP 2-- ** C ** CHECK FOR THE PROPER NUMBER OF INPUT ** C ** ARGUMENTS. ** C ************************************************** C ISTEPN='2' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'LICA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C MINNA=3 MAXNA=100 CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2, 1IERROR) IF(IERROR.EQ.'YES')GOTO9000 C C ******************************************** C ** STEP 3-- ** C ** CHECK THE VALIDITY OF ARGUMENT 1 ** C ** (THIS WILL BE THE DEPENDENT VARIABLE) ** C ******************************************** C ISTEPN='3' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'LICA') 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 4-- ** C ** CHECK THAT THE INPUT NUMBER OF OBSERVATIONS** C ** (NLEFT) ** C ** FOR THE RESPONSE VARIABLE IS 2 OR MORE. ** C ************************************************* C ISTEPN='4' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'LICA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NLEFT.LT.MINN2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,311)ICALTY 311 FORMAT('***** ERROR IN ',A9,' CALIBRATION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,312) 312 FORMAT(' THE INPUT NUMBER OF OBSERVATIONS FOR WHICH A') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,313)ICALTY 313 FORMAT(' ',A9,' CALIBRATION WAS TO HAVE BEEN CARRIED ', 1 'OUT MUST') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,315)MINN2 315 FORMAT(' BE ',I8,' OR LARGER; SUCH WAS NOT THE CASE ', 1 'HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,316)NLEFT 316 FORMAT(' NLEFT = ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,318) 318 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,319)(IANS(I),I=1,MIN(IWIDTH,80)) 319 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C C ***************************************** C ** STEP 5-- ** C ** CHECK TO SEE THE TYPE CASE-- ** C ** 1) UNQUALIFIED (THAT IS, FULL); ** C ** 2) SUBSET/EXCEPT; OR ** C ** 3) FOR. ** C ***************************************** C ISTEPN='5' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C ICASEQ='FULL' ILOCQ=NUMARG+1 IF(NUMARG.LT.1)GOTO490 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 490 CONTINUE IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'LICA')THEN WRITE(ICOUT,491)NUMARG,ILOCQ 491 FORMAT('NUMARG,ILOCQ = ',2I8) CALL DPWRST('XXX','BUG ') ENDIF C C ****************************************** C ** STEP 6-- ** C ** CHECK FOR A VALID NUMBER ** C ** OF VARIABLES (THERE ARE 2 VARIABLES ** C ** FOLLOWED BY ONE PARAMETER OR ** C ** VARIABLE (THIS DEFINES THE VALUES ** C ** AT WHICH TO COMPUTE THE ** C ** CALIBRATION). ** C ** CHECK THE VALIDITY OF EACH ** C ** OF THE VARIABLES (THAT IS, FOR EACH ** C ** OF THE VARIABLES, DOES THE NAME ** C ** EXIST IN THE TABLE? DOES THE NUMBER** C ** OF ELEMENTS AGREE WITH THE NUMBER ** C ** OF ELEMENTS IN THE FIRST VARIABLE? ** C ****************************************** C ISTEPN='6' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'LICA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C NUMVAR=ILOCQ-1 IF(NUMVAR.NE.3)THEN C WRITE(ICOUT,511)ICALTY 511 FORMAT('***** ERROR IN ',A9,' CALIBRATION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,512)ICALTY 512 FORMAT(' FOR A ',A9,' CALIBRATION, THERE MUST BE TWO ', 1 'VARIABLES') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,514) 514 FORMAT(' FOLLOWED BY A PARAMETER/SCALAR VALUE. SUCH ', 1 'WAS NOT') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,515)NUMVAR 515 FORMAT(' THE CASE HERE; THE SPECIFIED NUMBER OF ', 1 'VARIABLES/PARAMETERS WAS ',I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,518) 518 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,519)(IANS(I),I=1,MIN(80,IWIDTH)) 519 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C J=2 IHRIGH=IHARG(J) IHRIG2=IHARG2(J) 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 ICOLIV=IVALUE(ILOCV) NIV=IN(ILOCV) IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'LICA')THEN WRITE(ICOUT,532)IHFACT,IHFAC2,ICOLIV,NIV 532 FORMAT('IFAC,IHFACT,IHFAC2,ICOLIV,NIV = ',A4,2X,A4,I8,I8) CALL DPWRST('XXX','BUG ') ENDIF C IF(NIV.NE.NLEFT)THEN WRITE(ICOUT,551)ICALTY 551 FORMAT('***** ERROR IN ',A9,' CALIBRATION--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,552)ICALTY 552 FORMAT(' FOR A ',A9,' CALIBRATION, THE NUMBER OF ', 1 'ELEMENTS IN') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,554) 554 FORMAT(' THE DEPENDENT AND INDEPENDENT VARIABLES ', 1 'SHOULD BE THE SAME;') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,557) 557 FORMAT(' SUCH WAS NOT THE CASE HERE.') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,562)IHLEFT,IHLEF2,NLEFT 562 FORMAT(' THE DEPENDENT VARIABLE ',A4,A4,' HAS ',I8, 1 ' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,563)IHRIGH,IHRIG2,NIV 563 FORMAT(' THE INDEPENDENT VARIABLE',A4,A4,' HAS ',I8, 1 ' ELEMENTS') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,567) 567 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') CALL DPWRST('XXX','BUG ') IF(IWIDTH.GE.1)THEN WRITE(ICOUT,568)(IANS(I),I=1,MIN(80,IWIDTH)) 568 FORMAT(80A1) CALL DPWRST('XXX','BUG ') ENDIF IERROR='YES' GOTO9000 ENDIF C J=3 IHFACT=IHARG(J) IHFAC2=IHARG2(J) ITYPE='PARA' IF(IARGT(J).EQ.'NUMB')THEN Y0=ARG(J) ELSE IHWUSE='P' MESSAG='NO' CALL CHECKN(IHFACT,IHFAC2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'NO')THEN Y0=VALUE(ILOCV) ELSE IHWUSE='V' MESSAG='YES' CALL CHECKN(IHFACT,IHFAC2,IHWUSE, 1 IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM, 1 ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR) IF(IERROR.EQ.'YES')GOTO9000 ITYPE='VARI' ICOLCV=IVALUE(ILOCV) NCV=IN(ILOCV) ENDIF ENDIF C C ***************************************** C ** STEP 7-- ** C ** BRANCH TO THE APPROPRIATE SUBCASE; ** C ** THEN FORM THE RESPONSE VARIABLE ** C ** AND THE FACTORS ** C ***************************************** C ISTEPN='7' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'LICA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(ICASEQ.EQ.'SUBS')THEN NIOLD=NLEFT CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR) NQ=NIOLD ELSEIF(ICASEQ.EQ.'FOR')THEN NIOLD=NLEFT CALL DPFOR(NIOLD,NFOR,IROW1,IROWN, 1 NLOCAL,ILOCS,NS,IBUGQ,IERROR) NQ=NFOR ELSE DO615I=1,NLEFT ISUB(I)=1 615 CONTINUE NQ=NLEFT ENDIF C 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) C ICOLR=ICOLIV IJ=MAXN*(ICOLR-1)+I IF(ICOLR.LE.MAXCOL)Y2(J)=V(IJ) IF(ICOLR.EQ.MAXCP1)Y2(J)=PRED(I) IF(ICOLR.EQ.MAXCP2)Y2(J)=RES(I) IF(ICOLR.EQ.MAXCP3)Y2(J)=YPLOT(I) IF(ICOLR.EQ.MAXCP4)Y2(J)=XPLOT(I) IF(ICOLR.EQ.MAXCP5)Y2(J)=X2PLOT(I) IF(ICOLR.EQ.MAXCP6)Y2(J)=TAGPLO(I) C 660 CONTINUE NS=J C IF(ITYPE.EQ.'PARA')THEN Y3(1)=Y0 NCALPT=1 ELSE J=0 DO670I=1,NCV J=J+1 C IJ=MAXN*(ICOLCV-1)+I IF(ICOLCV.LE.MAXCOL)Y3(J)=V(IJ) IF(ICOLCV.EQ.MAXCP1)Y3(J)=PRED(I) IF(ICOLCV.EQ.MAXCP2)Y3(J)=RES(I) IF(ICOLCV.EQ.MAXCP3)Y3(J)=YPLOT(I) IF(ICOLCV.EQ.MAXCP4)Y3(J)=XPLOT(I) IF(ICOLCV.EQ.MAXCP5)Y3(J)=X2PLOT(I) IF(ICOLCV.EQ.MAXCP6)Y3(J)=TAGPLO(I) 670 CONTINUE NCALPT=NCV ENDIF C C C *********************************************** C ** STEP 9-- ** C ** CARRY OUT THE LINEAR CALIBRATION ** C *********************************************** C ISTEPN='9' IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'LICA') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'LICA')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,711) 711 FORMAT('***** FROM DPLICA, AS WE ARE ABOUT TO CALL DPLIC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,712)NLEFT,MAXN,NS,NUMVAR 712 FORMAT('NLEFT,MAXN,NS,NUMVAR = ',4I8) CALL DPWRST('XXX','BUG ') DO715I=1,NS WRITE(ICOUT,716)I,Y1(I),Y2(I) 716 FORMAT('I,Y1(I),Y2(I) = ',I6,2X,2G15.7) CALL DPWRST('XXX','BUG ') 715 CONTINUE WRITE(ICOUT,731)IBUGA3 731 FORMAT('IBUGA3 = ',A4) CALL DPWRST('XXX','BUG ') ENDIF C IH='ALPH' IH2='A ' IHWUSE='P' MESSAG='NO' CALL CHECKN(IH,IH2,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) IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)ALPHA=0.05 IF(ALPHA.GT.0.5)ALPHA=1.0 - ALPHA ENDIF C IWRITE='OFF' IF(ICASAN.EQ.'LICA')THEN CALL DPLIC2(Y1,Y2,Y3,NS,NCALPT,NUMVAR, 1 Z1,Z2,Z3,Z4,Z6,IZ, 1 IHLEFT,IHLEF2,IHRIGH,IHRIG2, 1 ALPHA,MAXOBV,ISEED, 1 EISEN,EISENL,EISENU, 1 GRAYB,GRAYBL,GRAYBU, 1 ANWK,ANWKL,ANWKU, 1 PROPE,PROPEL,PROPEU, 1 AINVR,AINVRL,AINVRU, 1 AMLE,AMLEL,AMLEU, 1 BOOTE,BOOTEL,BOOTEU, 1 BOOTW,BOOTWL,BOOTWU, 1 CBAYE,CBAYEL,CBAYEU, 1 FBAYE,FBAYEL,FBAYEU, 1 IWRITE, 1 ICAPSW,ICAPTY, 1 ISUBRO,IBUGA3,IERROR) ELSE CALL DPLIC3(Y1,Y2,Y3,NS,NCALPT,NUMVAR, 1 Z1,Z2,Z3,Z4,Z5,Z6,IZ, 1 IHLEFT,IHLEF2,IHRIGH,IHRIG2, 1 ALPHA,MAXOBV,ISEED, 1 EISEN,EISENL,EISENU, 1 GRAYB,GRAYBL,GRAYBU, 1 ANWK,ANWKL,ANWKU, 1 PROPE,PROPEL,PROPEU, 1 AINVR,AINVRL,AINVRU, 1 AMLE,AMLEL,AMLEU, 1 BOOTE,BOOTEL,BOOTEU, 1 BOOTW,BOOTWL,BOOTWU, 1 CBAYE,CBAYEL,CBAYEU, 1 FBAYE,FBAYEL,FBAYEU, 1 IWRITE, 1 ICAPSW,ICAPTY, 1 ISUBRO,IBUGA3,IERROR) ENDIF C C *************************************** C ** STEP 10-- ** C ** UPDATE INTERNAL DATAPLOT TABLES ** C *************************************** C ISTEPN='10' IF(IBUGA2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IF(NCALPT.GT.1)GOTO9000 IH='EISE' IH2='N ' VALUE0=EISEN CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='EISE' IH2='NLCL' VALUE0=EISENL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='EISE' IH2='NUCL' VALUE0=EISENU CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='GRAY' IH2='B ' VALUE0=GRAYB CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='GRAY' IH2='BLCL' VALUE0=GRAYBL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='GRAY' IH2='BUCL' VALUE0=GRAYBU CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='NWK ' IH2=' ' VALUE0=ANWK CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='NWKL' IH2='CL ' VALUE0=ANWKL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='NWKU' IH2='CL ' VALUE0=ANWKU CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='PROP' IH2='E ' VALUE0=PROPE CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='PROP' IH2='ELCL' VALUE0=PROPEL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='PROP' IH2='EUCL' VALUE0=PROPEU CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='INVE' IH2='R ' VALUE0=AINVR CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='INVE' IH2='RLCL' VALUE0=AINVRL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='INVE' IH2='RUCL' VALUE0=AINVRU CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='MLE ' IH2=' ' VALUE0=AMLE CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='MLEL' IH2='CL ' VALUE0=AMLEL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='MLEU' IH2='CL ' VALUE0=AMLEU CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='BOOT' IH2='E ' VALUE0=BOOTE CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='BOOT' IH2='ELCL' VALUE0=BOOTEL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='BOOT' IH2='EUCL' VALUE0=BOOTEU CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='BOOT' IH2='W ' VALUE0=BOOTW CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='BOOT' IH2='WLCL' VALUE0=BOOTWL CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C IH='BOOT' IH2='WUCL' VALUE0=BOOTWU CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, 1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, 1IANS,IWIDTH,IBUGA3,IERROR) C CCCCC BAYES NOT IMPLEMENTED YET, UNCOMMENT WHEN ACTIVATED IN DPLIC2. C CCCCC IH='CBAY' CCCCC IH2='E ' CCCCC VALUE0=CBAYE CCCCC CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, CCCCC1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, CCCCC1IANS,IWIDTH,IBUGA3,IERROR) C CCCCC IH='CBAY' CCCCC IH2='ELCL' CCCCC VALUE0=CBAYEL CCCCC CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, CCCCC1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, CCCCC1IANS,IWIDTH,IBUGA3,IERROR) C CCCCC IH='CBAY' CCCCC IH2='EUCL' CCCCC VALUE0=CBAYEU CCCCC CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, CCCCC1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, CCCCC1IANS,IWIDTH,IBUGA3,IERROR) C CCCCC IH='FBAY' CCCCC IH2='E ' CCCCC VALUE0=FBAYE CCCCC CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, CCCCC1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, CCCCC1IANS,IWIDTH,IBUGA3,IERROR) C CCCCC IH='FBAY' CCCCC IH2='ELCL' CCCCC VALUE0=FBAYEL CCCCC CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, CCCCC1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, CCCCC1IANS,IWIDTH,IBUGA3,IERROR) C CCCCC IH='FBAY' CCCCC IH2='EUCL' CCCCC VALUE0=FBAYEU CCCCC CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0, CCCCC1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM, CCCCC1IANS,IWIDTH,IBUGA3,IERROR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'LICA')THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9011) 9011 FORMAT('***** AT THE END OF DPLICA--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9012)IBUGA2,IBUGA3,IBUGQ 9012 FORMAT('IBUGA2,IBUGA3,IBUGQ = ',A4,2X,A4,2X,A4) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9014)NS,NUMVAR 9014 FORMAT('NS,NUMVAR = ',2I8) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,9016)IFOUND,IERROR 9016 FORMAT('IFOUND,IERROR = ',A4,2X,A4) CALL DPWRST('XXX','BUG ') ENDIF C RETURN END SUBROUTINE DPLIC2(Y1,Y2,Y3,NPTS,NCALPT,NUMVAR, 1Z1,Z2,Z3,Z4,Z6,IZ, 1IHLEFT,IHLEF2,IHRIGH,IHRIG2, 1ALPHA,MAXNXT,ISEED, 1EISEN,EISENL,EISENU, 1GRAYB,GRAYBL,GRAYBU, 1ANWK,ANWKL,ANWKU, 1PROPE,PROPEL,PROPEU, 1AINVR,AINVRL,AINVRU, 1AMLE,AMLEL,AMLEU, 1BOOTE,BOOTEL,BOOTEU, 1BOOTW,BOOTWL,BOOTWU, 1CBAYE,CBAYEL,CBAYEU, 1FBAYE,FBAYEL,FBAYEU, 1IWRITE, 1ICAPSW,ICAPTY, 1ISUBRO,IBUGA3,IERROR) C C PURPOSE--PERFORM A LINEAR CALIBRATRION ANALYSIS. C A LINEAR CALIBRATION WILL BE PERFORMED USING THE C FOLLOWING TECHNIQUES: C 1) CLASSICAL (EISENHART: INVERSE PREDICTION LIMITS) C 2) GRAYBILL-IYER METHOD C 3) NETER, WASSERMAN, AND KUTNER C 4) PROPOGATION OF ERROR C 5) INVERSE (KRUTCHKOFF) C 6) MAXIMUM LIKELIHOOD C 7) BOOTSTRAP (EFRON) C 8) BOOTSTRAP (WU) C 9) BAYESIAN, CONTROLLED X'S, IMPROPER PRIOR (HOADLEY) C (NOT ON INITIAL IMPLEMENTATION) C 10) BAYESIAN, RANDOM X'S, IMPROPER PRIOR (HOADLEY) C (NOT ON INITIAL IMPLEMENTATION) C PRINTING--YES C SUBROUTINES NEEDED--LINFIT, TPPF C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C INFORMATION TECHNOLOGY LABOARATORY C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899-8980 C PHONE--301-975-2899 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--2003/7 C ORIGINAL VERSION--JULY 2003. C UPDATED --OCTOBER 2003. ADD SUPPORT FOR LATEX OUTPUT 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 ISUBRO CHARACTER*4 ISUBN0 CHARACTER*4 IBUGA3 CHARACTER*4 IERROR C CHARACTER*4 IWRITE CHARACTER*4 IPTEMP C CHARACTER*1 IBASLC C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C CHARACTER*4 IHLEFT CHARACTER*4 IHLEF2 CHARACTER*4 IHRIGH CHARACTER*4 IHRIG2 C CHARACTER*4 ICASJB 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 DSUM DOUBLE PRECISION DMEAN C C---------------------------------------------------------------- C REAL Y1(*) REAL Y2(*) REAL Y3(*) C REAL Z1(*) REAL Z2(*) REAL Z3(*) REAL Z4(*) REAL Z6(*) INTEGER IZ(*) 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='DPLI' ISUBN2='C2 ' C EISEN=0.0 EISENL=0.0 EISENU=0.0 GRAYB=0.0 GRAYBL=0.0 GRAYBU=0.0 ANWK=0.0 ANWKL=0.0 ANWKU=0.0 PROPE=0.0 PROPEL=0.0 PROPEU=0.0 AINVR=0.0 AINVRL=0.0 AINVRU=0.0 AMLE=0.0 AMLEL=0.0 AMLEU=0.0 BOOTE=0.0 BOOTEL=0.0 BOOTEU=0.0 BOOTW=0.0 BOOTWL=0.0 BOOTWU=0.0 CBAYE=0.0 CBAYEL=0.0 CBAYEU=0.0 FBAYE=0.0 FBAYEL=0.0 FBAYEU=0.0 C IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'LIC2')THEN WRITE(ICOUT,999) 999 FORMAT(1X) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,51) 51 FORMAT('***** AT THE BEGINNING OF DPLIC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,52)NPTS,NCALPT,NUMVAR 52 FORMAT('NPTS,NCALPT,NUMVAR = ',3I8) CALL DPWRST('XXX','BUG ') DO55I=1,NPTS WRITE(ICOUT,56)I,Y1(I),Y2(I) 56 FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7) CALL DPWRST('XXX','BUG ') 55 CONTINUE DO65I=1,NCALPT WRITE(ICOUT,66)I,Y3(I) 66 FORMAT('I,Y3(I) = ',I8,G15.7) CALL DPWRST('XXX','BUG ') 65 CONTINUE ENDIF C C ******************************************** C ** STEP 1-- ** C ** CHECK THE INPUT ARGUMENTS FOR ERRORS ** C ******************************************** C IF(NPTS.LT.2)THEN WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,101) 101 FORMAT('***** ERROR IN DPLIC2--') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,102) 102 FORMAT(' THE NUMBER OF OBSERVATIONS FOR THE LINEAR ', 1 'CALIBRATION MUST BE') CALL DPWRST('XXX','BUG ') WRITE(ICOUT,103)NPTS 103 FORMAT(' AT LEAST 2; THE ENTERED NUMBER OF ', 1 'OBSERVATIONS = ',I6) CALL DPWRST('XXX','BUG ') WRITE(ICOUT,999) CALL DPWRST('XXX','BUG ') IERROR='YES' GOTO9000 ENDIF C C ************************************************** C ** STEP 1.1-- ** C ** OPEN THE STORAGE FILES ** C ************************************************** C ISTEPN='1.1' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LIC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C IOUNI1=IST1NU IFILE1=IST1NA ISTAT1=IST1ST IFORM1=IST1FO IACCE1=IST1AC IPROT1=IST1PR ICURS1=IST1CS ISUBN0='LIC2' IERRF1='NO' C IREWI1='ON' CALL DPOPFI(IOUNI1,IFILE1,ISTAT1,IFORM1,IACCE1,IPROT1,ICURS1, 1IREWI1,ISUBN0,IERRF1,IBUGA3,ISUBRO,IERROR) IF(IERRF1.EQ.'YES')GOTO9000 C IOUNI2=IST2NU IFILE2=IST2NA ISTAT2=IST2ST IFORM2=IST2FO IACCE2=IST2AC IPROT2=IST2PR ICURS2=IST2CS ISUBN0='LIC2' IERRF2='NO' C IREWI2='ON' CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2, 1IREWI2,ISUBN0,IERRF2,IBUGA3,ISUBRO,IERROR) IF(IERRF2.EQ.'YES')GOTO9000 C IOUNI3=IST3NU IFILE3=IST3NA ISTAT3=IST3ST IFORM3=IST3FO IACCE3=IST3AC IPROT3=IST3PR ICURS3=IST3CS ISUBN0='LIC2' IERRF3='NO' C IREWI3='ON' CALL DPOPFI(IOUNI3,IFILE3,ISTAT3,IFORM3,IACCE3,IPROT3,ICURS3, 1IREWI3,ISUBN0,IERRF3,IBUGA3,ISUBRO,IERROR) IF(IERRF3.EQ.'YES')GOTO9000 C IOUNI4=IST4NU IFILE4=IST4NA ISTAT4=IST4ST IFORM4=IST4FO IACCE4=IST4AC IPROT4=IST4PR ICURS4=IST4CS ISUBN0='LIC2' IERRF4='NO' C IREWI4='ON' CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4, 1IREWI4,ISUBN0,IERRF4,IBUGA3,ISUBRO,IERROR) IF(IERRF4.EQ.'YES')GOTO9000 C C *********************************************** C ** STEP 2-- ** C ** COMPUTE THE LINEAR FIT AND PRINT OUT ** C ** SUMMARY OF FIT INFORMATION. ** C *********************************************** C ISTEPN='2' IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'LIC2') 1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2) C CALL LINFIT(Y1,Y2,NPTS, 1A0,A1,RESSD,RESDF,CCXY,SDA0,SDA1,CCALBE, 1ISUBRO,IBUGA3,IERROR) C TA0=A0/SDA0 TA1=A1/SDA1 C IF(IERROR.EQ.'YES')GOTO9000 C IF(IPRINT.EQ.'ON')THEN IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'HTML')THEN WRITE(ICOUT,5101) 5101 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5102) 5102 FORMAT('

LINEAR CALIBRATION ANALYSIS

') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5104) 5104 FORMAT('

') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5107) 5107 FORMAT('') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5995) 5995 FORMAT('
') CALL DPWRST('XXX','WRIT') WRITE(ICOUT,5995) CALL DPWRST('XXX','WRIT') WRITE(ICOUT,999) CALL DPWRST('XXX','WRIT') C WRITE(ICOUT,5307) 5307 FORMAT('