fAsianOptions/0000755000176200001440000000000012161705167013035 5ustar liggesusersfAsianOptions/MD50000644000176200001440000000303112161705167013342 0ustar liggesusers9bcd862367e38fd2e8e17c8dd856f16b *ChangeLog 11ea07fce6ca196088f7bb52ad00ba75 *DESCRIPTION 5d0d38953901cdabfa1c56977da4fdf1 *NAMESPACE be7df6130ace1097ba6e8ac0971a7089 *R/BesselFunctions.R b24a5a867d0ecc11c159b1b58cc40393 *R/EBMAsianOptions.R 9882507e5c37d8a890edcaf01bf6f696 *R/EBMDistribution.R e7efd48788e0248853efb338c3fa578e *R/GammaFunctions.R 79480e99627d3c023f20c88e367debbf *R/HypergeometricFunctions.R 3c77bef693ed7c293f2a3319d1edbdba *R/zzz.R 6042b9c5e5bec3ecc1b6959cd2858b64 *inst/COPYRIGHT.html b208277c86926092266ea1ba1d2d9e0b *inst/unitTests/Makefile a516e208a0f1ef3c9f8e2f5e9b36290a *inst/unitTests/runTests.R 797b2a14d90a119ec5660bc95ef33610 *inst/unitTests/runit.BesselFunctions.R 8f4de115f88501c9f00d45ca58fa9fe6 *inst/unitTests/runit.EBMAsianOptions.R fa7baf4aa65c517a5c53548453af02a8 *inst/unitTests/runit.EBMDistribution.R 96610bc14fb29e4680144e0efe31ef33 *inst/unitTests/runit.GammaFunctions.R 197f80aaca6c6221faaabb88d40b083b *inst/unitTests/runit.HypergeometricFunctions.R c0d59ee25dc707e515d2c4953bf1e630 *man/BesselFunctions.Rd bb017f4ecab6bab8d23b1fec1d06c159 *man/EBMAsianOptions.Rd b898124e76be416234c45328f391d2ef *man/EBMDistribution.Rd b206863027bdd6b6f48e264f63352785 *man/GammaFunctions.Rd b0397e3bbfb223909451b1ed199b6894 *man/HypergeometricFunctions.Rd a741df3291ffa772d712e7660ac0c66f *src/EBMAsianOptions.f 00b5c600bd679e0127d91a08cddcbe72 *src/GammaFunctions.f 02b7119a53ace717d00d3538d8ffdd41 *src/HypergeometricFunctions.f 3996e7c16bfb96fad295ee425815cb4d *src/Makevars ca566e590ec30abd0718c5375e1a446f *tests/doRUnit.R fAsianOptions/tests/0000755000176200001440000000000012161636326014177 5ustar liggesusersfAsianOptions/tests/doRUnit.R0000644000176200001440000000151611370220760015701 0ustar liggesusers#### doRUnit.R --- Run RUnit tests ####------------------------------------------------------------------------ ### Origianlly follows Gregor Gojanc's example in CRAN package 'gdata' ### and the corresponding section in the R Wiki: ### http://wiki.r-project.org/rwiki/doku.php?id=developers:runit ### MM: Vastly changed: This should also be "runnable" for *installed* ## package which has no ./tests/ ## ----> put the bulk of the code e.g. in ../inst/unitTests/runTests.R : if(require("RUnit", quietly = TRUE)) { ## --- Setup --- wd <- getwd() pkg <- sub("\\.Rcheck$", '', basename(dirname(wd))) library(package=pkg, character.only = TRUE) path <- system.file("unitTests", package = pkg) stopifnot(file.exists(path), file.info(path.expand(path))$isdir) source(file.path(path, "runTests.R"), echo = TRUE) } fAsianOptions/src/0000755000176200001440000000000012161636326013624 5ustar liggesusersfAsianOptions/src/Makevars0000644000176200001440000000005612161635625015322 0ustar liggesusersPKG_LIBS=$(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) fAsianOptions/src/HypergeometricFunctions.f0000644000176200001440000020746212161636326020665 0ustar liggesusersC ALGORITHM 707, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 18, NO. 3, SEPTEMBER, 1992, PP. 345-349. C **************************************************************** C * * C * SOLUTION TO THE CONFLUENT HYPERGEOMETRIC FUNCTION * C * * C * by * C * * C * MARK NARDIN, * C * * C * W. F. PERGER and ATUL BHALLA * C * * C * * C * Michigan Technological University, Copyright 1989 * C * * C * * C * Description : A numerical evaluator for the confluent * C * hypergeometric function for complex arguments with large * C * magnitudes using a direct summation of the Kummer series. * C * The method used allows an accuracy of up to thirteen * C * decimal places through the use of large real arrays * C * and a single final division. LNCHF is a variable which * C * selects how the result should be represented. A '0' will * C * return the value in standard exponential form. A '1' * C * will return the LOG of the result. IP is an integer * C * variable that specifies how many array positions are * C * desired (usually 10 is sufficient). Setting IP=0 causes * C * the program to estimate the number of array positions. * C * * C * The confluent hypergeometric function is the solution to * C * the differential equation: * C * * C * zf"(z) + (a-z)f'(z) - bf(z) = 0 * C * * C * Subprograms called: BITS, CHGF * C * * C **************************************************************** FUNCTION CONHYP (A,B,Z,LNCHF,IP) INTEGER LNCHF,I,BITS,IP COMPLEX*16 CHGF,A,B,Z,CONHYP DOUBLE PRECISION NTERM,FX,TERM1,MAX,TERM2,ANG IF (CDABS(Z) .NE. 0.0D0) THEN ANG=DATAN2(DIMAG(Z),DBLE(Z)) ELSE ANG=1.0D0 ENDIF IF (DABS(ANG) .LT. (3.14159D0*0.5)) THEN ANG=1.0D0 ELSE ANG=DSIN(DABS(ANG)-(3.14159265D0*0.5D0))+1.0D0 ENDIF MAX=0 NTERM=0 FX=0 TERM1=0 10 NTERM=NTERM+1 TERM2=CDABS((A+NTERM-1)*Z/((B+NTERM-1)*NTERM)) IF (TERM2 .EQ. 0.0D0) GOTO 20 IF (TERM2 .LT. 1.0D0) THEN IF ((DBLE(A)+NTERM-1) .GT. 1.0D0) THEN IF ((DBLE(B)+NTERM-1) .GT. 1.0D0) THEN IF ((TERM2-TERM1) .LT. 0.0D0) THEN GOTO 20 ENDIF ENDIF ENDIF ENDIF FX=FX+DLOG(TERM2) IF (FX .GT. MAX) MAX=FX TERM1=TERM2 GOTO 10 20 MAX=MAX*2/(BITS()*6.93147181D-1) I=INT(MAX*ANG)+7 IF (I .LT. 5) I=5 IF (IP .GT. I) I=IP CONHYP=CHGF(A,B,Z,I,LNCHF) RETURN END C **************************************************************** C * * C * FUNCTION BITS * C * * C * * C * Description : Determines the number of significant figures * C * of machine precision to arrive at the size of the array * C * the numbers must must be stored in to get the accuracy * C * of the solution. * C * * C * Subprogram called: STORE * C * * C **************************************************************** INTEGER FUNCTION BITS() DOUBLE PRECISION BIT,BIT2,STORE INTEGER COUNT BIT=1.0 COUNT=0 10 COUNT=COUNT+1 BIT2=STORE(BIT*2.0) BIT=STORE(BIT2+1.0) IF ((BIT-BIT2) .NE. 0.0) GOTO 10 BITS=COUNT RETURN END DOUBLE PRECISION FUNCTION STORE (X) DOUBLE PRECISION X C C*********************************************************** C C C This function forces its argument X to be stored in a C memory location, thus providing a means of determining C floating point number characteristics (such as the machine C precision) when it is necessary to avoid computation in C high precision registers. C C On input: C C X = Value to be stored. C C X is not altered by this function. C C On output: C C STORE = Value of X after it has been stored and C possibly truncated or rounded to the double C precision word length. C C Modules required by STORE: None C C*********************************************************** C DOUBLE PRECISION Y COMMON/STCOM/Y Y = X STORE = Y RETURN END C **************************************************************** C * * C * FUNCTION CHGF * C * * C * * C * Description : Function that sums the Kummer series and * C * returns the solution of the confluent hypergeometric * C * function. * C * * C * Subprograms called: ARMULT, ARYDIV, BITS, CMPADD, CMPMUL * C * * C **************************************************************** FUNCTION CHGF (A,B,Z,L,LNCHF) PARAMETER (LENGTH=777) INTEGER L,I,BITS,BIT,LNCHF COMPLEX*16 A,B,Z,FINAL,CHGF DOUBLE PRECISION AR,AI,CR,CI,XR,XI,SUMR,SUMI,CNT,SIGFIG,MX1,MX2 DOUBLE PRECISION NUMR,NUMI,DENOMR,DENOMI,RMAX DOUBLE PRECISION QR1,QR2,QI1,QI2,AR2,AI2,CR2,CI2,XR2,XI2 DIMENSION SUMR(-1:LENGTH),SUMI(-1:LENGTH),NUMR(-1:LENGTH) DIMENSION NUMI(-1:LENGTH),DENOMR(-1:LENGTH),DENOMI(-1:LENGTH) DIMENSION QR1(-1:LENGTH),QR2(-1:LENGTH),QI1(-1:LENGTH), : QI2(-1:LENGTH) BIT=BITS() RMAX=2.0D0**(BIT/2) SIGFIG=2.0D0**(BIT/4) AR2=DBLE(A)*SIGFIG AR=DINT(AR2) AR2=DNINT((AR2-AR)*RMAX) AI2=DIMAG(A)*SIGFIG AI=DINT(AI2) AI2=DNINT((AI2-AI)*RMAX) CR2=DBLE(B)*SIGFIG CR=DINT(CR2) CR2=DNINT((CR2-CR)*RMAX) CI2=DIMAG(B)*SIGFIG CI=DINT(CI2) CI2=DNINT((CI2-CI)*RMAX) XR2=DBLE(Z)*SIGFIG XR=DINT(XR2) XR2=DNINT((XR2-XR)*RMAX) XI2=DIMAG(Z)*SIGFIG XI=DINT(XI2) XI2=DNINT((XI2-XI)*RMAX) SUMR(-1)=1.0D0 SUMI(-1)=1.0D0 NUMR(-1)=1.0D0 NUMI(-1)=1.0D0 DENOMR(-1)=1.0D0 DENOMI(-1)=1.0D0 DO 100 I=0,L+1 SUMR(I)=0.0D0 SUMI(I)=0.0D0 NUMR(I)=0.0D0 NUMI(I)=0.0D0 DENOMR(I)=0.0D0 DENOMI(I)=0.0D0 100 CONTINUE SUMR(1)=1.0D0 NUMR(1)=1.0D0 DENOMR(1)=1.0D0 CNT=SIGFIG 110 IF (SUMR(1) .LT. 0.5) THEN MX1=SUMI(L+1) ELSE IF (SUMI(1) .LT. 0.5) THEN MX1=SUMR(L+1) ELSE MX1=DMAX1(SUMR(L+1),SUMI(L+1)) ENDIF IF (NUMR(1) .LT. 0.5) THEN MX2=NUMI(L+1) ELSE IF (NUMI(1) .LT. 0.5) THEN MX2=NUMR(L+1) ELSE MX2=DMAX1(NUMR(L+1),NUMI(L+1)) ENDIF IF (MX1-MX2 .GT. 2.0) THEN IF (CR .GT. 0.0D0) THEN IF (CDABS(CMPLX(AR,AI)*CMPLX(XR,XI)/(CMPLX(CR,CI)*CNT)) : .LE. 1.0D0) GOTO 190 ENDIF ENDIF CALL CMPMUL(SUMR,SUMI,CR,CI,QR1,QI1,L,RMAX) CALL CMPMUL(SUMR,SUMI,CR2,CI2,QR2,QI2,L,RMAX) QR2(L+1)=QR2(L+1)-1 QI2(L+1)=QI2(L+1)-1 CALL CMPADD(QR1,QI1,QR2,QI2,SUMR,SUMI,L,RMAX) CALL ARMULT(SUMR,CNT,SUMR,L,RMAX) CALL ARMULT(SUMI,CNT,SUMI,L,RMAX) CALL CMPMUL(DENOMR,DENOMI,CR,CI,QR1,QI1,L,RMAX) CALL CMPMUL(DENOMR,DENOMI,CR2,CI2,QR2,QI2,L,RMAX) QR2(L+1)=QR2(L+1)-1 QI2(L+1)=QI2(L+1)-1 CALL CMPADD(QR1,QI1,QR2,QI2,DENOMR,DENOMI,L,RMAX) CALL ARMULT(DENOMR,CNT,DENOMR,L,RMAX) CALL ARMULT(DENOMI,CNT,DENOMI,L,RMAX) CALL CMPMUL(NUMR,NUMI,AR,AI,QR1,QI1,L,RMAX) CALL CMPMUL(NUMR,NUMI,AR2,AI2,QR2,QI2,L,RMAX) QR2(L+1)=QR2(L+1)-1 QI2(L+1)=QI2(L+1)-1 CALL CMPADD(QR1,QI1,QR2,QI2,NUMR,NUMI,L,RMAX) CALL CMPMUL(NUMR,NUMI,XR,XI,QR1,QI1,L,RMAX) CALL CMPMUL(NUMR,NUMI,XR2,XI2,QR2,QI2,L,RMAX) QR2(L+1)=QR2(L+1)-1 QI2(L+1)=QI2(L+1)-1 CALL CMPADD(QR1,QI1,QR2,QI2,NUMR,NUMI,L,RMAX) CALL CMPADD(SUMR,SUMI,NUMR,NUMI,SUMR,SUMI,L,RMAX) CNT=CNT+SIGFIG AR=AR+SIGFIG CR=CR+SIGFIG GOTO 110 190 CALL ARYDIV(SUMR,SUMI,DENOMR,DENOMI,FINAL,L,LNCHF,RMAX,BIT) CHGF=FINAL RETURN END C **************************************************************** C * * C * SUBROUTINE ARADD * C * * C * * C * Description : Accepts two arrays of numbers and returns * C * the sum of the array. Each array is holding the value * C * of one number in the series. The parameter L is the * C * size of the array representing the number and RMAX is * C * the actual number of digits needed to give the numbers * C * the desired accuracy. * C * * C * Subprograms called: none * C * * C **************************************************************** SUBROUTINE ARADD(A,B,C,L,RMAX) INTEGER L DOUBLE PRECISION A,B,C,Z,RMAX INTEGER EDIFF,I,J DIMENSION A(-1:*),B(-1:*),C(-1:*),Z(-1:777) DO 110 I=0,L+1 Z(I)=0.0D0 110 CONTINUE EDIFF=DNINT(A(L+1)-B(L+1)) IF (DABS(A(1)) .LT. 0.5 .OR. EDIFF .LE. -L) GOTO 111 IF (DABS(B(1)) .LT. 0.5 .OR. EDIFF .GE. L) GOTO 113 GOTO 115 111 DO 112 I=-1,L+1 C(I)=B(I) 112 CONTINUE GOTO 311 113 DO 114 I=-1,L+1 C(I)=A(I) 114 CONTINUE GOTO 311 115 Z(-1)=A(-1) IF (DABS(A(-1)-B(-1)) .LT. 0.5) GOTO 200 IF (EDIFF .GT. 0) THEN Z(L+1)=A(L+1) GOTO 233 ENDIF IF (EDIFF .LT. 0) THEN Z(L+1)=B(L+1) Z(-1)=B(-1) GOTO 266 ENDIF DO 120 I=1,L IF (A(I) .GT. B(I)) THEN Z(L+1)=A(L+1) GOTO 233 ENDIF IF (A(I) .LT. B(I)) THEN Z(L+1)=B(L+1) Z(-1)=B(-1) GOTO 266 ENDIF 120 CONTINUE GOTO 300 200 IF (EDIFF .GT. 0) GOTO 203 IF (EDIFF .LT. 0) GOTO 207 Z(L+1)=A(L+1) DO 201 I=L,1,-1 Z(I)=A(I)+B(I)+Z(I) IF (Z(I) .GE. RMAX) THEN Z(I)=Z(I)-RMAX Z(I-1)=1.0D0 ENDIF 201 CONTINUE IF (Z(0) .GT. 0.5) THEN DO 202 I=L,1,-1 Z(I)=Z(I-1) 202 CONTINUE Z(L+1)=Z(L+1)+1.0D0 Z(0)=0.0D0 ENDIF GOTO 300 203 Z(L+1)=A(L+1) DO 204 I=L,1+EDIFF,-1 Z(I)=A(I)+B(I-EDIFF)+Z(I) IF (Z(I) .GE. RMAX) THEN Z(I)=Z(I)-RMAX Z(I-1)=1.0D0 ENDIF 204 CONTINUE DO 205 I=EDIFF,1,-1 Z(I)=A(I)+Z(I) IF (Z(I) .GE. RMAX) THEN Z(I)=Z(I)-RMAX Z(I-1)=1.0D0 ENDIF 205 CONTINUE IF (Z(0) .GT. 0.5) THEN DO 206 I=L,1,-1 Z(I)=Z(I-1) 206 CONTINUE Z(L+1)=Z(L+1)+1 Z(0)=0.0D0 ENDIF GOTO 300 207 Z(L+1)=B(L+1) DO 208 I=L,1-EDIFF,-1 Z(I)=A(I+EDIFF)+B(I)+Z(I) IF (Z(I) .GE. RMAX) THEN Z(I)=Z(I)-RMAX Z(I-1)=1.0D0 ENDIF 208 CONTINUE DO 209 I=0-EDIFF,1,-1 Z(I)=B(I)+Z(I) IF (Z(I) .GE. RMAX) THEN Z(I)=Z(I)-RMAX Z(I-1)=1.0D0 ENDIF 209 CONTINUE IF (Z(0) .GT. 0.5) THEN DO 210 I=L,1,-1 Z(I)=Z(I-1) 210 CONTINUE Z(L+1)=Z(L+1)+1.0D0 Z(0)=0.0D0 ENDIF GOTO 300 233 IF (EDIFF .GT. 0) GOTO 243 DO 234 I=L,1,-1 Z(I)=A(I)-B(I)+Z(I) IF (Z(I) .LT. 0.0D0) THEN Z(I)=Z(I)+RMAX Z(I-1)=-1.0D0 ENDIF 234 CONTINUE GOTO 290 243 DO 244 I=L,1+EDIFF,-1 Z(I)=A(I)-B(I-EDIFF)+Z(I) IF (Z(I) .LT. 0.0D0) THEN Z(I)=Z(I)+RMAX Z(I-1)=-1.0D0 ENDIF 244 CONTINUE DO 245 I=EDIFF,1,-1 Z(I)=A(I)+Z(I) IF (Z(I) .LT. 0.0D0) THEN Z(I)=Z(I)+RMAX Z(I-1)=-1.0D0 ENDIF 245 CONTINUE GOTO 290 266 IF (EDIFF .LT. 0) GOTO 276 DO 267 I=L,1,-1 Z(I)=B(I)-A(I)+Z(I) IF (Z(I) .LT. 0.0D0) THEN Z(I)=Z(I)+RMAX Z(I-1)=-1.0D0 ENDIF 267 CONTINUE GOTO 290 276 DO 277 I=L,1-EDIFF,-1 Z(I)=B(I)-A(I+EDIFF)+Z(I) IF (Z(I) .LT. 0.0D0) THEN Z(I)=Z(I)+RMAX Z(I-1)=-1.0D0 ENDIF 277 CONTINUE DO 278 I=0-EDIFF,1,-1 Z(I)=B(I)+Z(I) IF (Z(I) .LT. 0.0D0) THEN Z(I)=Z(I)+RMAX Z(I-1)=-1.0D0 ENDIF 278 CONTINUE 290 IF (Z(1) .GT. 0.5) GOTO 300 I=1 291 I=I+1 IF (Z(I) .LT. 0.5 .AND. I .LT. L+1) GOTO 291 IF (I .EQ. L+1) THEN Z(-1)=1.0D0 Z(L+1)=0.0D0 GOTO 300 ENDIF DO 293 J=1,L+1-I Z(J)=Z(J+I-1) 293 CONTINUE DO 294 J=L+2-I,L Z(J)=0.0D0 294 CONTINUE Z(L+1)=Z(L+1)-I+1 300 DO 310 I=-1,L+1 C(I)=Z(I) 310 CONTINUE 311 IF (C(1) .LT. 0.5) THEN C(-1)=1.0D0 C(L+1)=0.0D0 ENDIF RETURN END C **************************************************************** C * * C * SUBROUTINE ARSUB * C * * C * * C * Description : Accepts two arrays and subtracts each element * C * in the second array from the element in the first array * C * and returns the solution. The parameters L and RMAX are * C * the size of the array and the number of digits needed for * C * the accuracy, respectively. * C * * C * Subprograms called: ARADD * C * * C **************************************************************** SUBROUTINE ARSUB(A,B,C,L,RMAX) INTEGER L,I DOUBLE PRECISION A,B,C,B2,RMAX DIMENSION A(-1:*),B(-1:*),C(-1:*),B2(-1:777) DO 100 I=-1,L+1 B2(I)=B(I) 100 CONTINUE B2(-1)=(-1.0D0)*B2(-1) CALL ARADD(A,B2,C,L,RMAX) RETURN END C **************************************************************** C * * C * SUBROUTINE ARMULT * C * * C * * C * Description : Accepts two arrays and returns the product. * C * L and RMAX are the size of the arrays and the number of * C * digits needed to represent the numbers with the required * C * accuracy. * C * * C * Subprograms called: none * C * * C **************************************************************** SUBROUTINE ARMULT(A,B,C,L,RMAX) INTEGER L DOUBLE PRECISION A,B,C,Z,B2,CARRY,RMAX,RMAX2 DIMENSION A(-1:*),C(-1:*),Z(-1:777) INTEGER I RMAX2=1.0D0/RMAX Z(-1)=DSIGN(1.0D0,B)*A(-1) B2=DABS(B) Z(L+1)=A(L+1) DO 100 I=0,L Z(I)=0.0D0 100 CONTINUE IF (B2 .LE. 1.0D-10 .OR. A(1) .LE. 1.0D-10) THEN Z(-1)=1.0D0 Z(L+1)=0.0D0 GOTO 198 ENDIF DO 110 I=L,1,-1 Z(I)=A(I)*B2+Z(I) IF (Z(I) .GE. RMAX) THEN CARRY=DINT(Z(I)/RMAX) Z(I)=Z(I)-CARRY*RMAX Z(I-1)=CARRY ENDIF 110 CONTINUE IF (Z(0) .LT. 0.5) GOTO 150 DO 120 I=L,1,-1 Z(I)=Z(I-1) 120 CONTINUE Z(L+1)=Z(L+1)+1.0D0 Z(0)=0.0D0 150 CONTINUE 198 DO 199 I=-1,L+1 C(I)=Z(I) 199 CONTINUE IF (C(1) .LT. 0.5) THEN C(-1)=1.0D0 C(L+1)=0.0D0 ENDIF RETURN END C **************************************************************** C * * C * SUBROUTINE CMPADD * C * * C * * C * Description : Takes two arrays representing one real and * C * one imaginary part, and adds two arrays representing * C * another complex number and returns two array holding the * C * complex sum. * C * (CR,CI) = (AR+BR, AI+BI) * C * * C * Subprograms called: ARADD * C * * C **************************************************************** SUBROUTINE CMPADD(AR,AI,BR,BI,CR,CI,L,RMAX) INTEGER L DOUBLE PRECISION AR,AI,BR,BI,CR,CI,RMAX DIMENSION AR(-1:*),AI(-1:*),BR(-1:*),BI(-1:*) DIMENSION CR(-1:*),CI(-1:*) CALL ARADD(AR,BR,CR,L,RMAX) CALL ARADD(AI,BI,CI,L,RMAX) RETURN END C **************************************************************** C * * C * SUBROUTINE CMPSUB * C * * C * * C * Description : Takes two arrays representing one real and * C * one imaginary part, and subtracts two arrays representing * C * another complex number and returns two array holding the * C * complex sum. * C * (CR,CI) = (AR+BR, AI+BI) * C * * C * Subprograms called: ARADD * C * * C **************************************************************** SUBROUTINE CMPSUB(AR,AI,BR,BI,CR,CI,L,RMAX) INTEGER L DOUBLE PRECISION AR,AI,BR,BI,CR,CI,RMAX DIMENSION AR(-1:*),AI(-1:*),BR(-1:*),BI(-1:*) DIMENSION CR(-1:*),CI(-1:*) CALL ARSUB(AR,BR,CR,L,RMAX) CALL ARSUB(AI,BI,CI,L,RMAX) RETURN END C **************************************************************** C * * C * SUBROUTINE CMPMUL * C * * C * * C * Description : Takes two arrays representing one real and * C * one imaginary part, and multiplies it with two arrays * C * representing another complex number and returns the * C * complex product. * C * * C * Subprograms called: ARMULT, ARSUB, ARADD * C * * C **************************************************************** SUBROUTINE CMPMUL(AR,AI,BR,BI,CR,CI,L,RMAX) INTEGER L DOUBLE PRECISION AR,AI,BR,BI,CR,CI,D1,D2,RMAX DIMENSION AR(-1:*),AI(-1:*),CR(-1:*),CI(-1:*) DIMENSION D1(-1:777),D2(-1:777) CALL ARMULT(AR,BR,D1,L,RMAX) CALL ARMULT(AI,BI,D2,L,RMAX) CALL ARSUB(D1,D2,CR,L,RMAX) CALL ARMULT(AR,BI,D1,L,RMAX) CALL ARMULT(AI,BR,D2,L,RMAX) CALL ARADD(D1,D2,CI,L,RMAX) RETURN END C **************************************************************** C * * C * SUBROUTINE ARYDIV * C * * C * * C * Description : Returns the double precision complex number * C * resulting from the division of four arrays, representing * C * two complex numbers. The number returned will be in one * C * two different forms. Either standard scientific or as * C * the log of the number. * C * * C * Subprograms called: CONV21, CONV12, EADD, ECPDIV, EMULT * C * * C **************************************************************** SUBROUTINE ARYDIV(AR,AI,BR,BI,C,L,LNCHF,RMAX,BIT) INTEGER L,BIT,REXP,IR10,II10,LNCHF COMPLEX*16 C DOUBLE PRECISION AR,AI,BR,BI,PHI,N1,N2,N3,E1,E2,E3,RR10,RI10,X DOUBLE PRECISION AE,BE,X1,X2,DUM1,DUM2,CE,RMAX DIMENSION AR(-1:*),AI(-1:*),BR(-1:*),BI(-1:*) DIMENSION AE(2,2),BE(2,2),CE(2,2) REXP=BIT/2 X=REXP*(AR(L+1)-2) RR10=X*DLOG10(2.0D0)/DLOG10(10.0D0) IR10=INT(RR10) RR10=RR10-IR10 X=REXP*(AI(L+1)-2) RI10=X*DLOG10(2.0D0)/DLOG10(10.0D0) II10=INT(RI10) RI10=RI10-II10 DUM1=DSIGN(AR(1)*RMAX*RMAX+AR(2)*RMAX+AR(3),AR(-1)) DUM2=DSIGN(AI(1)*RMAX*RMAX+AI(2)*RMAX+AI(3),AI(-1)) DUM1=DUM1*10**RR10 DUM2=DUM2*10**RI10 CALL CONV12(DCMPLX(DUM1,DUM2),AE) AE(1,2)=AE(1,2)+IR10 AE(2,2)=AE(2,2)+II10 X=REXP*(BR(L+1)-2) RR10=X*DLOG10(2.0D0)/DLOG10(10.0D0) IR10=INT(RR10) RR10=RR10-IR10 X=REXP*(BI(L+1)-2) RI10=X*DLOG10(2.0D0)/DLOG10(10.0D0) II10=INT(RI10) RI10=RI10-II10 DUM1=DSIGN(BR(1)*RMAX*RMAX+BR(2)*RMAX+BR(3),BR(-1)) DUM2=DSIGN(BI(1)*RMAX*RMAX+BI(2)*RMAX+BI(3),BI(-1)) DUM1=DUM1*10**RR10 DUM2=DUM2*10**RI10 CALL CONV12(DCMPLX(DUM1,DUM2),BE) BE(1,2)=BE(1,2)+IR10 BE(2,2)=BE(2,2)+II10 CALL ECPDIV(AE,BE,CE) IF (LNCHF .EQ. 0) THEN CALL CONV21(CE,C) ELSE CALL EMULT(CE(1,1),CE(1,2),CE(1,1),CE(1,2),N1,E1) CALL EMULT(CE(2,1),CE(2,2),CE(2,1),CE(2,2),N2,E2) CALL EADD(N1,E1,N2,E2,N3,E3) N1=CE(1,1) E1=CE(1,2)-CE(2,2) X2=CE(2,1) IF (E1 .GT. 74.0D0) THEN X1=1.0D75 ELSEIF (E1 .LT. -74.0D0) THEN X1=0 ELSE X1=N1*(10**E1) ENDIF PHI=DATAN2(X2,X1) C=DCMPLX(0.50D0*(DLOG(N3)+E3*DLOG(10.0D0)),PHI) ENDIF RETURN END C **************************************************************** C * * C * SUBROUTINE EMULT * C * * C * * C * Description : Takes one base and exponent and multiplies it * C * by another numbers base and exponent to give the product * C * in the form of base and exponent. * C * * C * Subprograms called: none * C * * C **************************************************************** SUBROUTINE EMULT(N1,E1,N2,E2,NF,EF) DOUBLE PRECISION N1,E1,N2,E2,NF,EF NF=N1*N2 EF=E1+E2 IF (DABS(NF) .GE. 10.0D0) THEN NF=NF/10.0D0 EF=EF+1.0D0 ENDIF RETURN END C **************************************************************** C * * C * SUBROUTINE EDIV * C * * C * * C * Description : returns the solution in the form of base and * C * exponent of the division of two exponential numbers. * C * * C * Subprograms called: none * C * * C **************************************************************** SUBROUTINE EDIV(N1,E1,N2,E2,NF,EF) DOUBLE PRECISION N1,E1,N2,E2,NF,EF NF=N1/N2 EF=E1-E2 IF ((DABS(NF) .LT. 1.0D0) .AND. (NF .NE. 0.0D0)) THEN NF=NF*10.0D0 EF=EF-1.0D0 ENDIF RETURN END C **************************************************************** C * * C * SUBROUTINE EADD * C * * C * * C * Description : Returns the sum of two numbers in the form * C * of a base and an exponent. * C * * C * Subprograms called: none * C * * C **************************************************************** SUBROUTINE EADD(N1,E1,N2,E2,NF,EF) DOUBLE PRECISION N1,E1,N2,E2,NF,EF,EDIFF EDIFF=E1-E2 IF (EDIFF .GT. 36.0D0) THEN NF=N1 EF=E1 ELSE IF (EDIFF .LT. -36.0D0) THEN NF=N2 EF=E2 ELSE NF=N1*(10.0D0**EDIFF)+N2 EF=E2 400 IF (DABS(NF) .LT. 10.0D0) GOTO 410 NF=NF/10.0D0 EF=EF+1.0D0 GOTO 400 410 IF ((DABS(NF) .GE. 1.0D0) .OR. (NF .EQ. 0.0D0)) GOTO 420 NF=NF*10.0D0 EF=EF-1.0D0 GOTO 410 ENDIF 420 RETURN END C **************************************************************** C * * C * SUBROUTINE ESUB * C * * C * * C * Description : Returns the solution to the subtraction of * C * two numbers in the form of base and exponent. * C * * C * Subprograms called: EADD * C * * C **************************************************************** SUBROUTINE ESUB(N1,E1,N2,E2,NF,EF) DOUBLE PRECISION N1,E1,N2,E2,NF,EF CALL EADD(N1,E1,N2*(-1.0D0),E2,NF,EF) RETURN END C **************************************************************** C * * C * SUBROUTINE CONV12 * C * * C * * C * Description : Converts a number from complex notation to a * C * form of a 2x2 real array. * C * * C * Subprograms called: none * C * * C **************************************************************** SUBROUTINE CONV12(CN,CAE) COMPLEX*16 CN DOUBLE PRECISION CAE DIMENSION CAE(2,2) CAE(1,1)=DBLE(CN) CAE(1,2)=0.0D0 300 IF (DABS(CAE(1,1)) .LT. 10.0D0) GOTO 310 CAE(1,1)=CAE(1,1)/10.0D0 CAE(1,2)=CAE(1,2)+1.0D0 GOTO 300 310 IF ((DABS(CAE(1,1)) .GE. 1.0D0) .OR. (CAE(1,1) .EQ. 0.0D0)) : GOTO 320 CAE(1,1)=CAE(1,1)*10.0D0 CAE(1,2)=CAE(1,2)-1.0D0 GOTO 310 320 CAE(2,1)=DIMAG(CN) CAE(2,2)=0.0D0 330 IF (DABS(CAE(2,1)) .LT. 10.0D0) GOTO 340 CAE(2,1)=CAE(2,1)/10.0D0 CAE(2,2)=CAE(2,2)+1.0D0 GOTO 330 340 IF ((DABS(CAE(2,1)) .GE. 1.0D0) .OR. (CAE(2,1) .EQ. 0.0D0)) : GOTO 350 CAE(2,1)=CAE(2,1)*10.0D0 CAE(2,2)=CAE(2,2)-1.0D0 GOTO 340 350 RETURN END C **************************************************************** C * * C * SUBROUTINE CONV21 * C * * C * * C * Description : Converts a number represented in a 2x2 real * C * array to the form of a complex number. * C * * C * Subprograms called: none * C * * C **************************************************************** SUBROUTINE CONV21(CAE,CN) DOUBLE PRECISION CAE COMPLEX*16 CN DIMENSION CAE(2,2) IF (CAE(1,2) .GT. 75 .OR. CAE(2,2) .GT. 75) THEN CN=DCMPLX(1.0D75,1.0D75) ELSE IF (CAE(2,2) .LT. -75) THEN CN=DCMPLX(CAE(1,1)*(10**CAE(1,2)),0D0) ELSE CN=DCMPLX(CAE(1,1)*(10**CAE(1,2)),CAE(2,1)*(10**CAE(2,2))) ENDIF RETURN END C **************************************************************** C * * C * SUBROUTINE ECPMUL * C * * C * * C * Description : Multiplies two numbers which are each * C * represented in the form of a two by two array and returns * C * the solution in the same form. * C * * C * Subprograms called: EMULT, ESUB, EADD * C * * C **************************************************************** SUBROUTINE ECPMUL(A,B,C) DOUBLE PRECISION A,B,C,N1,E1,N2,E2,C2 DIMENSION A(2,2),B(2,2),C(2,2),C2(2,2) CALL EMULT(A(1,1),A(1,2),B(1,1),B(1,2),N1,E1) CALL EMULT(A(2,1),A(2,2),B(2,1),B(2,2),N2,E2) CALL ESUB(N1,E1,N2,E2,C2(1,1),C2(1,2)) CALL EMULT(A(1,1),A(1,2),B(2,1),B(2,2),N1,E1) CALL EMULT(A(2,1),A(2,2),B(1,1),B(1,2),N2,E2) CALL EADD(N1,E1,N2,E2,C(2,1),C(2,2)) C(1,1)=C2(1,1) C(1,2)=C2(1,2) RETURN END C **************************************************************** C * * C * SUBROUTINE ECPDIV * C * * C * * C * Description : Divides two numbers and returns the solution. * C * All numbers are represented by a 2x2 array. * C * * C * Subprograms called: EADD, ECPMUL, EDIV, EMULT * C * * C **************************************************************** SUBROUTINE ECPDIV(A,B,C) DOUBLE PRECISION A,B,C,N1,E1,N2,E2,B2,N3,E3,C2 DIMENSION A(2,2),B(2,2),C(2,2),B2(2,2),C2(2,2) B2(1,1)=B(1,1) B2(1,2)=B(1,2) B2(2,1)=-1.0D0*B(2,1) B2(2,2)=B(2,2) CALL ECPMUL(A,B2,C2) CALL EMULT(B(1,1),B(1,2),B(1,1),B(1,2),N1,E1) CALL EMULT(B(2,1),B(2,2),B(2,1),B(2,2),N2,E2) CALL EADD(N1,E1,N2,E2,N3,E3) CALL EDIV(C2(1,1),C2(1,2),N3,E3,C(1,1),C(1,2)) CALL EDIV(C2(2,1),C2(2,2),N3,E3,C(2,1),C(2,2)) RETURN END C ***************************************************************************** SUBROUTINE CHFM(ZRE,ZIM,ARE,AIM,BRE,BIM,CRE,CIM,N,LNCHF,IP) REAL*8 ZRE(N), ZIM(N), CRE(N), CIM(N) REAL*8 ARE, AIM, BRE, BIM COMPLEX*16 Z, A, B, CHF, CONHYP A = CMPLX(ARE, AIM) B = CMPLX(BRE, BIM) DO I=1,N Z = CMPLX(ZRE(I), ZIM(I)) CHF = CONHYP(A, B, Z, LNCHF, IP) CRE(I) = DREAL(CHF) CIM(I) = DIMAG(CHF) ENDDO RETURN END C ***************************************************************************** C SUBROUTINE DRIVER_CHF() C REAL*8 ZRE(2), ZIM(2), ARE, AIM, BRE, BIM, CRE(2), CIM(2)C C ZRE(1) = 1.1D0 C ZIM(1) = 0.6D0 C ZRE(2) = -2.6D0 C ZIM(2) = 0.8D0 C ARE = 1.2D0 C AIM = 1.4D0 C BRE = 2.1D0 C BIM = 1.3D0 C LNCHF=0 C IP=0 C CALL CHFM(ZRE,ZIM,ARE,AIM,BRE,BIM,CRE,CIM,2,LNCHF,IP) C WRITE (*,*) "M:" C WRITE(*,*) ZRE(1), ZIM(1), CRE(1), CIM(1) C WRITE(*,*) ZRE(2), ZIM(2), CRE(2), CIM(2) C RETURN C END c PROGRAM TEST c CALL DRIVER_CHF() c STOP c END C ----------------------------------------------------------------------------- fAsianOptions/src/GammaFunctions.f0000644000176200001440000001250412161636326016710 0ustar liggesusers C FROM: http://iris-lee3.ece.uiuc.edu/~jjin/routines/routines.html C All the programs and subroutines contained in this archive are C copyrighted. However, we give permission to the user who downloads C these routines to incorporate any of these routines into his or C her programs provided that the copyright is acknowledged. C Contact Information C Email: j-jin1@uiuc.edu C Phone: (217) 244-0756 C Fax: (217) 333-5962 C Professor Jianming Jin C Department of Electrical and Computer Engineering C University of Illinois at Urbana-Champaign C 461 William L Everitt Laboratory C 1406 West Green Street C Urbana, IL 61801-2991 C ****************************************************************************** SUBROUTINE CGAMA(X,Y,KF,GR,GI) C C ========================================================= C Purpose: Compute the gamma function â(z) or ln[â(z)] C for a complex argument C Input : x --- Real part of z C y --- Imaginary part of z C KF --- Function code C KF=0 for ln[â(z)] C KF=1 for â(z) C Output: GR --- Real part of ln[â(z)] or â(z) C GI --- Imaginary part of ln[â(z)] or â(z) C ======================================================== C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(10) PI=3.141592653589793D0 DATA A/8.333333333333333D-02,-2.777777777777778D-03, & 7.936507936507937D-04,-5.952380952380952D-04, & 8.417508417508418D-04,-1.917526917526918D-03, & 6.410256410256410D-03,-2.955065359477124D-02, & 1.796443723688307D-01,-1.39243221690590D+00/ CC DW Y1 = 0.0D0 X1 = 0.0D0 NA = 0 CC DW IF (Y.EQ.0.0D0.AND.X.EQ.INT(X).AND.X.LE.0.0D0) THEN GR=1.0D+300 GI=0.0D0 RETURN ELSE IF (X.LT.0.0D0) THEN X1=X Y1=Y X=-X Y=-Y ENDIF X0=X IF (X.LE.7.0) THEN NA=INT(7-X) X0=X+NA ENDIF Z1=DSQRT(X0*X0+Y*Y) TH=DATAN(Y/X0) GR=(X0-.5D0)*DLOG(Z1)-TH*Y-X0+0.5D0*DLOG(2.0D0*PI) GI=TH*(X0-0.5D0)+Y*DLOG(Z1)-Y DO 10 K=1,10 T=Z1**(1-2*K) GR=GR+A(K)*T*DCOS((2.0D0*K-1.0D0)*TH) 10 GI=GI-A(K)*T*DSIN((2.0D0*K-1.0D0)*TH) IF (X.LE.7.0) THEN GR1=0.0D0 GI1=0.0D0 DO 15 J=0,NA-1 GR1=GR1+.5D0*DLOG((X+J)**2+Y*Y) 15 GI1=GI1+DATAN(Y/(X+J)) GR=GR-GR1 GI=GI-GI1 ENDIF IF (X1.LT.0.0D0) THEN Z1=DSQRT(X*X+Y*Y) TH1=DATAN(Y/X) SR=-DSIN(PI*X)*DCOSH(PI*Y) SI=-DCOS(PI*X)*DSINH(PI*Y) Z2=DSQRT(SR*SR+SI*SI) TH2=DATAN(SI/SR) IF (SR.LT.0.0D0) TH2=PI+TH2 GR=DLOG(PI/(Z1*Z2))-GR GI=-TH1-TH2-GI X=X1 Y=Y1 ENDIF IF (KF.EQ.1) THEN G0=DEXP(GR) GR=G0*DCOS(GI) GI=G0*DSIN(GI) ENDIF RETURN END C ****************************************************************************** SUBROUTINE CPSI(X,Y,PSR,PSI) C C ============================================= C Purpose: Compute the psi function for a C complex argument C Input : x --- Real part of z C y --- Imaginary part of z C Output: PSR --- Real part of psi(z) C PSI --- Imaginary part of psi(z) C ============================================= C IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION A(8) DATA A/-.8333333333333D-01,.83333333333333333D-02, & -.39682539682539683D-02,.41666666666666667D-02, & -.75757575757575758D-02,.21092796092796093D-01, & -.83333333333333333D-01,.4432598039215686D0/ PI=3.141592653589793D0 CC DW Y1 = 0.0D0 X1 = 0.0D0 N = 0 CC DW IF (Y.EQ.0.0D0.AND.X.EQ.INT(X).AND.X.LE.0.0D0) THEN PSR=1.0D+300 PSI=0.0D0 ELSE IF (X.LT.0.0D0) THEN X1=X Y1=Y X=-X Y=-Y ENDIF X0=X IF (X.LT.8.0D0) THEN N=8-INT(X) X0=X+N ENDIF IF (X0.EQ.0.0D0.AND.Y.NE.0.0D0) TH=0.5D0*PI IF (X0.NE.0.0D0) TH=DATAN(Y/X0) Z2=X0*X0+Y*Y Z0=DSQRT(Z2) PSR=DLOG(Z0)-0.5D0*X0/Z2 PSI=TH+0.5D0*Y/Z2 DO 10 K=1,8 PSR=PSR+A(K)*Z2**(-K)*DCOS(2.0D0*K*TH) 10 PSI=PSI-A(K)*Z2**(-K)*DSIN(2.0D0*K*TH) IF (X.LT.8.0D0) THEN RR=0.0D0 RI=0.0D0 DO 20 K=1,N RR=RR+(X0-K)/((X0-K)**2.0D0+Y*Y) 20 RI=RI+Y/((X0-K)**2.0D0+Y*Y) PSR=PSR-RR PSI=PSI+RI ENDIF IF (X1.LT.0.0D0) THEN TN=DTAN(PI*X) TM=DTANH(PI*Y) CT2=TN*TN+TM*TM PSR=PSR+X/(X*X+Y*Y)+PI*(TN-TN*TM*TM)/CT2 PSI=PSI-Y/(X*X+Y*Y)-PI*TM*(1.0D0+TN*TN)/CT2 X=X1 Y=Y1 ENDIF ENDIF RETURN END C ------------------------------------------------------------------------------ fAsianOptions/src/EBMAsianOptions.f0000644000176200001440000037024612161636326016742 0ustar liggesusers C added R print function to ensure that output goes to console output C ------------------------------------------------------------------------------ C ALGORITHM 540R (REMARK ON ALG.540), COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 18, NO. 3, SEPTEMBER, 1992, PP. 343-344. C C USED FOR: C PROGRAM RUNPDE C FOR TESTING AND DEBUGGING UNDER FORTRAN C CALL PDETEST() C END C MODEL 1: VECER's PDE C MODEL 2: ZHANG's PDE C Small modification to avoid gfortran warning: 'Rank mismatch in C argument 'x' at (1) (rank-1 and scalar)' by Yohan Chalabi on C March 2012 C ------------------------------------------------------------------------------ c$$$ c$$$ SUBROUTINE PDETEST() c$$$CC NOT USED BY R c$$$CC FOR TESTING AND DEBUGGING UNDER FORTRAN c$$$ IMPLICIT REAL*8 (A-H, O-Z) c$$$ PARAMETER(MNP=10) c$$$ DIMENSION PRICE(MNP+1), XBYS(MNP+1) c$$$C c$$$ PARAMETER (MMF=12, MMX=1000) c$$$ PARAMETER (MNPDE=1, MKORD=4, MNINT=MMX, MNCC=2, MMAXDER=5) c$$$ c$$$C WORKING ARRAYS: c$$$ DIMENSION WORK c$$$ * (MKORD+MNPDE*(4+9*MNPDE)+(MKORD+(MNINT-1)*(MKORD-MNCC))* c$$$ * (3*MKORD+2+MNPDE*(3*(MKORD-1)*MNPDE+MMAXDER+4))) c$$$ DIMENSION IWORK((MNPDE+1)*(MKORD+(MNINT-1)*(MKORD-MNCC))) c$$$ DIMENSION XBKPT(MNINT+1) c$$$ c$$$C PDE PARAMETERS: c$$$ NP = MNP c$$$ MF = MMF c$$$ MX = MMX c$$$ NPDE = MNPDE c$$$ KORD = MKORD c$$$ NINT = MNINT c$$$ NCC = MNCC c$$$ MAXDER = MMAXDER c$$$ c$$$C OPTION SETTINGS: c$$$ SIGMA = 0.30D0 c$$$ TIME = 1.00D0 c$$$ RR = 0.09D0 c$$$ XS = 100.00D0 c$$$ XSMIN = 90.00D0 c$$$ XSMAX = 110.00D0 c$$$ SS = 100.00D0 c$$$ DELTA = (XSMAX-XSMIN)/NP c$$$ DO I = 1, NP+1 c$$$ XBYS(I) = (XSMIN +(I-1)*DELTA)/XS c$$$ ENDDO c$$$ c$$$C SET TIME POINTS: c$$$C T0 = INITIAL VALUE OF T, THE INDEPENDENT VARIABLE c$$$C TOUT = VALUE OF T AT WHICH OUTPUT IS DESIRED NEXT c$$$C DT = INITIAL STEP SIZE IN T c$$$C EPS = RELATIVE TIME ERROR BOUND c$$$ T0 = 0.0D0 c$$$ TOUT = 1.0D0 c$$$ EPS = 1.0D-08 c$$$ DT = 1.0D-10 c$$$ c$$$C FURTHER PARAMETERS: c$$$C NINT=1000 - NUMBER OF SUBINTERVALS (XLEFT,XRIGHT) IS TO BE DIVIDED c$$$C KORD=4 - ORDER OF THE PIECEWISE POLYNOMIAL SPACE TO BE USED c$$$C NCC=2 - NUMBER OF CONTINUITY CONDITIONS TO BE IMPOSED c$$$C MF=12 - METHOD FLAG c$$$C ADAMS METHODS - GENERALIZATIONS OF CRANK-NICOLSON AND c$$$C CHORD METHOD WITH FINITE DIFFERENCES JACOBIAN c$$$C INDEX - INTEGER USED ON INPUT TO INDICATE TYPE OF CALL c$$$C WORK - WORKING ARRAY c$$$C IWORK - SIZE OF WORKING ARRAY c$$$ c$$$C ASIAN CALL (1) AND PUT(2) VALUE: c$$$ Z = -1 c$$$ DO IP = 1, 2 c$$$ Z = -Z c$$$C PDE PARAMETERS: c$$$ MODSEL = 1 c$$$ SIGMAT = SIGMA * DSQRT(TIME) c$$$ RRT = RR*TIME c$$$ XM = 5.0D0 * SIGMAT c$$$ WRITE (*,*) c$$$ WRITE (*,*) " PDE - ASIAN OPTION SETTINGS" c$$$ WRITE (*,*) " MF KORD NCC : ", MF, KORD, NCC c$$$ WRITE (*,*) " SIGMA*TIME : ", SIGMAT c$$$ WRITE (*,*) " R*TIME : ", RRT c$$$ WRITE (*,*) " XM : ", XM c$$$ WRITE (*,*) " (XMIN,XMAX)/S : ", XSMIN/SS, XSMAX/SS c$$$ CALL ASIANVAL( c$$$ & Z, SS, XS, XSMIN, XSMAX, TIME, RR, SIGMA, c$$$ & T0, TOUT, EPS, DT, PRICE, NP, MODSEL, c$$$ & MF, NPDE, KORD, MX, NCC, MAXDER, c$$$ & XBYS, XBKPT, WORK, IWORK) c$$$C OUTPUT U - NUMERICAL SOLUTION: c$$$ WRITE (*,*) " XLEFT XRIGHT : ", XBKPT(1), XBKPT(NINT+1) c$$$ WRITE (*,*) " EPS DT MX : ", EPS, DT, MX c$$$ WRITE (*,*) " ERROR CODE: : ", INDEX c$$$ WRITE(*,*) c$$$ WRITE(*,*) " U - NUMERICAL SOLUTION FOR DIFF STRIKES:" c$$$ WRITE(*,*) " X XI PRICE " c$$$ DO I = 1, NP+1 c$$$ XI = XBYS(I)*EXP(-RRT) - (1.0-EXP(-RRT))/RRT c$$$ WRITE(*,9) XS*XBYS(I), SS*XI, SS*PRICE(I), SS*(PRICE(I)-XI) c$$$ ENDDO c$$$ ENDDO c$$$ 9 FORMAT(F10.3, 4F15.7) c$$$ c$$$ RETURN c$$$ END C ------------------------------------------------------------------------------ SUBROUTINE ASIANVAL( & ZZ, SS1, XS1, XSMIN, XSMAX, TIME1, RR1, SIGMA1, & T0, TOUT, EPS, DT, PRICEBYS, NP, MODSEL, & MF1, NPDE1, KORD1, MX1, NCC1, MAXDER1, & XBYS, XBKPT, WORK, IWORK) IMPLICIT REAL*8 (A-H, O-Z) PARAMETER(MKORD=4, MDERV=0) DIMENSION WORK * (KORD1+NPDE1*(4+9*NPDE1)+(KORD1+(MX1-1)*(KORD1-NCC1))* * (3*KORD1+2+NPDE1*(3*(KORD1-1)*NPDE1+MAXDER1+4))) DIMENSION IWORK((NPDE1+1)*(KORD1+(MX1-1)*(KORD1-NCC1))) DIMENSION XBKPT(MX1+1) DIMENSION USOL(1,1,MDERV+1), SCRTCH(MKORD*(MDERV+1)) DIMENSION XBYS(NP), PRICEBYS(NP) COMMON /SIZES/ NINT,KORD,NCC,NPDE,NCPTS,NEQN,IQUAD COMMON /GEAR0/ HUSED, NQUSED, NS, NF, NJ COMMON /GEAR1/ T,DTC,DTMN,DTMX,EPSC,UROUND,N,MFC,KFLAG,JSTART COMMON /GEAR9/ EPSJ,R0,ML,MU,MW,NM1,N0ML,N0W COMMON /OPTION/ NOGAUS,MAXDER COMMON /ISTART/ IW1, IW2, IW3, IDUM(15) COMMON /PARAMS/ PI COMMON /ASIAN1/ SIGMAT, RRT, XM, Z, MODEL COMMON /ASIAN2/ SIGMA, TIME, RR, XS, SS, ETA, XL, XR DIMENSION XI(1) C FOR COMMON BLOCKS: SIGMA = SIGMA1 TIME = TIME1 RR = RR1 XS = XS1 SS = SS1 C FOR COMMON BLOCKS: MF = MF1 NPDE = NPDE1 KORD = KORD1 MX = MX1 NCC = NCC1 MAXDER = MAXDER1 NINT = MX1 MODEL = MODSEL PI = 4.0D0 * DATAN(1.0D0) C CALCULATE FOR BOTH, FOR A CALL Z=+1 OR FOR A PUT Z=-1: Z = ZZ C WORKSPACE SETTINGS: IWORK(1) = KORD+NPDE*(4+9*NPDE)+(KORD+(MX-1)* * (KORD-NCC))*(3*KORD+2+NPDE*(3*(KORD-1)*NPDE+MAXDER+4)) IWORK(2) = (NPDE+1)*(KORD+(NINT-1)*(KORD-NCC)) DO I = 1, IWORK(1) WORK(I)=0.0 ENDDO C OPTION SETTINGS: SIGMAT = SIGMA * DSQRT(TIME) RRT = RR*TIME XM = 5.0D0 * SIGMAT XL = -XM XR = +XM ETA = (SIGMA**2)*(TIME**3)/6.0D0 C SET SPACE POINTS: NX = MX DX = 2.0D0 * XM / NX DO I = 1, NX + 1 XBKPT(I) = -XM + (I-1)*DX ENDDO C SOLVE PDE: INDEX = 1 CALL PDECOL(T0, TOUT, DT, XBKPT, EPS, & NX, KORD, NCC, NPDE, MF, INDEX, WORK, IWORK) C OUTPUT U - NUMERICAL SOLUTION: DO I = 1, NP+1 XI(1) = XBYS(I)*DEXP(-RRT) - (1.0D0-DEXP(-RRT))/RRT CALL VALUES(XI, USOL, SCRTCH, 1, 1, 1, 0, WORK) PRICEBYS(I) = USOL(1,1,1) ENDDO RETURN END C ------------------------------------------------------------------------------ SUBROUTINE F(T, X, U, UX, UXX, FVAL, NPDE) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION U(NPDE), UX(NPDE), UXX(NPDE), FVAL(NPDE) COMMON /GEAR0/ HUSED, NQUSED, NS, NF, NJ COMMON /PARAMS/ PI COMMON /ASIAN1/ SIGMAT, RRT, XM, Z, MODEL COMMON /ASIAN2/ SIGMA, TIME, RR, XS, SS, ETA, XL, XR IF (MODEL.EQ.1) THEN FR = (1.0D0-DEXP(-RR*T))/RRT FVAL(1) = (0.5D0*SIGMAT*SIGMAT) * ((X+FR)**2) * UXX(1) ENDIF IF (MODEL.EQ.2) THEN RT = (1.0D0-DEXP(-RR*T))/RR PF = (X*SIGMA*SIGMA)/(4.0D0*DSQRT(PI*ETA)) FVAL(1) = (0.5D0*SIGMA*SIGMA) * ((X+RT)**2) * UXX(1) FVAL(1) = FVAL(1) + PF*DEXP(-0.25D0*X*X/ETA)*(X+2.0D0*RT) ENDIF RETURN END C ------------------------------------------------------------------------------ SUBROUTINE BNDRY(T, X, U, UX, DBDU, DBDUX, DZDT, NPDE) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION U(NPDE), UX(NPDE), DZDT(NPDE) DIMENSION DBDU(NPDE,NPDE), DBDUX(NPDE,NPDE) COMMON /ASIAN1/ SIGMAT, RRT, XM, Z, MODEL COMMON /ASIAN2/ SIGMA, TIME, RR, XS, SS, ETA, XL, XR C LEFT/RIGHT BOUNDARY MODEL 1: IF (MODEL.EQ.1) THEN IF (X.LE.-XM) THEN DBDU (1,1) = (-Z*X + DABS(X) ) / 2.0D0 DBDUX(1,1) = 0.0D0 DZDT (1) = 0.0D0 RETURN ENDIF IF (X.LE.XM) THEN DBDU (1,1) = (-Z*X + DABS(X) ) / 2.0D0 DBDUX(1,1) = 0.0D0 DZDT (1) = 0.0D0 RETURN ENDIF ENDIF C LEFT/RIGHT BOUNDARY MODEL 2: IF (MODEL.EQ.2) THEN EPS = 1.0D-20 IF (X.LE.XL ) THEN DBDU (1,1) = EPS DBDUX(1,1) = 0.0D0 DZDT (1) = 0.0D0 RETURN ENDIF IF (X.GE.XR ) THEN DBDU (1,1) = EPS DBDUX(1,1) = 0.0D0 DZDT (1) = 0.0D0 RETURN ENDIF ENDIF RETURN END C ------------------------------------------------------------------------------ SUBROUTINE UINIT(X, U, NPDE) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION U(NPDE) COMMON /ASIAN1/ SIGMAT, RRT, XM, Z, MODEL COMMON /ASIAN2/ SIGMA, TIME, RR, XS, SS, ETA, XL, XR C NOTE : Z=+1 FOR A CALL AND Z-1 FOR A PUT IF (MODEL.EQ.1) THEN U(1) = ( (-Z*X) + DABS(-X) ) / 2.0D0 ENDIF IF (MODEL.EQ.2) THEN U(1) = 0.0D0 ENDIF RETURN END C ------------------------------------------------------------------------------ SUBROUTINE DERIVF(T, X, U, UX, UXX, DFDU, DFDUX, DFDUXX, NPDE) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION U(NPDE), UX(NPDE), UXX(NPDE) DIMENSION DFDU(NPDE,NPDE), DFDUX(NPDE,NPDE), DFDUXX(NPDE,NPDE) COMMON /ASIAN1/ SIGMAT, RRT, XM, Z, MODEL COMMON /ASIAN2/ SIGMA, TIME, RR, XS, SS, ETA, XL, XR C C IF THE USER DESIRES TO USE THE MF = 11 OR 21 OPTION IN ORDER TO SAVE C ABOUT 10-20 PERCENT IN EXECUTION TIME (SEE BELOW), THEN THE USER MUST C PROVIDE THE FOLLOWING SUBROUTINE WHICH PROVIDES INFORMATION ABOUT THE C DERIVATIVES OF THE FUNCTION F ABOVE. THIS PROVIDES FOR MORE EFFICIENT C JACOBIAN MATRIX GENERATION. ON MOST COMPUTER SYSTEMS, THE USER WILL C BE REQUIRED TO SUPPLY THIS SUBROUTINE AS A DUMMY SUBROUTINE IF THE C OPTIONS MF = 12 OR 22 ARE USED (SEE BELOW). C C THE PACKAGE PROVIDES VALUES OF THE INPUT VARIABLES T, X, U, UX, C AND UXX, AND THE USER SHOULD CONSTRUCT THIS ROUTINE TO PROVIDE C THE FOLLOWING CORRESPONDING VALUES OF THE OUTPUT ARRAYS C DFDU, DFDUX, AND DFDUXX FOR K,J = 1 TO NPDE... C DFDU(K,J) = PARTIAL DERIVATIVE OF THE K-TH COMPONENT OF THE C PDE DEFINING FUNCTION F WITH RESPECT TO THE C VARIABLE U(J). C DFDUX(K,J) = PARTIAL DERIVATIVE OF THE K-TH COMPONENT OF THE C PDE DEFINING FUNCTION F WITH RESPECT TO THE C VARIABLE UX(J). C DFDUXX(K,J) = PARTIAL DERIVATIVE OF THE K-TH COMPONENT OF THE C PDE DEFINING FUNCTION F WITH RESPECT TO THE C VARIABLE UXX(J). C NOTE... THE INCOMING VALUE OF X WILL BE A COLLOCATION POINT C VALUE. PI = 4.0 * DATAN(1.0D0) IF (MODEL.EQ.1) THEN RT = (1.0D0-EXP(-RRT*T))/RRT DFDU(1,1) = 0.0D0 DFDUX(1,1) = 0.0D0 DFDUXX(1,1) = (SIGMAT**2) * ( X + RT ) ENDIF IF (MODEL.EQ.1) THEN RT = (1.0D0-DEXP(-RR*T))/RR F1 = (X*SIGMA*SIGMA)/(4.0D0*DSQRT(PI*ETA)) F2 = DEXP(-0.25D0*X*X/ETA) F3 = (X+2.0D0*RT) DF1 = F1 / X DF2 = -2.0D0 * X * F2 / (4.0D0*ETA) DF3 = 1.0D0 DFDUXX(1,1) = (SIGMA**2) * ( X + RT ) DFDUX(1,1) = 0.0D0 DFDU(1,1) = DF1*F2*F3 + F1*DF2*F3 + F1*F2*DF3 ENDIF RETURN END C ############################################################################## C ALGORITHM 540R (REMARK ON ALG.540), COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 18, NO. 3, SEPTEMBER, 1992, PP. 343-344. C C SUBROUTINE PDECOL(T0, TOUT, DT, XBKPT, EPS, NINT, KORD, * NCC, NPDE, MF, INDEX, WORK, IWORK) IMPLICIT REAL*8 (A-H, O-Z) EXTERNAL REALPR, INTPR C C C------------------------------------------------------------------------------- C C THIS IS THE MARCH 24, 1978 VERSION OF PDECOL. C C THIS PACKAGE WAS CONSTRUCTED SO AS TO CONFORM TO AS MANY ANSI-FORTRAN C RULES AS WAS CONVENIENTLY POSSIBLE. THE FORTRAN USED VIOLATES ANSI C STANDARDS IN THE TWO WAYS LISTED BELOW.... C C 1. SUBSCRIPTS OF THE GENERAL FORM C*V1 + V2 + V3 ARE USED C (POSSIBLY IN A PERMUTED ORDER), WHERE C IS AN INTEGER CONSTANT C AND V1, V2, AND V3 ARE INTEGER VARIABLES. C C 2. ARRAY NAMES APPEAR SINGLY IN DATA STATEMENTS IN THE ROUTINES C BSPLVN AND COSET. C C MACHINE DEPENDENT FEATURES...... C C THIS VERSION OF PDECOL WAS DESIGNED FOR USE ON CDC MACHINES WITH C A WORD LENGTH OF 60 BITS. WE DO NOT RECOMMEND THE USE OF PDECOL WITH C WORD LENGTHS OF LESS THAN 48 BITS. THE MOST IMPORTANT MACHINE C AND WORD LENGTH DEPENDENT CONSTANTS ARE DEFINED IN THE BLOCK DATA C AND IN SUBROUTINES COLPNT AND COSET. THE USER SHOULD CHECK THESE C CAREFULLY FOR APPROPRIATENESS FOR HIS LOCAL SITUATION. THE FORTRAN C FUNCTIONS USED BY EACH ROUTINE ARE LISTED IN THE COMMENTS TO C FACILITATE CONVERSION TO DOUBLE PRECISION. C C------------------------------------------------------------------------------- C C PDECOL IS THE DRIVER ROUTINE FOR A SOPHISTICATED PACKAGE OF C SUBROUTINES WHICH IS DESIGNED TO SOLVE THE GENERAL SYSTEM OF C NPDE NONLINEAR PARTIAL DIFFERENTIAL EQUATIONS OF AT MOST SECOND C ORDER ON THE INTERVAL (XLEFT,XRIGHT) FOR T .GT. T0 WHICH IS OF THE C FORM.... C C DU/DT = F( T, X, U, UX, UXX ) C C WHERE C C U = ( U(1), U(2), ... , U(NPDE) ) C UX = ( UX(1), UX(2), ... , UX(NPDE) ) C UXX = (UXX(1),UXX(2), ... ,UXX(NPDE) ) . C C EACH U(K) IS A FUNCTION OF THE SCALAR QUANTITIES T AND X. C UX(K) REPRESENTS THE FIRST PARTIAL DERIVATIVE OF U(K) WITH RESPECT C TO THE VARIABLE X, UXX(K) REPRESENTS THE SECOND PARTIAL DERIVATIVE C OF U(K) WITH RESPECT TO THE VARIABLE X, AND DU/DT IS THE VECTOR OF C PARTIAL DERIVATIVES OF U WITH RESPECT TO THE TIME VARIABLE T. C F REPRESENTS AN ARBITRARY VECTOR VALUED FUNCTION WHOSE NPDE C COMPONENTS DEFINE THE RESPECTIVE PARTIAL DIFFERENTIAL EQUATIONS OF C THE PDE SYSTEM. SEE SUBROUTINE F DESCRIPTION BELOW. C C BOUNDARY CONDITIONS C C DEPENDING ON THE TYPE OF PDE(S), 0, 1, OR 2 BOUNDARY CONDITIONS C ARE REQUIRED FOR EACH PDE IN THE SYSTEM. THESE ARE IMPOSED AT XLEFT C AND/OR XRIGHT AND EACH MUST BE OF THE FORM.... C C B(U,UX) = Z(T) C C WHERE B AND Z ARE ARBITRARY VECTOR VALUED FUNCTIONS WITH C NPDE COMPONENTS AND U, UX, AND T ARE AS ABOVE. THESE BOUNDARY C CONDITIONS MUST BE CONSISTENT WITH THE INITIAL CONDITIONS WHICH ARE C DESCRIBED NEXT. C C INITIAL CONDITIONS C C EACH SOLUTION COMPONENT U(K) IS ASSUMED TO BE A KNOWN (USER C PROVIDED) FUNCTION OF X AT THE INITIAL TIME T = T0. THE C INITIAL CONDITION FUNCTIONS MUST BE CONSISTENT WITH THE BOUNDARY C CONDITIONS ABOVE, I.E. THE INITIAL CONDITION FUNCTIONS MUST C SATISFY THE BOUNDARY CONDITIONS FOR T = T0. SEE SUBROUTINE UINIT C DESCRIPTION BELOW. C C------------------------------------------------------------------------------- C C REQUIRED USER SUPPLIED SUBROUTINES C C THE USER IS REQUIRED TO CONSTRUCT THREE SUBPROGRAMS AND A MAIN C PROGRAM WHICH DEFINE THE PDE PROBLEM WHOSE SOLUTION IS TO BE C ATTEMPTED. THE THREE SUBPROGRAMS ARE... C C 1) SUBROUTINE F( T, X, U, UX, UXX, FVAL, NPDE ) C DIMENSION U(NPDE), UX(NPDE), UXX(NPDE), FVAL(NPDE) C THIS ROUTINE DEFINES THE DESIRED PARTIAL DIFFERENTIAL C EQUATIONS TO BE SOLVED. THE PACKAGE PROVIDES VALUES OF THE C INPUT SCALARS T AND X AND INPUT ARRAYS (LENGTH NPDE) U, UX, C AND UXX, AND THE USER MUST CONSTRUCT THIS ROUTINE TO COMPUTE C THE OUTPUT ARRAY FVAL (LENGTH NPDE) WHICH CONTAINS THE C CORRESPONDING VALUES OF THE RIGHT HAND SIDES OF THE DESIRED C PARTIAL DIFFERENTIAL EQUATIONS, I.E. C C FVAL(K) = THE VALUE OF THE RIGHT HAND SIDE OF THE K-TH PDE IN C THE PDE SYSTEM ABOVE, FOR K = 1 TO NPDE. C C THE INCOMING VALUE OF THE SCALAR QUANTITY X WILL BE A C COLLOCATION POINT VALUE (SEE INITAL AND COLPNT) AND THE C INCOMING VALUES IN THE ARRAYS U, UX AND UXX CORRESPOND TO THIS C POINT X AND TIME T. C RETURN C END C C 2) SUBROUTINE BNDRY( T, X, U, UX, DBDU, DBDUX, DZDT, NPDE ) C DIMENSION U(NPDE), UX(NPDE), DZDT(NPDE) C DIMENSION DBDU(NPDE,NPDE), DBDUX(NPDE,NPDE) C THIS ROUTINE IS USED TO PROVIDE THE PDE PACKAGE WITH NEEDED C INFORMATION ABOUT THE BOUNDARY CONDITION FUNCTIONS B AND Z C ABOVE. THE PACKAGE PROVIDES VALUES OF THE INPUT VARIABLES C T, X, U, AND UX, AND THE USER IS TO DEFINE THE CORRESPONDING C OUTPUT VALUES OF THE DERIVATIVES OF THE FUNCTIONS B AND Z C WHERE.... C DBDU(K,J) = PARTIAL DERIVATIVE OF THE K-TH COMPONENT OF THE C VECTOR FUNCTION B(U,UX) ABOVE WITH RESPECT TO C THE J-TH VARIABLE U(J). C DBDUX(K,J) = PARTIAL DERIVATIVE OF THE K-TH COMPONENT OF THE C VECTOR FUNCTION B(U,UX) ABOVE WITH RESPECT TO C THE J-TH VARIABLE UX(J). C DZDT(K) = DERIVATIVE OF THE K-TH COMPONENT OF THE VECTOR C FUNCTION Z(T) ABOVE WITH RESPECT TO THE C VARIABLE T. C NOTE... THE INCOMING VALUE OF X WILL BE EITHER XLEFT OR XRIGHT. C IF NO BOUNDARY CONDITION IS DESIRED FOR SAY THE K-TH PDE AT C ONE OR BOTH OF THE ENDPOINTS XLEFT OR XRIGHT, THEN DBDU(K,K) C AND DBDUX(K,K) SHOULD BOTH BE SET TO ZERO WHEN BNDRY IS C CALLED FOR THAT POINT. WE REFER TO THIS AS A NULL BOUNDARY C CONDITION. THIS ROUTINE CAN BE STRUCTURED AS FOLLOWS... C THE COMMON BLOCK /ENDPT/ IS NOT A PART OF PDECOL AND C MUST BE SUPPLIED AND DEFINED BY THE USER. C COMMON /ENDPT/ XLEFT C IF( X .NE. XLEFT ) GO TO 10 C HERE DEFINE AND SET PROPER VALUES FOR DBDU(K,J), DBDUX(K,J), C AND DZDT(K) FOR K,J = 1 TO NPDE FOR THE LEFT BOUNDARY POINT C X = XLEFT. C RETURN C 10 CONTINUE C HERE DEFINE AND SET PROPER VALUES FOR DBDU(K,J), DBDUX(K,J), C AND DZDT(K) FOR K,J = 1 TO NPDE FOR THE RIGHT BOUNDARY POINT C X = XRIGHT. C RETURN C END C C 3) SUBROUTINE UINIT( X, U, NPDE ) C DIMENSION U(NPDE) C THIS ROUTINE IS USED TO PROVIDE THE PDE PACKAGE WITH THE C NEEDED INITIAL CONDITION FUNCTION VALUES. THE PACKAGE C PROVIDES A VALUE OF THE INPUT VARIABLE X, AND THE USER IS TO C DEFINE THE PROPER INITIAL VALUES (AT T = T0) FOR ALL OF THE C PDE COMPONENTS, I.E. C U(K) = DESIRED INITIAL VALUE OF PDE COMPONENT U(K) AT C X AND T = T0 FOR K = 1 TO NPDE. C NOTE... THE INCOMING VALUE OF X WILL BE A COLLOCATION POINT C VALUE. THE INITIAL CONDITIONS AND BOUNDARY CONDITIONS C MUST BE CONSISTENT (SEE ABOVE). C RETURN C END C C------------------------------------------------------------------------------- C C OPTIONAL USER SUPPLIED SUBROUTINE C C IF THE USER DESIRES TO USE THE MF = 11 OR 21 OPTION IN ORDER TO SAVE C ABOUT 10-20 PERCENT IN EXECUTION TIME (SEE BELOW), THEN THE USER MUST C PROVIDE THE FOLLOWING SUBROUTINE WHICH PROVIDES INFORMATION ABOUT THE C DERIVATIVES OF THE FUNCTION F ABOVE. THIS PROVIDES FOR MORE EFFICIENT C JACOBIAN MATRIX GENERATION. ON MOST COMPUTER SYSTEMS, THE USER WILL C BE REQUIRED TO SUPPLY THIS SUBROUTINE AS A DUMMY SUBROUTINE IF THE C OPTIONS MF = 12 OR 22 ARE USED (SEE BELOW). C C 1) SUBROUTINE DERIVF( T, X, U, UX, UXX, DFDU, DFDUX, DFDUXX, NPDE ) C DIMENSION U(NPDE), UX(NPDE), UXX(NPDE) C DIMENSION DFDU(NPDE,NPDE), DFDUX(NPDE,NPDE), DFDUXX(NPDE,NPDE) C THE PACKAGE PROVIDES VALUES OF THE INPUT VARIABLES T, X, U, UX, C AND UXX, AND THE USER SHOULD CONSTRUCT THIS ROUTINE TO PROVIDE C THE FOLLOWING CORRESPONDING VALUES OF THE OUTPUT ARRAYS C DFDU, DFDUX, AND DFDUXX FOR K,J = 1 TO NPDE... C DFDU(K,J) = PARTIAL DERIVATIVE OF THE K-TH COMPONENT OF THE C PDE DEFINING FUNCTION F WITH RESPECT TO THE C VARIABLE U(J). C DFDUX(K,J) = PARTIAL DERIVATIVE OF THE K-TH COMPONENT OF THE C PDE DEFINING FUNCTION F WITH RESPECT TO THE C VARIABLE UX(J). C DFDUXX(K,J) = PARTIAL DERIVATIVE OF THE K-TH COMPONENT OF THE C PDE DEFINING FUNCTION F WITH RESPECT TO THE C VARIABLE UXX(J). C NOTE... THE INCOMING VALUE OF X WILL BE A COLLOCATION POINT C VALUE. C RETURN C END C C------------------------------------------------------------------------------- C C METHODS USED C C THE PACKAGE PDECOL IS BASED ON THE METHOD OF LINES AND USES A C FINITE ELEMENT COLLOCATION PROCEDURE (WITH PIECEWISE POLYNOMIALS C AS THE TRIAL SPACE) FOR THE DISCRETIZATION OF THE SPATIAL VARIABLE C X. THE COLLOCATION PROCEDURE REDUCES THE PDE SYSTEM TO A SEMI- C DISCRETE SYSTEM WHICH THEN DEPENDS ONLY ON THE TIME VARIABLE T. C THE TIME INTEGRATION IS THEN ACCOMPLISHED BY USE OF SLIGHTLY C MODIFIED STANDARD TECHNIQUES (SEE REFS. 1,2). C C PIECEWISE POLYNOMIALS C C THE USER IS REQUIRED TO SELECT THE PIECEWISE POLYNOMIAL SPACE C WHICH IS TO BE USED TO COMPUTE HIS APPROXIMATE SOLUTION. FIRST, THE C ORDER, KORD, OF THE POLYNOMIALS TO BE USED MUST BE SPECIFIED C (KORD = POLYNOMIAL DEGREE + 1). NEXT, THE NUMBER OF PIECES C (INTERVALS), NINT, INTO WHICH THE SPATIAL DOMAIN (XLEFT,XRIGHT) IS C TO BE DIVIDED, IS CHOSEN. THE NINT + 1 DISTINCT BREAKPOINTS OF C THE DOMAIN MUST BE DEFINED AND SET INTO THE ARRAY XBKPT IN C STRICTLY INCREASING ORDER, I.E. C XLEFT=XBKPT(1) .LT. XBKPT(2) .LT. ... .LT. XBKPT(NINT+1)=XRIGHT. C THE APPROXIMATE SOLUTION AT ANY TIME T WILL BE A POLYNOMIAL OF C ORDER KORD OVER EACH SUBINTERVAL (XBKPT(I),XBKPT(I+1)). THE C NUMBER OF CONTINUITY CONDITIONS, NCC, TO BE IMPOSED ACROSS ALL OF C THE BREAKPOINTS IS THE LAST PIECE OF USER SUPPLIED DATA WHICH IS C REQUIRED TO UNIQUELY DETERMINE THE DESIRED PIECEWISE POLYNOMIAL C SPACE. FOR EXAMPLE, NCC = 2 WOULD REQUIRE THAT THE APPROXIMATE C SOLUTION (MADE UP OF THE SEPARATE POLYNOMIAL PIECES) AND ITS FIRST C SPATIAL DERIVATIVE BE CONTINUOUS AT THE BREAKPOINTS AND HENCE ON C THE ENTIRE DOMAIN (XLEFT,XRIGHT). NCC = 3 WOULD REQUIRE THAT THE C APPROXIMATE SOLUTION AND ITS FIRST AND SECOND SPATIAL DERIVATIVES C BE CONTINUOUS AT THE BREAKPOINTS, ETC. THE DIMENSION OF THIS LINEAR C SPACE IS KNOWN AND FINITE AND IS NCPTS = KORD*NINT - NCC*(NINT-1). C THE WELL-KNOWN B-SPLINE BASIS (SEE REF. 3) FOR THIS SPACE IS USED C BY PDECOL AND IT CONSISTS OF NCPTS KNOWN PIECEWISE POLYNOMIAL C FUNCTIONS BF(I,X), FOR I=1 TO NCPTS, WHICH DO NOT DEPEND ON THE C TIME VARIABLE T. WE WISH TO EMPHASIZE THAT THE PIECEWISE POLYNOMIAL C SPACE USED IN PDECOL (WHICH IS SELECTED BY THE USER) WILL DETERMINE C THE MAGNITUDE OF THE SPATIAL DISCRETIZATION ERRORS IN THE COMPUTED C APPROXIMATE SOLUTION. THE PACKAGE HAS NO CONTROL OVER ERRORS C INTRODUCED BY THE USERS CHOICE OF THIS SPACE. SEE INPUT PARAMETERS C BELOW. C C COLLOCATION OVER PIECEWISE POLYNOMIALS C C THE BASIC ASSUMPTION MADE IS THAT THE APPROXIMATE SOLUTION C SATISFIES C NCPTS C U(T,X) = SUM C(I,T) * BF(I,X) C I=1 C C WHERE THE UNKNOWN COEFFICIENTS C DEPEND ONLY ON THE TIME T AND C THE KNOWN BASIS FUNCTIONS DEPEND ONLY ON X (WE HAVE ASSUMED THAT C NPDE = 1 FOR CONVENIENCE). SO, AT ANY GIVEN TIME T THE APPROX- C IMATE SOLUTION IS A PIECEWISE POLYNOMIAL IN THE USER CHOSEN SPACE. C THE SEMI-DISCRETE EQUATIONS (ACTUALLY ORDINARY DIFFERENTIAL C EQUATIONS) WHICH DETERMINE THE COEFFICIENTS C ARE OBTAINED BY C REQUIRING THAT THE ABOVE APPROXIMATE U(T,X) SATISFY THE PDE AND C BOUNDARY CONDITIONS EXACTLY AT A SET OF NCPTS COLLOCATION POINTS C (SEE COLPNT). THUS, PDECOL ACTUALLY COMPUTES THE BASIS FUNCTION C COEFFICIENTS RATHER THAN SPECIFIC APPROXIMATE SOLUTION VALUES. C C REFERENCES C C 1. MADSEN, N.K. AND R.F. SINCOVEC, PDECOL - COLLOCATION SOFTWARE C FOR PARTIAL DIFFERENTIAL EQUATIONS, ACM-TOMS, VOL. , NO. , C 2. SINCOVEC, R.F. AND N.K. MADSEN, SOFTWARE FOR NONLINEAR PARTIAL C DIFFERENTIAL EQUATIONS, ACM-TOMS, VOL. 1, NO. 3, C SEPTEMBER 1975, PP. 232-260. C 3. HINDMARSH, A.C., PRELIMINARY DOCUMENTATION OF GEARIB.. SOLUTION C OF IMPLICIT SYSTEMS OF ORDINARY DIFFERENTIAL EQUATIONS WITH C BANDED JACOBIANS, LAWRENCE LIVERMORE LAB, UCID-30130, FEBRUARY C 1976. C 4. DEBOOR, C., PACKAGE FOR CALCULATING WITH B-SPLINES, SIAM J. C NUMER. ANAL., VOL. 14, NO. 3, JUNE 1977, PP. 441-472. C C------------------------------------------------------------------------------- C C USE OF PDECOL C C PDECOL IS CALLED ONCE FOR EACH DESIRED OUTPUT VALUE (TOUT) OF THE C TIME T, AND IT IN TURN MAKES REPEATED CALLS TO THE CORE INTEGRATOR, C STIFIB, WHICH ADVANCES THE TIME BY TAKING SINGLE STEPS UNTIL C T .GE. TOUT. INTERPOLATION TO THE EXACT TIME TOUT IS THEN DONE. C SEE TOUT BELOW. C C C SUMMARY OF SUGGESTED INPUT VALUES C C IT IS OF COURSE IMPOSSIBLE TO SUGGEST INPUT PARAMETER VALUES WHICH C ARE APPROPRIATE FOR ALL PROBLEMS. THE FOLLOWING SUGGESTIONS ARE TO C BE USED ONLY IF YOU HAVE NO IDEA OF BETTER VALUES FOR YOUR PROBLEM. C C DT = 1.E-10 C XBKPT = CHOOSE NINT+1 EQUALLY SPACED VALUES SUCH THAT XBKPT(1) = C XLEFT AND XBKPT(NINT+1) = XRIGHT. C EPS = 1.E-4 C NINT = ENOUGH SO THAT ANY FINE STRUCTURE OF THE PROBLEM MAY BE C RESOLVED. C KORD = 4 C NCC = 2 C MF = 22 C INDEX = 1 (ON FIRST CALL ONLY, THEN 0 THEREAFTER). C C C THE INPUT PARAMETERS ARE.. C T0 = THE INITIAL VALUE OF T, THE INDEPENDENT VARIABLE C (USED ONLY ON FIRST CALL). C TOUT = THE VALUE OF T AT WHICH OUTPUT IS DESIRED NEXT. SINCE C THE PACKAGE CHOOSES ITS OWN TIME STEP SIZES, THE C INTEGRATION WILL NORMALLY GO SLIGHTLY BEYOND TOUT C AND THE PACKAGE WILL INTERPOLATE TO T = TOUT. C DT = THE INITIAL STEP SIZE IN T, IF INDEX = 1, OR, THE C MAXIMUM STEP SIZE ALLOWED (MUST BE .GT. 0), IF INDEX = 3. C USED FOR INPUT ONLY WHEN INDEX = 1 OR 3. SEE BELOW. C XBKPT = THE ARRAY OF PIECEWISE POLYNOMIAL BREAKPOINTS. C THE NINT+1 VALUES MUST BE STRICTLY INCREASING WITH C XBKPT(1) = XLEFT AND XBKPT(NINT+1) = XRIGHT (USED ONLY C ON FIRST CALL). C EPS = THE RELATIVE TIME ERROR BOUND (USED ONLY ON THE C FIRST CALL, UNLESS INDEX = 4). SINGLE STEP ERROR C ESTIMATES DIVIDED BY CMAX(I) WILL BE KEPT LESS THAN C EPS IN ROOT-MEAN-SQUARE NORM. THE VECTOR CMAX OF WEIGHTS C IS COMPUTED IN PDECOL. INITIALLY CMAX(I) IS SET TO C DABS(C(I)), WITH A DEFAULT VALUE OF 1 IF DABS(C(I)) .LT. 1. C THEREAFTER, CMAX(I) IS THE LARGEST VALUE C OF DABS(C(I)) SEEN SO FAR, OR THE INITIAL CMAX(I) IF C THAT IS LARGER. TO ALTER EITHER OF THESE, CHANGE THE C APPROPRIATE STATEMENTS IN THE DO-LOOPS ENDING AT C STATEMENTS 50 AND 130 BELOW. THE USER SHOULD EXERCISE C SOME DISCRETION IN CHOOSING EPS. IN GENERAL, THE C OVERALL RUNNING TIME FOR A PROBLEM WILL BE GREATER IF C EPS IS CHOSEN SMALLER. THERE IS USUALLY LITTLE REASON TO C CHOOSE EPS MUCH SMALLER THAN THE ERRORS WHICH ARE BEING C INTRODUCED BY THE USERS CHOICE OF THE POLYNOMIAL SPACE. C SEE RELATED COMMENTS CONCERNING CMAX BELOW STATEMENT 40. C NINT = THE NUMBER OF SUBINTERVALS INTO WHICH THE SPATIAL DOMAIN C (XLEFT,XRIGHT) IS TO BE DIVIDED (MUST BE .GE. 1) C (USED ONLY ON FIRST CALL). C KORD = THE ORDER OF THE PIECEWISE POLYNOMIAL SPACE TO BE USED. C ITS VALUE MUST BE GREATER THAN 2 AND LESS THAN 21. FOR C FIRST ATTEMPTS WE RECOMMEND KORD = 4. IF THE SOLUTION C IS SMOOTH AND MUCH ACCURACY IS DESIRED, HIGHER VALUES C MAY PROVE TO BE MORE EFFICIENT. WE HAVE SELDOM USED C VALUES OF KORD IN EXCESS OF 8 OR 9, THOUGH THEY ARE C AVAILABLE FOR USE IN PDECOL (USED ONLY ON FIRST CALL). C NCC = THE NUMBER OF CONTINUITY CONDITIONS TO BE IMPOSED ON THE C APPROXIMATE SOLUTION AT THE BREAKPOINTS IN XBKPT. C NCC MUST BE GREATER THAN 1 AND LESS THAN KORD. WE C RECOMMEND THE USE OF NCC = 2 C SINCE THEORY PREDICTS THAT DRAMATICALLY MORE C ACCURATE RESULTS CAN OFTEN BE OBTAINED USING THIS CHOICE C (USED ONLY ON FIRST CALL). C NPDE = THE NUMBER OF PARTIAL DIFFERENTIAL EQUATIONS IN THE SYSTEM C TO BE SOLVED (USED ONLY ON FIRST CALL). C MF = THE METHOD FLAG (USED ONLY ON FIRST CALL, UNLESS C INDEX = 4). ALLOWED VALUES ARE 11, 12, 21, 22. C FOR FIRST ATTEMPTS WE RECOMMEND THE USE OF MF = 22. C MF HAS TWO DECIMAL DIGITS, METH AND MITER C (MF = 10*METH + MITER). C METH IS THE BASIC METHOD INDICATOR.. C METH = 1 MEANS THE ADAMS METHODS (GENERALIZATIONS OF C CRANK-NICOLSON). C METH = 2 MEANS THE BACKWARD DIFFERENTIATION C FORMULAS (BDF), OR STIFF METHODS OF GEAR. C MITER IS THE ITERATION METHOD INDICATOR C AND DETERMINES HOW THE JACOBIAN MATRIX IS C TO BE COMPUTED.. C MITER = 1 MEANS CHORD METHOD WITH ANALYTIC JACOBIAN. C FOR THIS USER SUPPLIES SUBROUTINE DERIVF. C SEE DESCRIPTION ABOVE. C MITER = 2 MEANS CHORD METHOD WITH JACOBIAN CALCULATED C INTERNALLY BY FINITE DIFFERENCES. SEE C SUBROUTINES PSETIB AND DIFFF. C INDEX = INTEGER USED ON INPUT TO INDICATE TYPE OF CALL, C WITH THE FOLLOWING VALUES AND MEANINGS.. C 1 THIS IS THE FIRST CALL FOR THIS PROBLEM. C 0 THIS IS NOT THE FIRST CALL FOR THIS PROBLEM, C AND INTEGRATION IS TO CONTINUE. C 2 SAME AS 0 EXCEPT THAT TOUT IS TO BE HIT C EXACTLY (NO INTERPOLATION IS DONE). SEE NOTE C BELOW. ASSUMES TOUT .GE. THE CURRENT T. C IF TOUT IS .LT. THE CURRENT TIME, THEN TOUT IS C RESET TO THE CURRENT TIME AND CONTROL IS C RETURNED TO THE USER. A CALL TO VALUES WILL C PRODUCE ANSWERS FOR THE NEW VALUE OF TOUT. C 3 SAME AS 0 EXCEPT CONTROL RETURNS TO CALLING C PROGRAM AFTER ONE STEP. TOUT IS IGNORED AND C DT MUST BE SET .GT. 0 TO A MAXIMUM ALLOWED C DT VALUE. SEE ABOVE. C 4 THIS IS NOT THE FIRST CALL FOR THE PROBLEM, C AND THE USER HAS RESET EPS AND/OR MF. C SINCE THE NORMAL OUTPUT VALUE OF INDEX IS 0, C IT NEED NOT BE RESET FOR NORMAL CONTINUATION. C C NOTE.. THE PACKAGE MUST HAVE TAKEN AT LEAST ONE SUCCESSFUL TIME C STEP BEFORE A CALL WITH INDEX = 2 OR 4 IS ALLOWED. C AFTER THE INITIAL CALL, IF A NORMAL RETURN OCCURRED AND A NORMAL C CONTINUATION IS DESIRED, SIMPLY RESET TOUT AND CALL AGAIN. C ALL OTHER PARAMETERS WILL BE Y FOR THE NEXT CALL. C A CHANGE OF PARAMETERS WITH INDEX = 4 CAN BE MADE AFTER C EITHER A SUCCESSFUL OR AN UNSUCCESSFUL RETURN PROVIDED AT LEAST C ONE SUCCESSFUL TIME STEP HAS BEEN MADE. C C WORK = FLOATING POINT WORKING ARRAY FOR PDECOL. WE RECOMMEND C THAT IT BE INITIALIZED TO ZERO BEFORE THE FIRST CALL C TO PDECOL. ITS TOTAL LENGTH MUST BE AT LEAST C C KORD + 4*NPDE + 9*NPDE**2 + NCPTS*(3*KORD + 2) + C NPDE*NCPTS*(3*ML + MAXDER + 7) C C WHERE ML AND MAXDER ARE DEFINED BELOW (SEE STORAGE C ALLOCATION). C C IWORK = INTEGER WORKING ARRAY FOR PDECOL. THE FIRST TWO C LOCATIONS MUST BE DEFINED AS FOLLOWS... C IWORK(1) = LENGTH OF USERS ARRAY WORK C IWORK(2) = LENGTH OF USERS ARRAY IWORK C THE TOTAL LENGTH OF IWORK MUST BE AT LEAST C NCPTS*(NPDE + 1). C OUTPUT C C THE SOLUTION VALUES ARE NOT RETURNED DIRECTLY TO THE USER BY PDECOL. C THE METHODS USED IN PDECOL COMPUTE BASIS FUNCTION COEFFICIENTS, SO C THE USER (AFTER A RETURN FROM PDECOL) MUST CALL THE PACKAGE ROUTINE C VALUES TO OBTAIN HIS APPROXIMATE SOLUTION VALUES AT ANY DESIRED SPACE C POINTS X AT THE TIME T = TOUT. SEE THE COMMENTS IN SUBROUTINE VALUES C FOR DETAILS ON HOW TO PROPERLY MAKE THE CALL. C C EXECUTION ERROR MESSAGES WILL BE PRINTED BY PDECOL ON LOGICAL UNIT C LOUT WHICH IS THE ONLY VARIABLE IN THE COMMON BLOCK /IOUNIT/. A C DEFAULT OF LOUT = 3 IS SET IN THE BLOCK DATA. C C THE COMMON BLOCK /GEAR0/ CONTAINS THE VARIABLES DTUSED, NQUSED, C NSTEP, NFE, AND NJE AND CAN BE ACCESSED EXTERNALLY BY THE USER IF C DESIRED. RESPECTIVELY, IT CONTAINS THE STEP SIZE LAST USED (SUCCESS- C FULLY), THE ORDER LAST USED (SUCCESSFULLY), THE NUMBER OF STEPS TAKEN C SO FAR, THE NUMBER OF RESIDUAL EVALUATIONS (RES CALLS) SO FAR, C AND THE NUMBER OF MATRIX EVALUATIONS (PSETIB CALLS) SO FAR. C DIFFUN CALLS ARE COUNTED IN WITH RESIDUAL EVALUATIONS. C C THE OUTPUT PARAMETERS ARE.. C DT = THE STEP SIZE USED LAST, WHETHER SUCCESSFULLY OR NOT. C TOUT = THE OUTPUT VALUE OF T. IF INTEGRATION WAS SUCCESSFUL, C AND THE INPUT VALUE OF INDEX WAS NOT 3, TOUT IS C UNCHANGED FROM ITS INPUT VALUE. OTHERWISE, TOUT C IS THE CURRENT VALUE OF T TO WHICH THE INTEGRATION C HAS BEEN COMPLETED. C INDEX = INTEGER USED ON OUTPUT TO INDICATE RESULTS, C WITH THE FOLLOWING VALUES AND MEANINGS.. C 0 INTEGRATION WAS COMPLETED TO TOUT OR BEYOND. C -1 THE INTEGRATION WAS HALTED AFTER FAILING TO PASS THE C ERROR TEST EVEN AFTER REDUCING DT BY A FACTOR OF C 1.E10 FROM ITS INITIAL VALUE. C -2 AFTER SOME INITIAL SUCCESS, THE INTEGRATION WAS C HALTED EITHER BY REPEATED ERROR TEST FAILURES OR BY C A TEST ON EPS. TOO MUCH ACCURACY HAS BEEN REQUESTED. C -3 THE INTEGRATION WAS HALTED AFTER FAILING TO ACHIEVE C CORRECTOR CONVERGENCE EVEN AFTER REDUCING DT BY A C FACTOR OF 1.E10 FROM ITS INITIAL VALUE. C -4 SINGULAR MATRIX ENCOUNTERED. PROBABLY DUE TO STORAGE C OVERWRITES. C -5 INDEX WAS 4 ON INPUT, BUT THE DESIRED CHANGES OF C PARAMETERS WERE NOT IMPLEMENTED BECAUSE TOUT C WAS NOT BEYOND T. INTERPOLATION TO T = TOUT WAS C PERFORMED AS ON A NORMAL RETURN. TO TRY AGAIN, C SIMPLY CALL AGAIN WITH INDEX = 4 AND A NEW TOUT. C -6 ILLEGAL INDEX VALUE. C -7 ILLEGAL EPS VALUE. C -8 AN ATTEMPT TO INTEGRATE IN THE WRONG DIRECTION. THE C SIGN OF DT IS WRONG RELATIVE TO T0 AND TOUT. C -9 DT .EQ. 0.0. C -10 ILLEGAL NINT VALUE. C -11 ILLEGAL KORD VALUE. C -12 ILLEGAL NCC VALUE. C -13 ILLEGAL NPDE VALUE. C -14 ILLEGAL MF VALUE. C -15 ILLEGAL BREAKPOINTS - NOT STRICTLY INCREASING. C -16 INSUFFICIENT STORAGE FOR WORK OR IWORK. C C------------------------------------------------------------------------------- C C SUMMARY OF ALL PACKAGE ROUTINES C C PDECOL - STORAGE ALLOCATION, ERROR CHECKING, INITIALIZATION, REPEATED C CALLS TO STIFIB TO ADVANCE THE TIME. C C INTERP - INTERPOLATES COMPUTED BASIS FUNCTION COEFFICIENTS TO THE C DESIRED OUTPUT TIMES, TOUT, FOR USE BY VALUES. C C INITAL - INITIALIZATION, GENERATION AND STORAGE OF PIECEWISE POLY- C NOMIAL SPACE BASIS FUNCTION VALUES AND DERIVATIVES, DET- C ERMINES THE BASIS FUNCTION COEFFICINTS OF THE PIECEWISE C POLYNOMIALS WHICH INTERPOLATE THE USERS INITIAL CONDITIONS. C C COLPNT - GENERATION OF REQUIRED COLLOCATION POINTS. C C BSPLVD - B-SPLINE PACKAGE ROUTINES WHICH ALLOW FOR EVALUATION OF C BSPLVN ANY B-SPLINE BASIS FUNCTION OR DERIVATIVE VALUE. C INTERV C C VALUES - GENERATION AT ANY POINT(S) OF VALUES OF THE COMPUTED C APPROXIMATE SOLUTION AND ITS DERIVATIVES WHICH ARE C PIECEWISE POLYNOMIALS. THE SUBROUTINE IS CALLED ONLY BY C THE USER. C C STIFIB - CORE INTEGRATOR, TAKES SINGLE TIME STEPS TO ADVANCE THE C TIME. ASSEMBLES AND SOLVES THE PROPER NONLINEAR EQUATIONS C WHICH ARE RELATED TO USE OF ADAMS OR GEAR TYPE INTEGRATION C FORMULAS. CHOOSES PROPER STEP SIZE AND INTEGRATION FORMULA C ORDER TO MAINTAIN A DESIRED ACCURACY. DESIGNED FOR ODE C PROBLEMS OF THE FORM A * (DY/DT) = G(T,Y). C C COSET - GENERATES INTEGRATION FORMULA AND ERROR CONTROL COEFFICIENTS. C C RES - COMPUTES RESIDUAL VECTORS USED IN SOLVING THE NONLINEAR C EQUATIONS BY A MODIFIED NEWTON METHOD. C C DIFFUN - COMPUTES A**-1 * G(T,Y) WHERE A AND G ARE AS ABOVE (STIFIB). C C ADDA - ADDS THE A MATRIX TO A GIVEN MATRIX IN BAND FORM. C C EVAL - EVALUATES THE COMPUTED PIECEWISE POLYNOMIAL SOLUTION AND C DERIVATIVES AT COLLOCATION POINTS. C C GFUN - EVALUATES THE FUNCTION G(T,Y) BY CALLING EVAL AND THE USER C SUBROUTINES F AND BNDRY. C C PSETIB - GENERATES PROPER JACOBIAN MATRICES REQUIRED BY THE MODIFIED C NEWTON METHOD. C C DIFFF - PERFORMS SAME ROLE AS THE USER ROUTINE DERIVF. COMPUTES C DERIVATIVE APPROXIMATIONS BY USE OF FINITE DIFFERENCES. C C DECB - PERFORM AN LU DECOMPOSTION AND FORWARD AND BACKWARD C SOLB SUBSTITUTION FOR SOLVING BANDED SYSTEMS OF LINEAR EQUATIONS. C C----------------------------------------------------------------------- C C C STORAGE ALLOCATION C C SINCE PDECOL IS A DYNAMICALLY DIMENSIONED PROGRAM, MOST OF ITS C WORKING STORAGE IS PROVIDED BY THE USER IN THE ARRAYS WORK AND IWORK. C THE FOLLOWING GIVES A LIST OF THE ARRAYS WHICH MAKE UP THE CONTENTS C WORK AND IWORK, THEIR LENGTHS, AND THEIR USES. WHEN MORE THAN ONE C NAME IS GIVEN, IT INDICATES THAT DIFFERENT NAMES ARE USED FOR THE C SAME ARRAY IN DIFFERENT PARTS OF THE PROGRAM. THE DIFFERENT NAMES C OCCUR BECAUSE PDECOL IS AN AMALGAMATION OF SEVERAL OTHER CODES C WRITTEN BY DIFFERENT PEOPLE AND WE HAVE TRIED TO LEAVE THE SEPARATE C PARTS AS UNCHANGED FROM THEIR ORIGINAL VERSIONS AS POSSIBLE. C C C NAMES LENGTH USE C --------- ------------ ------------------------------------- C C BC 4*NPDE**2 BOUNDARY CONDITION INFORMATION. C WORK C C A 3*KORD*NCPTS BASIS FUNCTION VALUES AT COLLOCATION POINT C WORK(IW1) C C XT NCPTS + KORD BREAKPOINT SEQUENCE FOR GENERATION OF BASI C WORK(IW2) FUNCTION VALUES. C C XC NCPTS COLLOCATION POINTS. C WORK(IW3) C C CMAX NPDE*NCPTS VALUES USED IN ESTIMATING TIME C YMAX INTEGRATION ERRORS. C WORK(IW4) C C ERROR NPDE*NCPTS TIME INTEGRATION ERRORS. C WORK(IW5) C C SAVE1 NPDE*NCPTS WORKING STORAGE FOR THE TIME INTEGRATION C WORK(IW6) METHOD. C C SAVE2 NPDE*NCPTS WORKING STORAGE FOR THE TIME INTEGRATION C WORK(IW7) METHOD. C C SAVE3 NPDE*NCPTS WORKING STORAGE FOR THE TIME INTEGRATION C WORK(IW8) METHOD. C C UVAL 3*NPDE WORKING STORAGE FOR VALUES OF U, UX, AND C WORK(IW9) UXX AT ONE POINT. C C C NPDE*NCPTS* CURRENT BASIS FUNCTION COEFFICIENT VALUES C Y (MAXDER+1) AND THEIR SCALED TIME DERIVATIVES. C WORK(IW10) C C DFDU NPDE**2 WORKING STORAGE USED TO COMPUTE THE C WORK(IW11) JACOBIAN MATRIX. C C DFDUX NPDE**2 WORKING STORAGE USED TO COMPUTE THE C WORK(IW12) JACOBIAN MATRIX. C C DFDUXX NPDE**2 WORKING STORAGE USED TO COMPUTE THE C WORK(IW13) JACOBIAN MATRIX. C C DBDU NPDE**2 BOUNDARY CONDITION INFORMATION. C WORK(IW14) C C DBDUX NPDE**2 BOUNDARY CONDITION INFORMATION. C WORK(IW15) C C DZDT NPDE BOUNDARY CONDITION INFORMATION. C WORK(IW16) C C PW NPDE*NCPTS* STORAGE AND PROCESSING OF THE JACOBIAN C WORK(IW17) (3*ML+1) MATRIX. C C ILEFT NCPTS POINTERS TO BREAKPOINT SEQUENCE FOR C IWORK GENERATION OF BASIS FUNCTION VALUES. C C IPIV NPDE*NCPTS PIVOT INFORMATION FOR THE LU DECOMPOSED C IWORK(IW18) JACOBIAN MATRIX PW. C C WHERE... C C NCPTS = KORD*NINT - NCC*(NINT-1) C ML = NPDE*(KORD+IQUAD-1) - 1 C IQUAD = 1 IF KORD = 3 AND A NULL BOUNDARY CONDITION EXISTS C IQUAD = 0 OTHERWISE C MAXDER = 5 UNLESS OTHERWISE SET BY THE USER INTO /OPTION/. C C THE COMMON BLOCK /OPTION/ CONTAINS THE TWO VARIABLES NOGAUS AND C MAXDER. NOGAUS IS SET .EQ. 0 IN THE BLOCK DATA. IT CAN BE CHANGED C TO BE SET .EQ. 1 IF THE GAUSS-LEGENDRE COLLOCATION POINTS ARE NOT C DESIRED WHEN NCC = 2 (SEE ABOVE AND COLPNT). MAXDER IS SET C .EQ. 5 IN THE BLOCK DATA AND ITS VALUE REPRESENTS THE C MAXIMUM ORDER OF TIME INTEGRATION FORMULA ALLOWED. ITS VALUE C AFFECTS THE STORAGE REQUIRED IN WORK AND MAY BE CHANGED IF C DESIRED. SEE COSET FOR RESTRICTIONS. THESE CHANGES MAY BE MADE BY C THE USER BY ACCESSING /OPTION/ IN HIS CALLING PROGRAM (BEFORE THE C FIRST CALL TO PDECOL) OR BY CHANGING THE DATA STATEMENT IN C THE BLOCK DATA. C C----------------------------------------------------------------------- C C C COMMUNICATION C C EACH SUBROUTINE IN THE PACKAGE CONTAINS A COMMUNICATION SUMMARY C AS INDICATED BELOW. C C PACKAGE ROUTINES CALLED.. EVAL,INITAL,INTERP,STIFIB C USER ROUTINES CALLED.. BNDRY C CALLED BY.. USERS MAIN PROGRAM C FORTRAN FUNCTIONS USED.. ABS,DMAX1,FLOAT,DSQRT C----------------------------------------------------------------------- SAVE COMMON /GEAR0/ DTUSED,NQUSED,NSTEP,NFE,NJE COMMON /GEAR1/ T,DTC,DTMN,DTMX,EPSC,UROUND,N,MFC,KFLAG,JSTART COMMON /GEAR9/ EPSJ,R0,ML,MU,MW,NM1,N0ML,N0W COMMON /OPTION/ NOGAUS,MAXDER COMMON /SIZES/ NIN,KOR,NC,NPD,NCPTS,NEQN,IQUAD COMMON /ISTART/ IW1,IW2,IW3,IW4,IW5,IW6,IW7,IW8,IW9,IW10, * IW11,IW12,IW13,IW14,IW15,IW16,IW17,IW18 COMMON /IOUNIT/ LOUT DIMENSION WORK(KORD+NPDE*(4+9*NPDE)+(KORD+(NINT-1)*(KORD-NCC))* * (3*KORD+2+NPDE*(3*(KORD-1)*NPDE+MAXDER+4))), * IWORK((NPDE+1)*(KORD+(NINT-1)*(KORD-NCC))), XBKPT(NINT+1) IF (INDEX .EQ. 0) GO TO 60 IF (INDEX .EQ. 2) GO TO 70 IF (INDEX .EQ. 4) GO TO 80 IF (INDEX .EQ. 3) GO TO 90 C----------------------------------------------------------------------- C SEVERAL CHECKS ARE MADE HERE TO DETERMINE IF THE INPUT PARAMETERS C HAVE LEGAL VALUES. ERROR CHECKS ARE MADE ON INDEX, EPS, (T0-TOUT)*DT, C DT, NINT, KORD, NCC, NPDE, MF, WHETHER THE BREAKPOINT SEQUENCE IS C STRICTLY INCREASING, AND WHETHER THERE IS SUFFICIENT STORAGE C PROVIDED FOR WORK AND IWORK. PROBLEM DEPENDENT PARAMETERS ARE C CALCULATED AND PLACED IN COMMON. C----------------------------------------------------------------------- IERID = -6 IF (INDEX .NE. 1) GO TO 320 IERID = IERID - 1 IF (EPS .LE. 0.) GO TO 320 IERID = IERID - 1 IF ((T0-TOUT)*DT .GT. 0.) GO TO 320 IERID = IERID - 1 IF (DT .EQ. 0.0) GO TO 320 IERID = IERID - 1 NIN = NINT IF (NIN .LT. 1) GO TO 320 IERID = IERID - 1 KOR = KORD IF (KOR .LT. 3 .OR. KOR .GT. 20) GO TO 320 IERID = IERID - 1 NC = NCC IF (NCC .LT. 2 .OR. NCC .GE. KOR) GO TO 320 IERID = IERID - 1 NPD = NPDE NPDE2 = NPD*NPD IF (NPDE .LT. 1) GO TO 320 IERID = IERID - 1 IF (MF.NE.22.AND.MF.NE.21.AND.MF.NE.12.AND.MF.NE.11) GO TO 320 IERID = IERID - 1 DO 10 K=1,NIN IF(XBKPT(K) .GE. XBKPT(K+1)) GO TO 320 10 CONTINUE NCPTS = KOR + (NIN - 1) * (KOR - NCC) NEQN = NPDE * NCPTS ML = (KOR-1)*NPDE - 1 MU = ML MW = ML + ML + 1 N0W = NEQN*MW IWSAVE = IWORK(1) IISAVE = IWORK(2) IW1 = 4*NPDE2 + 1 IW2 = IW1 + 3*KORD*NCPTS IW3 = IW2 + NCPTS + KORD IW4 = IW3 + NCPTS IW5 = IW4 + NEQN IW6 = IW5 + NEQN IW7 = IW6 + NEQN IW8 = IW7 + NEQN IW9 = IW8 + NEQN IW10 = IW9 + 3*NPDE IW11 = IW10 + NEQN*(MAXDER+1) IW12 = IW11 + NPDE2 IW13 = IW12 + NPDE2 IW14 = IW13 + NPDE2 IW15 = IW14 + NPDE2 IW16 = IW15 + NPDE2 IW17 = IW16 + NPDE IW18 = NCPTS + 1 IERID = IERID - 1 IWSTOR = IW17 + NEQN*(3*ML+1) - 1 IISTOR = IW18 + NEQN - 1 IF ( IWSAVE .LT. IWSTOR .OR. IISAVE .LT. IISTOR ) GO TO 335 C----------------------------------------------------------------------- C PERFORM INITIALIZATION TASKS. IF KORD .EQ. 3 THEN CALCULATE THE BAND- C WIDTH OF THE ASSOCIATED MATRIX PROBLEM BY DETERMINING THE TYPE OF C BOUNDARY CONDITIONS, THEN CHECK FOR SUFFICIENT STORAGE AGAIN. C----------------------------------------------------------------------- CALL INITAL(KOR,WORK(IW1),WORK(IW6),XBKPT,WORK(IW2),WORK(IW3), * WORK(IW17),IWORK(IW18),IWORK) IF(IQUAD .NE. 0) GO TO 280 IF( KOR .NE. 3 ) GO TO 40 CALL EVAL(1,NPDE,WORK(IW6),WORK(IW9),WORK(IW1),IWORK) CALL BNDRY(T0,WORK(IW3),WORK(IW9),WORK(IW9+NPDE),WORK(IW14), * WORK(IW15),WORK(IW16),NPDE) DO 20 K=1,NPDE I = K + NPDE*(K-1) - 1 IF(WORK(IW14+I) .EQ. 0.0 .AND. WORK(IW15+I) .EQ. 0.0) * IQUAD = 1 20 CONTINUE CALL EVAL(NCPTS,NPDE,WORK(IW6),WORK(IW9),WORK(IW1),IWORK) CALL BNDRY(T0,WORK(IW3+NCPTS-1),WORK(IW9),WORK(IW9+NPDE), * WORK(IW14),WORK(IW15),WORK(IW16),NPDE) DO 30 K=1,NPDE I = K + NPDE*(K-1) - 1 IF(WORK(IW14+I) .EQ. 0.0 .AND. WORK(IW15+I) .EQ. 0.0) * IQUAD = 1 30 CONTINUE ML = ML + IQUAD*NPDE MU = ML MW = ML + ML + 1 N0W = NEQN*MW 40 CONTINUE IWSTOR = IW17 + NEQN*(3*ML+1) - 1 IF ( IWSAVE .LT. IWSTOR ) GO TO 335 C----------------------------------------------------------------------- C IF INITIAL VALUES OF CMAX OTHER THAN THOSE SET BELOW ARE DESIRED, C THEY SHOULD BE SET HERE. ALL CMAX(I) MUST BE POSITIVE. C HAVING PROPER VALUES OF CMAX FOR THE PROBLEM BEING SOLVED IS AS C IMPORTANT AS CHOOSING EPS (SEE ABOVE), SINCE ERRORS ARE C MEASURED RELATIVE TO CMAX. IF VALUES FOR DTMN OR DTMX, THE C BOUNDS ON DABS(DT), OTHER THAN THOSE BELOW ARE DESIRED, THEY C SHOULD BE SET BELOW. C----------------------------------------------------------------------- DO 50 I = 1,NEQN I1 = I - 1 WORK(IW4+I1) = DABS(WORK(IW6+I1)) IF (WORK(IW4+I1) .LT. 1.) WORK(IW4+I1) = 1. 50 WORK(IW10+I1) = WORK(IW6+I1) N = NEQN T = T0 DTC = DT DTMN = DABS(DT) DTUSED = 0. EPSC = EPS MFC = MF JSTART = 0 EPSJ = DSQRT(UROUND) NM1 = NEQN - 1 N0ML = NEQN*ML NHCUT = 0 KFLAG = 0 TOUTP = T0 IF ( T0 .EQ. TOUT ) GO TO 360 60 DTMX = DABS(TOUT-TOUTP)*10. GO TO 140 C 70 DTMX = DABS(TOUT-TOUTP)*10. IF ((T-TOUT)*DTC .GE. 0.) GO TO 340 GO TO 150 C 80 IF ((T-TOUT)*DTC .GE. 0.) GO TO 300 JSTART = -1 EPSC = EPS MFC = MF GO TO 100 C 90 DTMX = DT 100 IF ((T+DTC) .EQ. T) CALL REALPR("WARNING.. T + DT = T ON NEXT $ STEP.", -1, T, 0) C 100 IF ((T+DTC) .EQ. T) WRITE(LOUT,110) C 110 FORMAT(36H WARNING.. T + DT = T ON NEXT STEP.) C----------------------------------------------------------------------- C TAKE A TIME STEP BY CALLING THE INTEGRATOR. C----------------------------------------------------------------------- CALL STIFIB (NEQN,WORK(IW10),WORK(IW4),WORK(IW5),WORK(IW6), * WORK(IW7),WORK(IW8),WORK(IW17),IWORK(IW18),WORK,IWORK) C KGO = 1 - KFLAG GO TO (120, 160, 220, 260, 280), KGO C KFLAG = 0, -1, -2, -3 -4 C 120 CONTINUE C----------------------------------------------------------------------- C NORMAL RETURN FROM INTEGRATOR. C C THE WEIGHTS CMAX(I) ARE UPDATED. IF DIFFERENT VALUES ARE DESIRED, C THEY SHOULD BE SET HERE. A TEST IS MADE FOR EPS BEING TOO SMALL C FOR THE MACHINE PRECISION. C C ANY OTHER TESTS OR CALCULATIONS THAT ARE REQUIRED AFTER EVERY C STEP SHOULD BE INSERTED HERE. C C IF INDEX = 3, SAVE1 IS SET TO THE CURRENT C VALUES ON RETURN. C IF INDEX = 2, DT IS CONTROLLED TO HIT TOUT (WITHIN ROUNDOFF C ERROR), AND THEN THE CURRENT C VALUES ARE PUT IN SAVE1 ON RETURN. C FOR ANY OTHER VALUE OF INDEX, CONTROL RETURNS TO THE INTEGRATOR C UNLESS TOUT HAS BEEN REACHED. THEN INTERPOLATED VALUES OF C ARE C COMPUTED AND STORED IN SAVE1 ON RETURN. C IF INTERPOLATION IS NOT DESIRED, THE CALL TO INTERP SHOULD BE C REMOVED AND CONTROL TRANSFERRED TO STATEMENT 340 INSTEAD OF 360. C----------------------------------------------------------------------- D = 0. DO 130 I = 1,NEQN I1 = I - 1 AYI = DABS(WORK(IW10+I1)) WORK(IW4+I1) = DMAX1(WORK(IW4+I1), AYI) 130 D = D + (AYI/WORK(IW4+I1))**2 D = D*(UROUND/EPS)**2 IF (D .GT. FLOAT(NEQN)) GO TO 240 IF (INDEX .EQ. 3) GO TO 340 IF (INDEX .EQ. 2) GO TO 150 140 IF ((T-TOUT)*DTC .LT. 0.) GO TO 100 CALL INTERP(TOUT,WORK(IW10),NEQN,WORK(IW6)) GO TO 360 C 150 IF (((T+DTC)-TOUT)*DTC .LE. 0.) GO TO 100 IF (DABS(T-TOUT) .LE. 100.*UROUND*DTMX) GO TO 340 IF ((T-TOUT)*DTC .GE. 0.) GO TO 340 DTC = (TOUT - T)*(1. - 4.*UROUND) JSTART = -1 GO TO 100 C----------------------------------------------------------------------- C ON AN ERROR RETURN FROM INTEGRATOR, AN IMMEDIATE RETURN OCCURS IF C KFLAG = -2 OR -4, AND RECOVERY ATTEMPTS ARE MADE OTHERWISE. C TO RECOVER, DT AND DTMN ARE REDUCED BY A FACTOR OF .1 UP TO 10 C TIMES BEFORE GIVING UP. C----------------------------------------------------------------------- 160 CALL REALPR("\n\nKFLAG = -1 FROM INTEGRATOR AT T = ", -1, T, 1) CALL REALPR("ERROR TEST FAILED WITH DABS(DT) = DTMIN", -1, T, 0) c$$$ 160 WRITE (LOUT,170) T c$$$ 170 FORMAT(//35H KFLAG = -1 FROM INTEGRATOR AT T = ,E16.8/ c$$$ * 41H ERROR TEST FAILED WITH DABS(DT) = DTMIN/) 180 IF (NHCUT .EQ. 10) GO TO 200 NHCUT = NHCUT + 1 DTMN = .1*DTMN DTC = .1*DTC CALL REALPR("DT HAS BEEN REDUCED TO", -1, DTC, 1) CALL REALPR("AND STEP WILL BE RETRIED", -1, DTC, 0) c$$$ WRITE (LOUT,190) DTC c$$$ 190 FORMAT(25H DT HAS BEEN REDUCED TO ,E16.8, c$$$ * 26H AND STEP WILL BE RETRIED//) JSTART = -1 GO TO 100 C 200 CALL REALPR("\n\nPROBLEM APPEARS UNSOLVABLE WITH GIVEN INPUT", -1, $ T, 0) c$$$ 200 WRITE (LOUT,210) c$$$ 210 FORMAT(//44H PROBLEM APPEARS UNSOLVABLE WITH GIVEN INPUT//) GO TO 340 C 220 CALL REALPR("\n\nKFLAG = -2 FROM INTEGRATOR AT T = ", -1, T, 1) CALL REALPR("DT =", -1, DT, 1) CALL REALPR("THE REQUESTED ERROR IS SMALLER THAN CAN BE $ HANDLED", -1, T, 0) c$$$ 220 WRITE (LOUT,230) T,DTC c$$$ 230 FORMAT(//35H KFLAG = -2 FROM INTEGRATOR AT T = ,E16.8,6H DT =, c$$$ * E16.8/52H THE REQUESTED ERROR IS SMALLER THAN CAN BE HANDLED//) GO TO 340 C 240 CALL REALPR("\n\nINTEGRATION HALTED BY DRIVER AT T = ", -1, T, 1) CALL REALPR("EPS TOO SMALL TO BE ATTAINED FOR THE MACHINE $ PRECISION", -1, T, 0) c$$$ 240 WRITE (LOUT,250) T c$$$ 250 FORMAT(//37H INTEGRATION HALTED BY DRIVER AT T = ,E16.8/ c$$$ * 56H EPS TOO SMALL TO BE ATTAINED FOR THE MACHINE PRECISION/) KFLAG = -2 GO TO 340 C 260 CALL REALPR("\n\nKFLAG = -3 FROM INTEGRATOR AT T =", -1, T, 1) CALL REALPR("CORRECTOR CONVERGENCE COULD NOT BE ACHIEVED", -1 , T, $ 0) c$$$ 260 WRITE (LOUT,270) T c$$$ 270 FORMAT(//35H KFLAG = -3 FROM INTEGRATOR AT T = ,E16.8/ c$$$ * 45H CORRECTOR CONVERGENCE COULD NOT BE ACHIEVED/) GO TO 180 C 280 CALL REALPR("\n\nSINGULAR MATRIX ENCOUNTERED", -1, T, 0) CALL REALPR("PROBABLY DUE TO STORAGE OVERWRITES", -1, T, 0) c$$$ 280 WRITE (LOUT,290) c$$$ 290 FORMAT(//28H SINGULAR MATRIX ENCOUNTERED, c$$$ * 35H PROBABLY DUE TO STORAGE OVERWRITES//) KFLAG = -4 GO TO 340 C 300 CALL REALPR("\n\nINDEX = -1 ON INPUT WITH (T-TOUT)*DT .GE. 0." , $ -1, T, 0) CALL REALPR("T =", -1, T, 1) CALL REALPR("TOUT =", -1, TOUT, 1) CALL REALPR("DTC =", -1, DTC, 1) CALL REALPR("INTERPOLATION WAS DONE AS ON NORMAL RETURN.", -1, T, $ 0) CALL REALPR("DESIRED PARAMETER CHANGES WERE NOT MADE.", -1, T, 0) c$$$ 300 WRITE(LOUT,310) T,TOUT,DTC c$$$ 310 FORMAT(//45H INDEX = -1 ON INPUT WITH (T-TOUT)*DT .GE. 0./ c$$$ * 4H T =,E16.8,9H TOUT =,E16.8,8H DTC =,E16.8/ c$$$ * 44H INTERPOLATION WAS DONE AS ON NORMAL RETURN./ c$$$ * 41H DESIRED PARAMETER CHANGES WERE NOT MADE.) CALL INTERP(TOUT,WORK(IW10),NEQN,WORK(IW6)) INDEX = -5 RETURN C 320 CALL INTPR("\n\nILLEGAL INPUT...INDEX=", -1, IERID, 1) c$$$ 320 WRITE(LOUT,330) IERID c$$$ 330 FORMAT(//24H ILLEGAL INPUT...INDEX= ,I3//) INDEX = IERID RETURN C 335 CALL INTPR("\n\nINSUFFICIENT STORAGE", -1, IWSTOR, 0) CALL INTPR("WORK MUST BE OF LENGTH", -1, IWSTOR, 1) CALL INTPR("YOU PROVIDED", -1, IWSAVE, 1) CALL INTPR("IWORK MUST BE OF LENGTH", -1, IISTOR, 1) CALL INTPR("YOU PROVIDED", -1, IISAVE, 1) c$$$ 335 WRITE(LOUT,336) IWSTOR,IWSAVE,IISTOR,IISAVE c$$$ 336 FORMAT(//21H INSUFFICIENT STORAGE/24H WORK MUST BE OF LENGTH, c$$$ * I10,5X,12HYOU PROVIDED,I10/24H IWORK MUST BE OF LENGTH,I10,5X, c$$$ * 12HYOU PROVIDED,I10//) INDEX = IERID RETURN C 340 TOUT = T DO 350 I = 1,NEQN I1 = I - 1 350 WORK(IW6+I1) = WORK(IW10+I1) 360 INDEX = KFLAG TOUTP = TOUT DT = DTUSED IF (KFLAG .NE. 0) DT = DTC RETURN END C C C ############################################################################## C C SUBROUTINE VALUES(X,USOL,SCTCH,NDIM1,NDIM2,NPTS,NDERV,WORK) IMPLICIT REAL*8 (A-H, O-Z) C------------------------------------------------------------------------------- C SUBROUTINE VALUES COMPUTES THE SOLUTION U AND THE FIRST NDERV C DERIVATIVES OF U AT THE NPTS POINTS X AND AT TIME TOUT AND RETURNS C THEM IN THE ARRAY USOL. THIS ROUTINE MUST BE USED TO OBTAIN C SOLUTION VALUES SINCE PDECOL DOES NOT RETURN ANY SOLUTION VALUES C TO THE USER. SEE PDECOL. C C THE CALLING PARAMETERS ARE... C X = AN ARBITRARY VECTOR OF SPATIAL POINTS OF LENGTH NPTS AT C WHICH THE SOLUTION AND THE FIRST NDERV DERIVATIVE VALUES C ARE TO BE CALCULATED. IF X .LT. XLEFT ( X .GT. XRIGHT ) C THEN THE PIECEWISE POLYNOMIAL OVER THE LEFTMOST ( RIGHT- C MOST ) INTERVAL IS EVALUATED TO CALCULATE THE SOLUTION C VALUES AT THIS UNUSUAL VALUE OF X. SEE PDECOL. C C USOL = AN ARRAY WHICH CONTAINS THE SOLUTION AND THE FIRST C NDERV DERIVATIVES OF THE SOLUTION AT ALL THE POINTS IN C THE INPUT VECTOR X. IN PARTICULAR, USOL(J,I,K) CONTAINS C THE VALUE OF THE (K-1)-ST DERIVATIVE OF THE J-TH PDE C COMPONENT AT THE I-TH POINT OF THE X VECTOR FOR C J = 1 TO NPDE, I = 1 TO NPTS, AND K = 1 TO NDERV+1. C C SCTCH = A USER SUPPLIED WORKING STORAGE ARRAY OF LENGTH AT LEAST C KORD*(NDERV+1). SEE BELOW AND PDECOL FOR DEFINITIONS OF C THESE PARAMETERS. C C NDIM1 = THE FIRST DIMENSION OF THE OUTPUT ARRAY USOL IN THE CALLING C PROGRAM. NDIM1 MUST BE .GE. NPDE. C C NDIM2 = THE SECOND DIMENSION OF THE OUTPUT ARRAY USOL IN THE C CALLING PROGRAM. NDIM2 MUST BE .GE. NPTS. C C NPTS = THE NUMBER OF POINTS IN THE X VECTOR. C C NDERV = THE NUMBER OF DERIVATIVE VALUES OF THE SOLUTION THAT ARE C TO BE CALCULATED. NDERV SHOULD BE LESS THAN KORD SINCE C THE KORD-TH DERIVATIVE OF A POLYNOMIAL OF DEGREE KORD-1 C IS EQUAL TO ZERO. SEE PDECOL. C C WORK = THE USERS WORKING STORAGE ARRAY WHICH IS USED IN THIS CASE C TO PROVIDE THE CURRENT BASIS FUNCTION COEFFICIENTS AND THE C PIECEWISE POLYNOMIAL BREAKPOINT SEQUENCE. C C PACKAGE ROUTINES CALLED.. BSPLVD,INTERV C USER ROUTINES CALLED.. NONE C CALLED BY.. USERS MAIN PROGRAM C FORTRAN FUNCTIONS USED.. NONE C C----------------------------------------------------------------------- SAVE ILEFT, MFLAG COMMON /SIZES/ NINT,KORD,NCC,NPDE,NCPTS,NEQN,IQUAD COMMON /ISTART/ IW1,IW2,IW3,IW4,IW5,IW6,IDUM(12) COMMON /OPTION/ NOGAUS,MAXDER DIMENSION USOL(NDIM1,NDIM2,NDERV+1),X(NPTS),SCTCH(KORD*(NDERV+1)), * WORK(KORD+NPDE*(4+9*NPDE)+(KORD+(NINT-1)*(KORD-NCC))* * (3*KORD+2+NPDE*(3*(KORD-1)*NPDE+MAXDER+4))) DATA ILEFT/0/, MFLAG/0/ NDERV1 = NDERV + 1 DO 20 IPTS=1,NPTS CALL INTERV(WORK(IW2),NCPTS,X(IPTS),ILEFT,MFLAG) CALL BSPLVD(WORK(IW2),KORD,X(IPTS),ILEFT,SCTCH,NDERV1) IK = ILEFT - KORD DO 10 M=1,NDERV1 I1 = (M-1)*KORD DO 10 K=1,NPDE USOL(K,IPTS,M) = 0. DO 10 I=1,KORD I2 = (I+IK-1)*NPDE + IW6 - 1 USOL(K,IPTS,M) = USOL(K,IPTS,M) + WORK(I2+K) * SCTCH(I+I1) 10 CONTINUE 20 CONTINUE RETURN END C C C ############################################################################## C C BLOCK DATA IMPLICIT REAL*8 (A-H, O-Z) C------------------------------------------------------------------------------- C IN THE FOLLOWING DATA STATEMENT, SET.. C LOUT = THE LOGICAL UNIT NUMBER FOR THE OUTPUT OF MESSAGES DURING C THE INTEGRATION. C NOGAUS = SET .EQ. 1 IF THE GAUSS-LEGENDRE COLLOCATION POINTS ARE C NOT DESIRED WHEN NCC = 2 (SEE PDECOL AND COLPNT). C MAXDER = SET .EQ. 5. ITS VALUE REPRESENTS THE MAXIMUM ORDER OF C THE TIME INTEGRATION ALLOWED. ITS VALUE AFFECTS THE STOR- C AGE REQUIRED IN WORK AND MAY BE CHANGED IF DESIRED C (SEE COSET FOR RESTRICTIONS). C UROUND = THE UNIT ROUNDOFF OF THE MACHINE, I.E. THE SMALLEST C POSITIVE U SUCH THAT 1. + U .NE. 1. ON THE MACHINE. C------------------------------------------------------------------------------- COMMON /GEAR1/ DUM(5),UROUND,IDUM(4) COMMON /OPTION/ NOGAUS,MAXDER COMMON /IOUNIT/ LOUT C*** C*** UROUND SET TO SINGLE PRECISION FOR A SUN SPARC2 C*** C*** DATA LOUT,NOGAUS,MAXDER,UROUND/6, 0, 5, 5.960464D-08/ C DATA LOUT,NOGAUS,MAXDER,UROUND/66, 0, 5, 2.22D-16/ END C C C ############################################################################## C C SUBROUTINE INITAL(K,A,RHS,X,XT,XC,PW,IPIV,ILEFT) IMPLICIT REAL*8 (A-H, O-Z) C------------------------------------------------------------------------------- C INITAL IS CALLED ONLY ONCE BY PDECOL TO PERFORM INITIALIZATION TASKS. C THESE TASKS INCLUDE - 1) DEFINING THE PIECEWISE POLYNOMIAL SPACE C BREAKPOINT SEQUENCE, 2) CALLING THE SUBROUTINE COLPNT TO DEFINE THE C REQUIRED COLLOCATION POINTS, 3) DEFING THE PIECEWISE POLYNOMIAL SPACE C BASIS FUNCTION VALUES (PLUS FIRST AND SECOND DERIVATIVE VALUES) AT C THE COLLOCATION POINTS, AND 4) DEFINING THE INITIAL BASIS FUNCTION C COEFFICIENTS WHICH DETERMINE THE PIECEWISE POLYNOMIAL WHICH C INTERPOLATES THE USER SUPPLIED (UINIT) INITIAL CONDITION FUNCTION(S) C AT THE COLLOCATION POINTS. C C K = ORDER OF PIECEWISE POLYNOMIAL SPACE. C A = BASIS FUNCTION VALUES GENERATED BY INITAL. C RHS = TEMPORARY STORAGE USED TO RETURN INITIAL CONDITION COEFFICIENT C VALUES. C X = USER DEFINED PIECEWISE POLYNOMIAL BREAKPOINTS. C XT = PIECEWISE POLYNOMIAL BREAKPOINT SEQUENCE GENERATED BY INITAL. C XC = COLLOCATION POINTS GENERATED BY INITAL. C PW = STORAGE FOR BAND MATRIX USED TO GENERATE INITIAL C COEFFICIENT VALUES. C IPIV = PIVOT INFORMATION FOR LINEAR EQUATION SOLVER DECB-SOLB. C ILEFT = POINTERS TO BREAKPOINT SEQUENCE GENERATED BY INITAL. C C PACKAGE ROUTINES CALLED.. BSPLVD,COLPNT,DECB,INTERV,SOLB C USER ROUTINES CALLED.. UINIT C CALLED BY.. PDECOL C FORTRAN FUNCTIONS USED.. MAX0,MIN0 C------------------------------------------------------------------------------- COMMON /SIZES/ NINT,KORD,NCC,NPDE,NCPTS,NEQN,IER COMMON /GEAR9/ EPSJ,R0,ML,MU,IDUM(3),N0W DIMENSION A(K,3,NCPTS),RHS(NEQN),X(NINT+1),XT(NCPTS+KORD), * XC(NCPTS),PW(NEQN*(3*ML+1)), * IPIV(NEQN),ILEFT(NCPTS) MFLAG = -2 IER = 0 C----------------------------------------------------------------------- C SET UP THE PIECEWISE POLYNOMIAL SPACE BREAKPOINT SEQUENCE. C----------------------------------------------------------------------- KRPT = KORD - NCC DO 10 I=1,KORD XT(NCPTS+I) = X(NINT+1) 10 XT(I) = X(1) DO 20 I=2,NINT I1 = (I-2)*KRPT + KORD DO 20 J=1,KRPT 20 XT(I1+J) = X(I) C----------------------------------------------------------------------- C SET UP COLLOCATION POINTS ARRAY XC. C----------------------------------------------------------------------- CALL COLPNT(X, XC, XT) C----------------------------------------------------------------------- C GENERATE THE ILEFT ARRAY. STORE THE BASIS FUNCTION VALUES IN THE C ARRAY A. THE ARRAY A IS DIMENSIONED A(KORD,3,NCPTS) AND A(K,J,I) C CONTAINS THE VALUE OF THE (J-1)-ST DERIVATIVE (J = 1,2,3) OF THE K-TH C NONZERO BASIS FUNCTION (K = 1, ... ,KORD) AT THE I-TH COLLOCATION C POINT (I = 1, ... ,NCPTS). SET UP RHS FOR INTERPOLATING THE INITIAL C CONDITIONS AT THE COLLOCATION POINTS. SET THE INTERPOLATION MATRIX C INTO THE BANDED MATRIX PW. C----------------------------------------------------------------------- DO 30 I=1,N0W 30 PW(I) = 0. DO 40 I=1,NCPTS CALL INTERV(XT,NCPTS,XC(I),ILEFT(I),MFLAG) CALL BSPLVD(XT,KORD,XC(I),ILEFT(I),A(1,1,I),3) I1 = NPDE * (I-1) CALL UINIT(XC(I),RHS(I1+1),NPDE) ICOL = ILEFT(I) - I - 1 JL = MAX0(1,I+2-NCPTS) JU = MIN0(KORD,KORD+I-2) DO 40 J=JL,JU J1 = I1 + NEQN * (NPDE * (ICOL + J) - 1) DO 40 JJ=1,NPDE 40 PW(JJ+J1) = A(J,1,I) C----------------------------------------------------------------------- C LU DECOMPOSE THE MATRIX PW. C----------------------------------------------------------------------- CALL DECB (NEQN,NEQN,ML,MU,PW,IPIV,IER) IF ( IER .NE. 0 ) RETURN C----------------------------------------------------------------------- C SOLVE THE LINEAR SYSTEM PW*Z = RHS. THIS GIVES THE BASIS FUNCTION C COEFFICIENTS FOR THE INITIAL CONDITIONS. C----------------------------------------------------------------------- CALL SOLB (NEQN,NEQN,ML,MU,PW,RHS,IPIV) RETURN END C C C ############################################################################## C C SUBROUTINE COLPNT(X, XC, XT) IMPLICIT REAL*8 (A-H, O-Z) C------------------------------------------------------------------------------- C COLPNT IS CALLED ONLY ONCE BY INITAL TO DEFINE THE REQUIRED COLLOCA- C TION POINTS WHICH ARE TO BE USED WITH THE USER SELECTED PIECEWISE C POLYNOMIAL SPACE. THE COLLOCATION POINTS ARE CHOSEN SUCH THAT THEY C ARE EITHER THE POINTS AT WHICH THE PIECEWISE POLYNOMIAL SPACE BASIS C FUNCTIONS ATTAIN THEIR UNIQUE MAXIMUM VALUES, OR, THE GAUSS-LEGENDRE C QUADRATURE POINTS WITHIN EACH PIECEWISE POLYNOMIAL SPACE SUBINTERVAL, C DEPENDING UPON THE SPACE BEING USED AND THE DESIRE OF THE USER. C C X = USER DEFINED PIECEWISE POLYNOMIAL BREAKPOINTS. C XC = COLLOCATION POINTS DEFINED BY COLPNT. C XT = PIECEWISE POLYNOMIAL BREAKPOINT SEQUENCE. C C PACKAGE ROUTINES CALLED.. BSPLVD,INTERV C USER ROUTINES CALLED.. NONE C CALLED BY.. INITAL C FORTRAN FUNCTIONS USED.. NONE C------------------------------------------------------------------------------- SAVE ILEFT COMMON /SIZES/ NINT,KORD,NCC,NPDE,NCPTS,NEQN,IQUAD COMMON /OPTION/ NOGAUS,MAXDER DIMENSION RHO(40),X(NINT+1),XC(NCPTS),XT(NCPTS+KORD) DATA ILEFT/0/ C----------------------------------------------------------------------- C IF THE VARIABLE NOGAUS IN THE COMMON BLOCK /OPTION/ IS SET .EQ. 1, C THE USE OF THE GAUSS-LEGENDRE POINTS IS PROHIBITED FOR ALL CASES. C NOGAUS IS CURRENTLY SET .EQ. 0 BY A DATA STATEMENT IN THE BLOCK DATA. C THE USER MAY CHANGE THIS AS DESIRED. C----------------------------------------------------------------------- IF ( NCC .NE. 2 .OR. NOGAUS .EQ. 1 ) GO TO 200 C----------------------------------------------------------------------- C COMPUTE THE COLLOCATION POINTS TO BE AT THE GAUSS-LEGENDRE POINTS IN C EACH PIECEWISE POLYNOMIAL SPACE SUBINTERVAL. THE ARRAY RHO IS SET TO C CONTAIN THE GAUSS-LEGENDRE POINTS FOR THE STANDARD INTERVAL (-1,1). C----------------------------------------------------------------------- IPTS = KORD - 2 GO TO (10,20,30,40,50,60,70,80,90,100,110,120,130,140,150,160,170, * 180),IPTS 10 RHO(1) = 0. GO TO 190 20 RHO(2) = .577350269189626D-00 RHO(1) = - RHO(2) GO TO 190 30 RHO(3) = .774596669241483D-00 RHO(1) = - RHO(3) RHO(2) = 0. GO TO 190 40 RHO(3) = .339981043584856D-00 RHO(2) = - RHO(3) RHO(4) = .861136311594053D-00 RHO(1) = - RHO(4) GO TO 190 50 RHO(4) = .538469310105683D-00 RHO(2) = - RHO(4) RHO(5) = .906179845938664D-00 RHO(1) = - RHO(5) RHO(3) = 0. GO TO 190 60 RHO(4) = .238619186083197D-00 RHO(3) = - RHO(4) RHO(5) = .661209386466265D-00 RHO(2) = - RHO(5) RHO(6) = .932469514203152D-00 RHO(1) = - RHO(6) GO TO 190 70 RHO(5) = .405845151377397D-00 RHO(3) = - RHO(5) RHO(6) = .741531185599394D-00 RHO(2) = - RHO(6) RHO(7) = .949107912342759D-00 RHO(1) = - RHO(7) RHO(4) = 0. GO TO 190 80 RHO(5) = .183434642495650D-00 RHO(4) = - RHO(5) RHO(6) = .525532409916329D-00 RHO(3) = - RHO(6) RHO(7) = .796666477413627D-00 RHO(2) = - RHO(7) RHO(8) = .960289856497536D-00 RHO(1) = - RHO(8) GO TO 190 90 RHO( 5) = .0 RHO( 6) = .324253423403809D-00 RHO( 7) = .613371432700590D-00 RHO( 8) = .836031107326636D-00 RHO( 9) = .968160239507626D-00 DO 95 I=1,4 95 RHO(I) = -RHO(10-I) GO TO 190 100 RHO( 6) = .148874338981631D-00 RHO( 7) = .433395394129247D-00 RHO( 8) = .679409568299024D-00 RHO( 9) = .865063366688984D-00 RHO(10) = .973906528517172D-00 DO 105 I=1,5 105 RHO(I) = -RHO(11-I) GO TO 190 110 RHO( 6) = .0 RHO( 7) = .269543155952345D-00 RHO( 8) = .519096129206812D-00 RHO( 9) = .730152005574049D-00 RHO(10) = .887062599768095D-00 RHO(11) = .978228658146057D-00 DO 115 I=1,5 115 RHO(I) = -RHO(12-I) GO TO 190 120 RHO( 7) = .125233408511469D-00 RHO( 8) = .367831498998180D-00 RHO( 9) = .587317954286617D-00 RHO(10) = .769902674194305D-00 RHO(11) = .904117256370475D-00 RHO(12) = .981560634246719D-00 DO 125 I=1,6 125 RHO(I) = -RHO(13-I) GO TO 190 130 RHO( 7) = .0 RHO( 8) = .230458315955135D-00 RHO( 9) = .448492751036447D-00 RHO(10) = .642349339440340D-00 RHO(11) = .801578090733310D-00 RHO(12) = .917598399222978D-00 RHO(13) = .984183054718588D-00 DO 135 I=1,6 135 RHO(I) = -RHO(14-I) GO TO 190 140 RHO( 8) = .108054948707344D-00 RHO( 9) = .319112368927890D-00 RHO(10) = .515248636358154D-00 RHO(11) = .687292904811685D-00 RHO(12) = .827201315069765D-00 RHO(13) = .928434883663574D-00 RHO(14) = .986283808696812D-00 DO 145 I=1,7 145 RHO(I) = -RHO(15-I) GO TO 190 150 RHO( 8) = .0 RHO( 9) = .201194093997435D-00 RHO(10) = .394151347077563D-00 RHO(11) = .570972172608539D-00 RHO(12) = .724417731360170D-00 RHO(13) = .848206583410427D-00 RHO(14) = .937273392400706D-00 RHO(15) = .987992518020485D-00 DO 155 I = 1,7 155 RHO(I) = -RHO(16-I) GO TO 190 160 RHO( 9) = .950125098376374D-01 RHO(10) = .281603550779259D-00 RHO(11) = .458016777657227D-00 RHO(12) = .617876244402644D-00 RHO(13) = .755404408355003D-00 RHO(14) = .865631202387832D-00 RHO(15) = .944575023073233D-00 RHO(16) = .989400934991650D-00 DO 165 I=1,8 165 RHO(I) = -RHO(17-I) GO TO 190 170 RHO( 9) = .0 RHO(10) = .178484181495848D-00 RHO(11) = .351231763453876D-00 RHO(12) = .512690537086477D-00 RHO(13) = .657671159216691D-00 RHO(14) = .781514003896801D-00 RHO(15) = .880239153726986D-00 RHO(16) = .950675521768768D-00 RHO(17) = .990575475314417D-00 DO 175 I=1,8 175 RHO(I) = -RHO(18-I) GO TO 190 180 RHO(10) = .847750130417353D-01 RHO(11) = .251886225691506D-00 RHO(12) = .411751161462843D-00 RHO(13) = .559770831073948D-00 RHO(14) = .691687043060353D-00 RHO(15) = .803704958972523D-00 RHO(16) = .892602466497556D-00 RHO(17) = .955823949571398D-00 RHO(18) = .991565168420931D-00 DO 185 I=1,9 185 RHO(I) = -RHO(19-I) C----------------------------------------------------------------------- C COMPUTE THE GAUSS-LEGENDRE COLLOCATION POINTS IN EACH SUBINTERVAL. C----------------------------------------------------------------------- 190 DO 195 I=1,NINT FAC = ( X(I+1) - X(I) ) * .5 DO 195 J = 1,IPTS KNOT = IPTS * (I-1) + J + 1 195 XC(KNOT) = X(I) + FAC * ( RHO(J) + 1. ) XC(1) = X(1) XC(NCPTS) = X(NINT+1) RETURN C----------------------------------------------------------------------- C COMPUTE THE COLLOCATION POINTS TO BE AT THE POINTS WHERE THE BASIS C FUNCTIONS ATTAIN THEIR MAXIMA. A BISECTION METHOD IS USED TO FIND C THE POINTS TO MACHINE PRECISION. THIS PROCESS COULD BE SPEEDED UP C BY USING A SECANT METHOD IF DESIRED. C----------------------------------------------------------------------- 200 ITOP = NCPTS - 1 MFLAG = -2 XC(1) = X(1) XC(NCPTS) = X(NINT+1) DO 240 I=2,ITOP XOLD = 1.E+20 XL = XT(I) XR = XT(I+KORD) 210 XNEW = .5 * (XL + XR) IF( XOLD .EQ. XNEW ) GO TO 240 CALL INTERV(XT,NCPTS,XNEW,ILEFT,MFLAG) CALL BSPLVD(XT,KORD,XNEW,ILEFT,RHO,2) DO 220 J=1,KORD IF( I .EQ. J + ILEFT - KORD ) GO TO 230 220 CONTINUE 230 XVAL = RHO(KORD+J) IF( XVAL .EQ. 0.0 ) XR = XNEW IF( XVAL .GT. 0.0 ) XL = XNEW IF( XVAL .LT. 0.0 ) XR = XNEW XOLD = XNEW GO TO 210 240 XC(I) = XR RETURN END C C C ############################################################################## C C SUBROUTINE BSPLVD ( XT, K, X, ILEFT, VNIKX, NDERIV ) IMPLICIT REAL*8 (A-H, O-Z) C------------------------------------------------------------------------------- C THIS SUBROUTINE IS PART OF THE B-SPLINE PACKAGE FOR THE STABLE C EVALUATION OF ANY B-SPLINE BASIS FUNCTION OR DERIVATIVE VALUE. C SEE REFERENCE BELOW. C C CALCULATES THE VALUE AND THE FIRST NDERIV-1 DERIVATIVES OF ALL C B-SPLINES WHICH DO NOT VANISH AT X. THE ROUTINE FILLS THE TWO- C DIMENSIONAL ARRAY VNIKX(J,IDERIV), J=IDERIV, ... ,K WITH NONZERO C VALUES OF B-SPLINES OF ORDER K+1-IDERIV, IDERIV=NDERIV, ... ,1, BY C REPEATED CALLS TO BSPLVN. C C XT = PIECEWISE POLYNOMIAL BREAKPOINT SEQUENCE. C K = ORDER OF THE PIECEWISE POLYNOMIAL SPACE. C X = POINT AT WHICH THE B-SPLINE IS TO BE EVALUATED. C ILEFT = POINTER TO THE BREAKPOINT SEQUENCE. C VNIKX = TABLE OF B-SPLINE VALUES AND DERIVATIVES. C NDERIV = DETERMINES NUMBER OF DERIVATIVES TO BE GENERATED. C C REFERENCE C C DEBOOR, C., PACKAGE FOR CALCULATING WITH B-SPLINES, SIAM J. C NUMER. ANAL., VOL. 14, NO. 3, JUNE 1977, PP. 441-472. C C PACKAGE ROUTINES CALLED.. BSPLVN C USER ROUTINES CALLED.. NONE C CALLED BY.. COLPNT,INITAL,VALUES C FORTRAN FUNCTIONS USED.. FLOAT,MAX0 C------------------------------------------------------------------------------- COMMON /SIZES/ NINT,KORD,NCC,NPDE,NCPTS,NEQN,IQUAD DIMENSION XT(NCPTS+KORD),VNIKX(K,NDERIV) DIMENSION A(20,20) KO = K + 1 - NDERIV CALL BSPLVN(XT,KO,1,X,ILEFT,VNIKX(NDERIV,NDERIV)) IF (NDERIV .LE. 1) GO TO 120 IDERIV = NDERIV DO 20 I=2,NDERIV IDERVM = IDERIV-1 DO 10 J=IDERIV,K 10 VNIKX(J-1,IDERVM) = VNIKX(J,IDERIV) IDERIV = IDERVM CALL BSPLVN(XT,0,2,X,ILEFT,VNIKX(IDERIV,IDERIV)) 20 CONTINUE DO 40 I=1,K DO 30 J=1,K 30 A(I,J) = 0. 40 A(I,I) = 1. KMD = K DO 110 M=2,NDERIV KMD = KMD - 1 FKMD = FLOAT(KMD) I = ILEFT J = K 50 JM1 = J-1 IPKMD = I + KMD DIFF = XT(IPKMD) -XT(I) IF (JM1 .EQ. 0) GO TO 80 IF (DIFF .EQ. 0.) GO TO 70 DO 60 L=1,J 60 A(L,J) = (A(L,J) - A(L,J-1))/DIFF*FKMD 70 J = JM1 I = I - 1 GO TO 50 80 IF (DIFF .EQ. 0.) GO TO 90 A(1,1) = A(1,1)/DIFF*FKMD 90 DO 110 I=1,K V = 0. JLOW = MAX0(I,M) DO 100 J=JLOW,K 100 V = A(I,J)*VNIKX(J,M) + V 110 VNIKX(I,M) = V 120 RETURN END C C C ############################################################################## C C SUBROUTINE BSPLVN ( XT, JHIGH, INDEX, X, ILEFT, VNIKX ) IMPLICIT REAL*8 (A-H, O-Z) C------------------------------------------------------------------------------- C THIS SUBROUTINE IS PART OF THE B-SPLINE PACKAGE FOR THE STABLE C EVALUATION OF ANY B-SPLINE BASIS FUNCTION OR DERIVATIVE VALUE. C SEE REFERENCE BELOW. C C CALCULATES THE VALUE OF ALL POSSIBLY NONZERO B-SPLINES AT THE C POINT X OF ORDER MAX(JHIGH,(J+1)(INDEX-1)) FOR THE BREAKPOINT SEQ- C UENCE XT. ASSUMING THAT XT(ILEFT) .LE. X .LE. XT(ILEFT+1), THE ROUT- C INE RETURNS THE B-SPLINE VALUES IN THE ONE DIMENSIONAL ARRAY VNIKX. C C FOR DEFINITIONS OF CALLING ARGUMENTS SEE ABOVE AND BSPLVD. C C REFERENCE C C DEBOOR, C., PACKAGE FOR CALCULATING WITH B-SPLINES, SIAM J. C NUMER. ANAL., VOL. 14, NO. 3, JUNE 1977, PP. 441-472. C C PACKAGE ROUTINES CALLED.. NONE C USER ROUTINES CALLED.. NONE C CALLED BY.. BSPLVD C FORTRAN FUNCTIONS USED.. NONE C------------------------------------------------------------------------------- SAVE J,DELTAM,DELTAP COMMON /SIZES/ NINT,KORD,NCC,NPDE,NCPTS,NEQN,IQUAD DIMENSION DELTAM(20),DELTAP(20) DIMENSION XT(NCPTS+KORD),VNIKX(*) DATA J/1/,DELTAM/20*0.D-00/,DELTAP/20*0.D-00/ GO TO (10,20),INDEX 10 J = 1 VNIKX(1) = 1. IF (J .GE. JHIGH) GO TO 40 20 IPJ = ILEFT+J DELTAP(J) = XT(IPJ) - X IMJP1 = ILEFT-J+1 DELTAM(J) = X - XT(IMJP1) VMPREV = 0. JP1 = J+1 DO 30 L=1,J JP1ML = JP1-L VM = VNIKX(L)/(DELTAP(L) + DELTAM(JP1ML)) VNIKX(L) = VM*DELTAP(L) + VMPREV 30 VMPREV = VM*DELTAM(JP1ML) VNIKX(JP1) = VMPREV J = JP1 IF (J .LT. JHIGH) GO TO 20 40 RETURN END C C C ############################################################################## C C SUBROUTINE INTERV ( XT, LXT, X, ILEFT, MFLAG ) IMPLICIT REAL*8 (A-H, O-Z) C------------------------------------------------------------------------------- C THIS SUBROUTINE IS PART OF THE B-SPLINE PACKAGE FOR THE STABLE C EVALUATION OF ANY B-SPLINE BASIS FUNCTION OR DERIVATIVE VALUE. C SEE REFERENCE BELOW. C C COMPUTES LARGEST ILEFT IN (1,LXT) SUCH THAT XT(ILEFT) .LE. X. THE C PROGRAM STARTS THE SEARCH FOR ILEFT WITH THE VALUE OF ILEFT THAT WAS C RETURNED AT THE PREVIOUS CALL (AND WAS SAVED IN THE LOCAL VARIABLE C ILO) TO MINIMIZE THE WORK IN THE COMMON CASE THAT THE VALUE OF X ON C THIS CALL IS CLOSE TO THE VALUE OF X ON THE PREVIOUS CALL. SHOULD C THIS ASSUMPTION NOT BE VALID, THEN THE PROGRAM LOCATES ILO AND IHI C SUCH THAT XT(ILO) .LE. X .LT. XT(IHI) AND, ONCE THEY ARE FOUND USES C BISECTION TO FIND THE CORRECT VALUE FOR ILEFT. MFLAG IS AN ERROR FLAG. C C FOR DEFINITIONS OF CALLING ARGUMENTS SEE ABOVE AND BSPLVD. C C REFERENCE C C DEBOOR, C., PACKAGE FOR CALCULATING WITH B-SPLINES, SIAM J. C NUMER. ANAL., VOL. 14, NO. 3, JUNE 1977, PP. 441-472. C C PACKAGE ROUTINES CALLED.. NONE C USER ROUTINES CALLED.. NONE C CALLED BY.. COLPNT,INITAL,VALUES C FORTRAN FUNCTIONS USED.. NONE C------------------------------------------------------------------------------- SAVE ILO DIMENSION XT(LXT) IF(MFLAG.EQ.-2) ILO = 1 IHI = ILO + 1 IF (IHI .LT. LXT) GO TO 20 IF (X .GE. XT(LXT)) GO TO 110 IF (LXT .LE. 1) GO TO 90 ILO = LXT - 1 GO TO 21 20 IF (X .GE. XT(IHI)) GO TO 40 21 IF (X .GE. XT(ILO)) GO TO 100 C----------------------------------------------------------------------- C NOW X .LT. XT(IHI). FIND LOWER BOUND. C----------------------------------------------------------------------- CC 30 ISTEP = 1 ISTEP = 1 31 IHI = ILO ILO = IHI - ISTEP IF (ILO .LE. 1) GO TO 35 IF (X .GE. XT(ILO)) GO TO 50 ISTEP = ISTEP*2 GO TO 31 35 ILO = 1 IF (X .LT. XT(1)) GO TO 90 GO TO 50 C----------------------------------------------------------------------- C NOW X .GE. XT(ILO). FIND UPPER BOUND. C----------------------------------------------------------------------- 40 ISTEP = 1 41 ILO = IHI IHI = ILO + ISTEP IF (IHI .GE. LXT) GO TO 45 IF (X .LT. XT(IHI)) GO TO 50 ISTEP = ISTEP*2 GO TO 41 45 IF (X .GE. XT(LXT)) GO TO 110 IHI = LXT C----------------------------------------------------------------------- C NOW XT(ILO) .LE. X .LT. XT(IHI). NARROW THE INTERVAL. C----------------------------------------------------------------------- 50 MIDDLE = (ILO + IHI)/2 IF (MIDDLE .EQ. ILO) GO TO 100 C----------------------------------------------------------------------- C NOTE.. IT IS ASSUMED THAT MIDDLE = ILO IN CASE IHI = ILO+1. C----------------------------------------------------------------------- IF (X .LT. XT(MIDDLE)) GO TO 53 ILO = MIDDLE GO TO 50 53 IHI = MIDDLE GO TO 50 C----------------------------------------------------------------------- C SET OUTPUT AND RETURN. C----------------------------------------------------------------------- 90 MFLAG = -1 ILEFT = 1 RETURN 100 MFLAG = 0 ILEFT = ILO RETURN 110 MFLAG = 1 ILEFT = LXT RETURN END C C C ############################################################################## C C SUBROUTINE STIFIB (N0,Y,YMAX,ERROR,SAVE1,SAVE2,SAVE3, * PW,IPIV,WORK,IWORK) IMPLICIT REAL*8 (A-H, O-Z) C------------------------------------------------------------------------------- C STIFIB PERFORMS ONE STEP OF THE INTEGRATION OF AN INITIAL VALUE C PROBLEM FOR A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM, C A(Y,T)*(DY/DT) = G(Y,T), WHERE Y = (Y(1),Y(2), ... ,Y(N)). C STIFIB IS FOR USE WHEN THE MATRICES A AND DG/DY HAVE BANDED OR NEARLY C BANDED FORM. THE DEPENDENCE OF A(Y,T) ON Y IS ASSUMED TO BE WEAK. C C REFERENCE C C HINDMARSH, A.C., PRELIMINARY DOCUMENTATION OF GEARIB.. SOLUTION C OF IMPLICIT SYSTEMS OF ORDINARY DIFFERENTIAL EQUATIONS WITH C BANDED JACOBIANS, LAWRENCE LIVERMORE LAB, UCID-30130, FEBRUARY C 1976. C C COMMUNICATION WITH STIFIB IS DONE WITH THE FOLLOWING VARIABLES.. C C Y AN N0 BY LMAX ARRAY CONTAINING THE DEPENDENT VARIABLES C AND THEIR SCALED DERIVATIVES. LMAX IS 13 FOR THE ADAMS C METHODS AND 6 FOR THE GEAR METHODS. LMAX - 1 = MAXDER C IS THE MAXIMUM ORDER AVAILABLE. SEE SUBROUTINE COSET. C Y(I,J+1) CONTAINS THE J-TH DERIVATIVE OF Y(I), SCALED BY C H**J/FACTORIAL(J) (J = 0,1,...,NQ). C N0 A CONSTANT INTEGER .GE. N, USED FOR DIMENSIONING PURPOSES. C T THE INDEPENDENT VARIABLE. T IS UPDATED ON EACH STEP TAKEN. C H THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. C H IS ALTERED BY THE ERROR CONTROL ALGORITHM DURING THE C PROBLEM. H CAN BE EITHER POSITIVE OR NEGATIVE, BUT ITS C SIGN MUST REMAIN CONSTANT THROUGHOUT THE PROBLEM. C HMIN, THE MINIMUM AND MAXIMUM ABSOLUTE VALUE OF THE STEP SIZE C HMAX TO BE USED FOR THE STEP. THESE MAY BE CHANGED AT ANY C TIME, BUT WILL NOT TAKE EFFECT UNTIL THE NEXT H CHANGE. C EPS THE RELATIVE ERROR BOUND. SEE DESCRIPTION IN PDECOL. C UROUND THE UNIT ROUNDOFF OF THE MACHINE. C N THE NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS. C MF THE METHOD FLAG. SEE DESCRIPTION IN PDECOL. C KFLAG A COMPLETION CODE WITH THE FOLLOWING MEANINGS.. C 0 THE STEP WAS SUCCESFUL. C -1 THE REQUESTED ERROR COULD NOT BE ACHIEVED C WITH DABS(H) = HMIN. C -2 THE REQUESTED ERROR IS SMALLER THAN CAN C BE HANDLED FOR THIS PROBLEM. C -3 CORRECTOR CONVERGENCE COULD NOT BE C ACHIEVED FOR DABS(H) = HMIN. C -4 SINGULAR A-MATRIX ENCOUNTERED. C ON A RETURN WITH KFLAG NEGATIVE, THE VALUES OF T AND C THE Y ARRAY ARE AS OF THE BEGINNING OF THE LAST C STEP, AND H IS THE LAST STEP SIZE ATTEMPTED. C JSTART AN INTEGER USED ON INPUT AND OUTPUT. C ON INPUT, IT HAS THE FOLLOWING VALUES AND MEANINGS.. C 0 PERFORM THE FIRST STEP. C .GT.0 TAKE A NEW STEP CONTINUING FROM THE LAST. C .LT.0 TAKE THE NEXT STEP WITH A NEW VALUE OF C H, EPS, N, AND/OR MF. C ON EXIT, JSTART IS NQ, THE CURRENT ORDER OF THE METHOD. C YMAX AN ARRAY OF N ELEMENTS WITH WHICH THE ESTIMATED LOCAL C ERRORS IN Y ARE COMPARED. C ERROR AN ARRAY OF N ELEMENTS. ERROR(I)/TQ(2) IS THE ESTIMATED C ONE-STEP ERROR IN Y(I). C SAVE1,SAVE2,SAVE3 THREE WORKING STORAGE ARRAYS, EACH OF LENGTH N. C PW A BLOCK OF LOCATIONS USED FOR THE CHORD ITERATION C MATRIX. SEE DESCRIPTION IN PDECOL. C IPIV AN INTEGER ARRAY OF LENGTH N FOR PIVOT INFORMATION. C ML,MU THE LOWER AND UPPER HALF BANDWIDTHS, RESPECTIVELY, OF C THE CHORD ITERATION MATRIX. SEE DESCRIPTION IN PDECOL. C WORK,IWORK WORKING ARRAYS WHICH ARE USED TO PASS APPROPRIATE C ARRAYS TO OTHER SUBROUTINES. C C PACKAGE ROUTINES CALLED.. COSET,DIFFUN,PSETIB,RES,SOLB C USER ROUTINES CALLED.. NONE C CALLED BY.. PDECOL C FORTRAN FUNCTIONS USED.. ABS,DMAX1,DMIN1,FLOAT C------------------------------------------------------------------------------- C SAVE EL,OLDL0,TQ,IER,NQ,L,METH,MITER SAVE BND,CON,CRATE,D,D1,E,EDN,ENQ1,ENQ2,ENQ3,EPSOLD, * EUP,FN,HOLD,OLDL0,PR1,PR2,PR3,R1,RC,RH,RMAX,TOLD, * I,IDOUB,IER,IREDO,IRET,IWEVAL,J,J1,J2,L,LMAX,M,MEO,METH, * MFOLD,MIO,MITER,NEWQ,NOLD,NQ,NSTEPJ COMMON /SIZES/ NINT,KORD,NCC,NPDE,NCPTS,NEQN,IQUAD COMMON /ISTART/ IW1,IW2,IW3,IW4,IW5,IW6,IW7,IW8,IW9,IW10,IW11, * IW12,IW13,IW14,IW15,IW16,IW17,IW18 COMMON /GEAR1/ T,H,HMIN,HMAX,EPS,UROUND,N,MF,KFLAG,JSTART COMMON /GEAR9/ EPSJ,R0,ML,MU,MW,NM1,N0ML,N0W COMMON /GEAR0/ HUSED,NQUSED,NSTEP,NFE,NJE COMMON /OPTION/ NOGAUS,MAXDER DIMENSION Y(NEQN,MAXDER+1),YMAX(NEQN),ERROR(NEQN),SAVE1(NEQN), * SAVE2(NEQN), * SAVE3(NEQN),PW(NEQN*(3*ML+1)),IPIV(NEQN), * IWORK((NPDE+1)*NCPTS), * WORK(KORD+NPDE*(4+9*NPDE)+(KORD+(NINT-1)*(KORD-NCC))* * (3*KORD+2+NPDE*(3*(KORD-1)*NPDE+MAXDER+4))) DIMENSION EL(13),TQ(4) DATA EL(2)/1./, OLDL0/1./, TQ(1)/0./, IER/0/ KFLAG = 0 TOLD = T IF (JSTART .GT. 0) GO TO 200 IF (JSTART .NE. 0) GO TO 120 C----------------------------------------------------------------------- C ON THE FIRST CALL, THE ORDER IS SET TO 1 AND THE INITIAL YDOT IS C CALCULATED. RMAX IS THE MAXIMUM RATIO BY WHICH H CAN BE INCREASED C IN A SINGLE STEP. IT IS INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL C INITIAL H, BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE C OCCURS (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT 2 C FOR THE NEXT INCREASE. C----------------------------------------------------------------------- NQ = 1 IER = 0 CALL DIFFUN (N, T, Y, SAVE1, IER, PW, IPIV, WORK, IWORK) IF ( IER .NE. 0 ) GO TO 685 DO 110 I = 1,N 110 Y(I,2) = H*SAVE1(I) METH = MF/10 MITER = MF - 10*METH L = 2 IDOUB = 3 RMAX = 1.E+04 RC = 0. CRATE = 1. EPSOLD = EPS HOLD = H MFOLD = MF NOLD = N NSTEP = 0 NSTEPJ = 0 NFE = 0 NJE = 1 IRET = 3 GO TO 130 C----------------------------------------------------------------------- C IF THE CALLER HAS CHANGED METH, COSET IS CALLED TO SET C THE COEFFICIENTS OF THE METHOD. IF THE CALLER HAS CHANGED C N, EPS, OR METH, THE CONSTANTS E, EDN, EUP, AND BND MUST BE RESET. C E IS A COMPARISON FOR ERRORS OF THE CURRENT ORDER NQ. EUP IS C TO TEST FOR INCREASING THE ORDER, EDN FOR DECREASING THE ORDER. C BND IS USED TO TEST FOR CONVERGENCE OF THE CORRECTOR ITERATES. C IF THE CALLER HAS CHANGED H, Y MUST BE RESCALED. C IF H OR METH HAS BEEN CHANGED, IDOUB IS RESET TO L + 1 TO PREVENT C FURTHER CHANGES IN H FOR THAT MANY STEPS. C----------------------------------------------------------------------- 120 IF (MF .EQ. MFOLD) GO TO 150 MEO = METH MIO = MITER METH = MF/10 MITER = MF - 10*METH MFOLD = MF IF (MITER .NE. MIO) IWEVAL = MITER IF (METH .EQ. MEO) GO TO 150 IDOUB = L + 1 IRET = 1 130 CALL COSET (METH, NQ, EL, TQ) LMAX = MAXDER + 1 RC = RC*EL(1)/OLDL0 OLDL0 = EL(1) 140 FN = FLOAT(N) EDN = FN*(TQ(1)*EPS)**2 E = FN*(TQ(2)*EPS)**2 EUP = FN*(TQ(3)*EPS)**2 BND = FN*(TQ(4)*EPS)**2 GO TO (160, 170, 200), IRET 150 IF ((EPS .EQ. EPSOLD) .AND. (N .EQ. NOLD)) GO TO 160 EPSOLD = EPS NOLD = N IRET = 1 GO TO 140 160 IF (H .EQ. HOLD) GO TO 200 RH = H/HOLD H = HOLD IREDO = 3 GO TO 175 170 RH = DMAX1(RH,HMIN/ DABS(H)) 175 RH = DMIN1(RH,HMAX/ DABS(H),RMAX) R1 = 1. DO 180 J = 2,L R1 = R1*RH DO 180 I = 1,N 180 Y(I,J) = Y(I,J)*R1 H = H*RH RC = RC*RH IDOUB = L + 1 IF (IREDO .EQ. 0) GO TO 690 C----------------------------------------------------------------------- C THIS SECTION COMPUTES THE PREDICTED VALUES BY EFFECTIVELY C MULTIPLYING THE Y ARRAY BY THE PASCAL TRIANGLE MATRIX. C RC IS THE RATIO OF NEW TO OLD VALUES OF THE COEFFICIENT H*EL(1). C WHEN RC DIFFERS FROM 1 BY MORE THAN 30 PERCENT, OR THE CALLER HAS C CHANGED MITER, IWEVAL IS SET TO MITER TO FORCE PW TO BE UPDATED. C IN ANY CASE, PW IS UPDATED AT LEAST EVERY 40-TH STEP. C PW IS THE CHORD ITERATION MATRIX A - H*EL(1)*(DG/DY). C----------------------------------------------------------------------- 200 IF ( DABS(RC-1.) .GT. 0.3) IWEVAL = MITER IF (NSTEP .GE. NSTEPJ+40) IWEVAL = MITER T = T + H DO 210 J1 = 1,NQ DO 210 J2 = J1,NQ J = (NQ + J1) - J2 DO 210 I = 1,N 210 Y(I,J) = Y(I,J) + Y(I,J+1) C----------------------------------------------------------------------- C UP TO 3 CORRECTOR ITERATIONS ARE TAKEN. A CONVERGENCE TEST IS C MADE ON THE R.M.S. NORM OF EACH CORRECTION, USING BND, WHICH C IS DEPENDENT ON EPS. THE SUM OF THE CORRECTIONS IS ACCUMULATED C IN THE VECTOR ERROR(I). THE Y ARRAY IS NOT ALTERED IN THE CORRECTOR C LOOP. THE UPDATED Y VECTOR IS STORED TEMPORARILY IN SAVE1. C THE UPDATED H*YDOT IS STORED IN SAVE2. C----------------------------------------------------------------------- 220 DO 230 I = 1,N SAVE2(I) = Y(I,2) 230 ERROR(I) = 0. M = 0 CALL RES (T, H, Y, SAVE2, SAVE3, NPDE, NCPTS, WORK(IW1), IWORK, * WORK, WORK(IW14), WORK(IW15), WORK(IW16), WORK(IW3), WORK(IW9)) NFE = NFE + 1 IF (IWEVAL .LE. 0) GO TO 350 C----------------------------------------------------------------------- C IF INDICATED, THE MATRIX PW IS REEVALUATED BEFORE STARTING THE C CORRECTOR ITERATION. IWEVAL IS SET TO 0 AS AN INDICATOR C THAT THIS HAS BEEN DONE. PW IS COMPUTED AND PROCESSED IN PSETIB. C----------------------------------------------------------------------- IWEVAL = 0 RC = 1.0D0 NJE = NJE + 1 NSTEPJ = NSTEP CON = -H*EL(1) CALL PSETIB (Y, PW, N0, CON, MITER, IER, WORK(IW1), IWORK, * WORK(IW3),WORK(IW9),SAVE2,IPIV,YMAX,WORK(IW11),WORK(IW12), * WORK(IW13),WORK(IW16),WORK(IW14),WORK(IW15),WORK,NPDE) IF (IER .NE. 0) GO TO 420 C----------------------------------------------------------------------- C COMPUTE THE CORRECTOR ERROR, R SUB M, AND SOLVE THE LINEAR SYSTEM C WITH THAT AS RIGHT-HAND SIDE AND PW AS COEFFICIENT MATRIX, C USING THE LU DECOMPOSITION OF PW. C----------------------------------------------------------------------- 350 CALL SOLB (N0, N, ML, MU, PW, SAVE3, IPIV) cc 370 D = 0.0D0 D = 0.0D0 DO 380 I = 1,N ERROR(I) = ERROR(I) + SAVE3(I) D = D + (SAVE3(I)/YMAX(I))**2 SAVE1(I) = Y(I,1) + EL(1)*ERROR(I) 380 SAVE2(I) = Y(I,2) + ERROR(I) C----------------------------------------------------------------------- C TEST FOR CONVERGENCE. IF M.GT.0, AN ESTIMATE OF THE CONVERGENCE C RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST. C----------------------------------------------------------------------- CC 400 IF (M .NE. 0) CRATE = DMAX1(.9*CRATE,D/D1) IF (M .NE. 0) CRATE = DMAX1(.9*CRATE,D/D1) IF ((D*DMIN1(1.D0,2.0D0*CRATE)) .LE. BND) GO TO 450 D1 = D M = M + 1 IF (M .EQ. 3) GO TO 410 CALL RES(T, H, SAVE1, SAVE2, SAVE3, NPDE, NCPTS, WORK(IW1), IWORK, * WORK, WORK(IW14), WORK(IW15), WORK(IW16), WORK(IW3), WORK(IW9)) GO TO 350 C----------------------------------------------------------------------- C THE CORRECTOR ITERATION FAILED TO CONVERGE IN 3 TRIES. C IF THE MATRIX PW IS NOT UP TO DATE, IT IS REEVALUATED FOR THE C NEXT TRY. OTHERWISE THE Y ARRAY IS RETRACTED TO ITS VALUES C BEFORE PREDICTION, AND H IS REDUCED, IF POSSIBLE. IF NOT, A C NO-CONVERGENCE EXIT IS TAKEN. C----------------------------------------------------------------------- 410 NFE = NFE + 2 IF (IWEVAL .EQ. -1) GO TO 440 420 T = TOLD RMAX = 2. DO 430 J1 = 1,NQ DO 430 J2 = J1,NQ J = (NQ + J1) - J2 DO 430 I = 1,N 430 Y(I,J) = Y(I,J) - Y(I,J+1) IF ( DABS(H) .LE. HMIN*1.00001) GO TO 680 RH = .25 IREDO = 1 GO TO 170 440 IWEVAL = MITER GO TO 220 C----------------------------------------------------------------------- C THE CORRECTOR HAS CONVERGED. IWEVAL IS SET TO -1 TO SIGNAL C THAT PW MAY NEED UPDATING ON SUBSEQUENT STEPS. THE ERROR TEST C IS MADE AND CONTROL PASSES TO STATEMENT 500 IF IT FAILS. C----------------------------------------------------------------------- 450 IWEVAL = -1 NFE = NFE + M D = 0. DO 460 I = 1,N 460 D = D + (ERROR(I)/YMAX(I))**2 IF (D .GT. E) GO TO 500 C----------------------------------------------------------------------- C AFTER A SUCCESSFUL STEP, UPDATE THE Y ARRAY. C CONSIDER CHANGING H IF IDOUB = 1. OTHERWISE DECREASE IDOUB BY 1. C IF IDOUB IS THEN 1 AND NQ .LT. MAXDER, THEN ERROR IS SAVED FOR C USE IN A POSSIBLE ORDER INCREASE ON THE NEXT STEP. C IF A CHANGE IN H IS CONSIDERED, AN INCREASE OR DECREASE IN ORDER C BY ONE IS CONSIDERED ALSO. A CHANGE IN H IS MADE ONLY IF IT IS BY A C FACTOR OF AT LEAST 1.1. IF NOT, IDOUB IS SET TO 10 TO PREVENT C TESTING FOR THAT MANY STEPS. C----------------------------------------------------------------------- KFLAG = 0 IREDO = 0 NSTEP = NSTEP + 1 HUSED = H NQUSED = NQ DO 470 J = 1,L DO 470 I = 1,N 470 Y(I,J) = Y(I,J) + EL(J)*ERROR(I) IF (IDOUB .EQ. 1) GO TO 520 IDOUB = IDOUB - 1 IF (IDOUB .GT. 1) GO TO 700 IF (L .EQ. LMAX) GO TO 700 DO 490 I = 1,N 490 Y(I,LMAX) = ERROR(I) GO TO 700 C----------------------------------------------------------------------- C THE ERROR TEST FAILED. KFLAG KEEPS TRACK OF MULTIPLE FAILURES. C RESTORE T AND THE Y ARRAY TO THEIR PREVIOUS VALUES, AND PREPARE C TO TRY THE STEP AGAIN. COMPUTE THE OPTIMUM STEP SIZE FOR THIS OR C ONE LOWER ORDER. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 T = TOLD DO 510 J1 = 1,NQ DO 510 J2 = J1,NQ J = (NQ + J1) - J2 DO 510 I = 1,N 510 Y(I,J) = Y(I,J) - Y(I,J+1) RMAX = 2. IF ( DABS(H) .LE. HMIN*1.00001) GO TO 660 IF (KFLAG .LE. -3) GO TO 640 IREDO = 2 PR3 = 1.E+20 GO TO 540 C----------------------------------------------------------------------- C REGARDLESS OF THE SUCCESS OR FAILURE OF THE STEP, FACTORS C PR1, PR2, AND PR3 ARE COMPUTED, BY WHICH H COULD BE DIVIDED C AT ORDER NQ - 1, ORDER NQ, OR ORDER NQ + 1, RESPECTIVELY. C IN THE CASE OF FAILURE, PR3 = 1.E20 TO AVOID AN ORDER INCREASE. C THE SMALLEST OF THESE IS DETERMINED AND THE NEW ORDER CHOSEN C ACCORDINGLY. IF THE ORDER IS TO BE INCREASED, WE COMPUTE ONE C ADDITIONAL SCALED DERIVATIVE. C----------------------------------------------------------------------- 520 PR3 = 1.E+20 IF (L .EQ. LMAX) GO TO 540 D1 = 0. DO 530 I = 1,N 530 D1 = D1 + ((ERROR(I) - Y(I,LMAX))/YMAX(I))**2 ENQ3 = .5/ FLOAT(L+1) PR3 = ((D1/EUP)**ENQ3)*1.4 + 1.4D-06 540 ENQ2 = .5/ FLOAT(L) PR2 = ((D/E)**ENQ2)*1.2 + 1.2D-06 PR1 = 1.E+20 IF (NQ .EQ. 1) GO TO 560 D = 0. DO 550 I = 1,N 550 D = D + (Y(I,L)/YMAX(I))**2 ENQ1 = .5/ FLOAT(NQ) PR1 = ((D/EDN)**ENQ1)*1.3 + 1.3D-06 560 IF (PR2 .LE. PR3) GO TO 570 IF (PR3 .LT. PR1) GO TO 590 GO TO 580 570 IF (PR2 .GT. PR1) GO TO 580 NEWQ = NQ RH = 1./PR2 GO TO 620 580 NEWQ = NQ - 1 RH = 1./PR1 GO TO 620 590 NEWQ = L RH = 1./PR3 IF (RH .LT. 1.1) GO TO 610 DO 600 I = 1,N 600 Y(I,NEWQ+1) = ERROR(I)*EL(L)/ FLOAT(L) GO TO 630 610 IDOUB = 10 GO TO 700 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1)) GO TO 610 C----------------------------------------------------------------------- C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, AND THE COEFFICIENTS. C IN ANY CASE H IS RESET ACCORDING TO RH AND THE Y ARRAY IS RESCALED. C THEN EXIT FROM 690 IF THE STEP WAS OK, OR REDO THE STEP OTHERWISE. C----------------------------------------------------------------------- IF (NEWQ .EQ. NQ) GO TO 170 630 NQ = NEWQ L = NQ + 1 IRET = 2 GO TO 130 C----------------------------------------------------------------------- C CONTROL REACHES THIS SECTION IF 3 OR MORE FAILURES HAVE OCCURED. C IT IS ASSUMED THAT THE DERIVATIVES THAT HAVE ACCUMULATED IN THE C Y ARRAY HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST C DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO 1. THEN C H IS REDUCED BY A FACTOR OF 10, AND THE STEP IS RETRIED. C AFTER A TOTAL OF 7 FAILURES, AN EXIT IS TAKEN WITH KFLAG = -2. C----------------------------------------------------------------------- 640 IF (KFLAG .EQ. -7) GO TO 670 RH = .1 RH = DMAX1(HMIN/ DABS(H),RH) H = H*RH IER = 0 CALL DIFFUN (N, T, Y, SAVE1, IER, PW, IPIV, WORK, IWORK) IF ( IER .NE. 0 ) GO TO 685 NJE = NJE + 1 DO 650 I = 1,N 650 Y(I,2) = H*SAVE1(I) IWEVAL = MITER IDOUB = 10 IF (NQ .EQ. 1) GO TO 200 NQ = 1 L = 2 IRET = 3 GO TO 130 C----------------------------------------------------------------------- C ALL RETURNS ARE MADE THROUGH THIS SECTION. H IS SAVED IN HOLD C TO ALLOW THE CALLER TO CHANGE H ON THE NEXT STEP. C----------------------------------------------------------------------- 660 KFLAG = -1 GO TO 700 670 KFLAG = -2 GO TO 700 680 KFLAG = -3 GO TO 700 685 KFLAG = -4 GO TO 700 690 RMAX = 10. 700 HOLD = H JSTART = NQ RETURN END C C C ############################################################################## C C SUBROUTINE GFUN ( T,C,UDOT,NPDE,NCPTS,A,BC,DBDU,DBDUX,DZDT, * XC,UVAL,ILEFT ) IMPLICIT REAL*8 (A-H, O-Z) C------------------------------------------------------------------------------- C CALLING ARGUMENTS ARE DEFINED BELOW AND IN PDECOL. C C SUBROUTINE GFUN COMPUTES THE FUNCTION UDOT=G(C,T), THE RIGHT- C HAND SIDE OF THE SEMI-DISCRETE APPROXIMATION TO THE ORIGINAL C SYSTEM OF PARTIAL DIFFERENTIAL EQUATIONS AND UPDATES THE BOUNDARY C CONDITION INFORMATION. C C PACKAGE ROUTINES CALLED.. EVAL C USER ROUTINES CALLED.. BNDRY,F C CALLED BY.. DIFFUN,PSETIB,RES C FORTRAN FUNCTIONS USED.. NONE C------------------------------------------------------------------------------- COMMON /SIZES/ NINT,KORD,NCC,NPD,NCPT,NEQN,IQUAD DIMENSION C(NPDE,NCPTS),UDOT(NPDE,NCPTS) DIMENSION A(NCPTS*3*KORD),BC(NPDE,NPDE,4), * XC(NCPTS),UVAL(NPDE,3),ILEFT(NCPTS) DIMENSION DZDT(NPDE),DBDU(NPDE,NPDE),DBDUX(NPDE,NPDE) DO 10 K=1,4 DO 10 J=1,NPDE DO 10 I=1,NPDE BC(I,J,K) = 0.0 10 CONTINUE C----------------------------------------------------------------------- C UPDATE THE LEFT BOUNDARY VALUES. SAVE LEFT BOUNDARY CONDITION C INFORMATION IN THE FIRST 2*NPDE*NPDE LOCATIONS OF BC. C C NOTE.. UVAL(K,1) = U(K), UVAL(K,2) = UX(K), AND UVAL(K,3) = UXX(K). C----------------------------------------------------------------------- CALL EVAL(1,NPDE,C,UVAL,A,ILEFT) CALL BNDRY(T,XC(1),UVAL,UVAL(1,2),DBDU,DBDUX,DZDT,NPDE) CALL F(T,XC(1),UVAL,UVAL(1,2),UVAL(1,3),UDOT,NPDE) ILIM = KORD + 2 DO 30 K=1,NPDE BC(K,K,1) = 1. IF( DBDU(K,K) .EQ. 0.0 .AND. DBDUX(K,K) .EQ. 0.0 ) GO TO 30 UDOT(K,1) = DZDT(K) DO 20 J=1,NPDE BC(K,J,2) = A(ILIM) * DBDUX(K,J) BC(K,J,1) = DBDU(K,J) - BC(K,J,2) 20 CONTINUE 30 CONTINUE C----------------------------------------------------------------------- C MAIN LOOP TO FORM RIGHT SIDE OF ODES AT THE COLLOCATION POINTS. C----------------------------------------------------------------------- ILIM = NCPTS - 1 DO 40 I=2,ILIM CALL EVAL(I,NPDE,C,UVAL,A,ILEFT) CALL F(T,XC(I),UVAL,UVAL(1,2),UVAL(1,3),UDOT(1,I),NPDE) 40 CONTINUE C----------------------------------------------------------------------- C UPDATE THE RIGHT BOUNDARY VALUES. SAVE THE RIGHT BOUNDARY CONDITION C INFORMATION IN THE LAST 2*NPDE*NPDE LOCATIONS IN BC. C----------------------------------------------------------------------- CALL EVAL(NCPTS,NPDE,C,UVAL,A,ILEFT) CALL F(T,XC(NCPTS),UVAL,UVAL(1,2),UVAL(1,3),UDOT(1,NCPTS),NPDE) CALL BNDRY(T,XC(NCPTS),UVAL,UVAL(1,2),DBDU,DBDUX,DZDT,NPDE) ILIM = NCPTS * 3 * KORD - KORD - 1 DO 60 K=1,NPDE BC(K,K,4) = 1. IF( DBDU(K,K) .EQ. 0.0 .AND. DBDUX(K,K) .EQ. 0.0 ) GO TO 60 UDOT(K,NCPTS) = DZDT(K) DO 50 J=1,NPDE BC(K,J,3) = A(ILIM) * DBDUX(K,J) BC(K,J,4) = DBDU(K,J) - BC(K,J,3) 50 CONTINUE 60 CONTINUE RETURN END C C C ############################################################################## C C SUBROUTINE EVAL( ICPT,NPDE,C,UVAL,A,ILEFT ) IMPLICIT REAL*8 (A-H, O-Z) C------------------------------------------------------------------------------- C CALLING ARGUMENTS ARE DEFINED BELOW AND IN PDECOL. C C SUBROUTINE EVAL EVALUATES U(K), UX(K), AND UXX(K), K=1 TO NPDE, C AT THE COLLOCATION POINT WITH INDEX ICPT USING THE VALUES OF C THE BASIS FUNCTION COEFFICIENTS IN C AND THE BASIS FUNCTION VALUES C STORED IN A. THE RESULTS ARE STORED IN UVAL AS FOLLOWS.. C UVAL(K,1) = U(K), UVAL(K,2) = UX(K), AND UVAL(K,3) = UXX(K). C C PACKAGE ROUTINES CALLED.. NONE C USER ROUTINES CALLED.. NONE C CALLED BY.. GFUN,PDECOL,PSETIB C FORTRAN FUNCTIONS USED.. NONE C------------------------------------------------------------------------------- COMMON /SIZES/ NINT,KORD,NCC,NPD,NCPTS,NEQN,IQUAD DIMENSION C(NPDE,NCPTS),UVAL(NPDE,3),A(NCPTS*3*KORD),ILEFT(NCPTS) IK = ILEFT(ICPT) - KORD IC = 3*KORD*(ICPT-1) DO 10 M=1,3 ICC = IC + KORD*(M-1) DO 10 J=1,NPDE UVAL(J,M) = 0. DO 10 I=1,KORD UVAL(J,M) = UVAL(J,M) + C(J,I+IK)*A(I+ICC) 10 CONTINUE RETURN END C C C ############################################################################## C C SUBROUTINE DIFFUN( N, T, Y, YDOT, IER, PW, IPIV, WORK, IWORK ) IMPLICIT REAL*8 (A-H, O-Z) C------------------------------------------------------------------------------- C CALLING ARGUMENTS ARE DEFINED BELOW AND IN PDECOL. C C THIS ROUTINE COMPUTES YDOT = A(Y,T)**-1 * G(Y,T) BY USE OF C THE ROUTINES GFUN, ADDA, DECB, AND SOLB. C C PACKAGE ROUTINES CALLED.. ADDA,DECB,GFUN,SOLB C USER ROUTINES CALLED.. NONE C CALLED BY.. STIFIB C FORTRAN FUNCTIONS USED.. NONE C------------------------------------------------------------------------------- COMMON /GEAR9/ EPSJ,R0,ML,MU,MW,NM1,N0ML,N0W COMMON /SIZES/ NINT,KORD,NCC,NPDE,NCPTS,NEQN,IQUAD COMMON /ISTART/ IW1,IW2,IW3,IDUM(5),IW9,IW10,IW11,IW12,IW13,IW14, * IW15,IW16,IW17,IW18 COMMON /OPTION/ NOGAUS,MAXDER DIMENSION Y(NEQN),YDOT(NEQN),PW(NEQN*(3*ML+1)), * IPIV(NEQN),IWORK((NPDE+1)*NCPTS), * WORK(KORD+NPDE*(4+9*NPDE)+(KORD+(NINT-1)*(KORD-NCC))* * (3*KORD+2+NPDE*(3*(KORD-1)*NPDE+MAXDER+4))) CALL GFUN (T, Y, YDOT, NPDE, NCPTS, WORK(IW1), WORK, WORK(IW14), * WORK(IW15), WORK(IW16), WORK(IW3), WORK(IW9), IWORK) DO 10 I = 1,N0W 10 PW(I) = 0. N0 = NM1 + 1 CALL ADDA (PW, N0, WORK(IW1), IWORK, WORK, NPDE) CALL DECB (N0, N, ML, MU, PW, IPIV, IER) IF ( IER .NE. 0 ) RETURN CALL SOLB (N0, N, ML, MU, PW, YDOT, IPIV) RETURN END C C C ############################################################################## C C SUBROUTINE ADDA( PW,N0,A,ILEFT,BC,NPDE ) IMPLICIT REAL*8 (A-H, O-Z) C------------------------------------------------------------------------------- C CALLING ARGUMENTS ARE DEFINED BELOW AND IN PDECOL AND STIFIB. C C SUBROUTINE ADDA ADDS THE MATRIX A TO THE MATRIX STORED IN PW IN C BAND FORM. PW IS STORED BY DIAGONALS WITH THE LOWERMOST DIAGONAL C STORED IN THE FIRST COLUMN OF THE ARRAY. C C PACKAGE ROUTINES CALLED.. NONE C USER ROUTINES CALLED.. NONE C CALLED BY.. DIFFUN,PSETIB C FORTRAN FUNCTIONS USED.. NONE C------------------------------------------------------------------------------- COMMON /SIZES/ NINT,KORD,NCC,NPD,NCPTS,NEQN,IQUAD COMMON /GEAR9/ EPSJ,R0,ML,MU,MW,NM1,N0ML,N0W DIMENSION PW(NEQN,3*ML+1),A(3*KORD*NCPTS), * ILEFT(NCPTS),BC(NPDE,NPDE,4) C----------------------------------------------------------------------- C ADD THE BOUNDARY CONDITION PORTIONS OF THE A MATRIX TO PW ( THE FIRST C AND LAST BLOCK ROWS). C----------------------------------------------------------------------- ICOL = (ILEFT(1) + IQUAD - 1) * NPDE DO 10 I=1,NPDE IBOT = NEQN - NPDE + I DO 10 J=1,NPDE IND = ICOL + J - I PW(I,IND) = PW(I,IND) + BC(I,J,1) PW(I,IND+NPDE) = PW(I,IND+NPDE) + BC(I,J,2) PW(IBOT,IND-NPDE) = PW(IBOT,IND-NPDE) + BC(I,J,3) PW(IBOT,IND) = PW(IBOT,IND) + BC(I,J,4) 10 CONTINUE C----------------------------------------------------------------------- C UPDATE THE REMAINING ROWS OF PW BY ADDING THE APPROPRIATE VALUES C IN A TO PW. C----------------------------------------------------------------------- IND = NCPTS - 1 DO 20 I=2,IND I1 = (I-1) * NPDE I2 = (I-1) * KORD * 3 ICOL = ILEFT(I) - I + IQUAD - 1 DO 20 J=1,KORD J1 = (ICOL+J) * NPDE J2 = I2 + J DO 20 JJ=1,NPDE 20 PW(I1+JJ,J1) = PW(I1+JJ,J1) + A(J2) RETURN END C C C ############################################################################## C C SUBROUTINE RES( T,H,C,V,R,NPDE,NCPTS,A,ILEFT,BC,DBDU,DBDUX,DZDT, * XC,UVAL ) IMPLICIT REAL*8 (A-H, O-Z) C------------------------------------------------------------------------------- C CALLING ARGUMENTS ARE DEFINED BELOW AND IN PDECOL. C C SUBROUTINE RES COMPUTES THE RESIDUAL VECTOR R = H*G(C,T) - A(C,T)*V C WHERE H IS THE CURRENT TIME STEP SIZE, G IS A VECTOR, A IS A C MATRIX, V IS A VECTOR, AND T IS THE CURRENT TIME. C C PACKAGE ROUTINES CALLED.. GFUN C USER ROUTINES CALLED.. NONE C CALLED BY.. STIFIB C FORTRAN FUNCTIONS USED.. NONE C------------------------------------------------------------------------------- SAVE COMMON /SIZES/ NINT,KORD,NCC,NPD,NCPT,NEQN,IQUAD DIMENSION C(NPDE,NCPTS),R(NPDE,NCPTS),V(NPDE,NCPTS) DIMENSION A(3*KORD*NCPTS),ILEFT(NCPTS),BC(NPDE,NPDE,4),XC(NCPTS), * UVAL(3*NPDE) DIMENSION DBDU(NPDE,NPDE),DBDUX(NPDE,NPDE),DZDT(NPDE) C----------------------------------------------------------------------- C FORM G(C,T) AND STORE IN R. C----------------------------------------------------------------------- CALL GFUN(T,C,R,NPDE,NCPTS,A,BC,DBDU,DBDUX,DZDT,XC,UVAL,ILEFT) C----------------------------------------------------------------------- C FORM THE FIRST AND LAST BLOCK ROWS OF THE RESIDUAL VECTOR C WHICH ARE DEPENDENT ON THE BOUNDARY CONDITIONS. C----------------------------------------------------------------------- ILIM = NCPTS - 1 DO 20 I=1,NPDE SUM1 = 0.0 SUM2 = 0.0 DO 10 J=1,NPDE SUM1 = SUM1 + BC(I,J,1) * V(J,1) + BC(I,J,2) * V(J,2) SUM2 = SUM2 + BC(I,J,3) * V(J,ILIM) + BC(I,J,4) * V(J,NCPTS) 10 CONTINUE R(I,1) = H * R(I,1) - SUM1 R(I,NCPTS) = H * R(I,NCPTS) - SUM2 20 CONTINUE C----------------------------------------------------------------------- C FORM THE REMAINING COMPONENTS OF THE RESIDUAL VECTOR. C----------------------------------------------------------------------- DO 50 ICPTS=2,ILIM I2 = (ICPTS-1) * KORD * 3 ICOL = ILEFT(ICPTS) - KORD DO 40 JJ=1,NPDE SUM1 = 0. DO 30 J=1,KORD SUM1 = SUM1 + A(I2+J) * V(JJ,ICOL+J) 30 CONTINUE R(JJ,ICPTS) = H*R(JJ,ICPTS) - SUM1 40 CONTINUE 50 CONTINUE RETURN END C C C ############################################################################## C C SUBROUTINE PSETIB( C,PW,N0,CON,MITER,IER,A,ILEFT,XC,UVAL, * SAVE2,IPIV,CMAX,DFDU,DFDUX,DFDUXX,DZDT,DBDU,DBDUX,BC,NPDE ) IMPLICIT REAL*8 (A-H, O-Z) C----------------------------------------------------------------------- C CALLING ARGUMENTS ARE DEFINED BELOW AND IN PDECOL AND STIFIB. C C PSETIB IS CALLED BY STIFIB TO COMPUTE AND PROCESS THE MATRIX C PW = A - H*EL(1)*(DG/DC), WHERE A AND DG/DC ARE TREATED IN BAND C FORM. DG/DC IS COMPUTED, EITHER WITH THE AID OF THE USER-SUPPLIED C ROUTINE DERIVF IF MITER = 1, OR BY FINITE DIFFERENCING WITH THE AID C OF THE PACKAGE-SUPPLIED ROUTINE DIFFF IF MITER = 2. FINALLY, C PW IS SUBJECTED TO LU DECOMPOSITION IN PREPARATION FOR LATER C SOLUTION OF LINEAR SYSTEMS WITH PW AS COEFFICIENT MATRIX. C SEE SUBROUTINES DECB AND SOLB. C C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION C WITH PSETIB USES THE FOLLOWING.. C EPSJ = DSQRT(UROUND), USED IN THE NUMERICAL JACOBIAN INCREMENTS. C MW = ML + MU + 1. C NM1 = N0 - 1. C N0ML = N0*ML. C N0W = N0*MW. C C PACKAGE ROUTINES CALLED.. ADDA,DECB,DIFFF,EVAL,GFUN C USER ROUTINES CALLED.. BNDRY,DERIVF C CALLED BY.. STIFIB C FORTRAN FUNCTIONS USED.. ABS,FLOAT,MAX0,MIN0,DSQRT C----------------------------------------------------------------------- COMMON /SIZES/ NINT,KORD,NCC,NPD,NCPTS,NEQN,IQUAD COMMON /GEAR1/ T,H,DUMMY(3),UROUND,N,IDUMMY(3) COMMON /GEAR9/ EPSJ,R0,ML,MU,MW,NM1,N0ML,N0W DIMENSION PW(NEQN,3*ML+1),C(NEQN),CMAX(NEQN) DIMENSION A(3*KORD*NCPTS),ILEFT(NCPTS),BC(4*NPDE*NPDE), * XC(NCPTS),UVAL(NPDE,3),SAVE2(NEQN),IPIV(NEQN) DIMENSION DFDU(NPDE,NPDE),DFDUX(NPDE,NPDE),DFDUXX(NPDE,NPDE) DIMENSION DZDT(NPDE),DBDU(NPDE,NPDE),DBDUX(NPDE,NPDE) DO 10 I=1,NEQN DO 5 J=1,MW 5 PW(I,J)=0.0E0 10 CONTINUE IF ( MITER .EQ. 1 ) GO TO 25 CALL GFUN (T, C, SAVE2, NPDE, NCPTS,A,BC,DBDU,DBDUX,DZDT,XC, * UVAL,ILEFT) D = 0. DO 20 I = 1,N 20 D = D + SAVE2(I)**2 R0 = DABS(H)* DSQRT(D/FLOAT(N0))*1.E+03*UROUND C----------------------------------------------------------------------- C COMPUTE BLOCK ROWS OF JACOBIAN. C----------------------------------------------------------------------- 25 DO 30 I=1,NCPTS I1 = (I-1)*NPDE I2 = (I-1)*KORD*3 CALL EVAL(I,NPDE,C,UVAL,A,ILEFT) IF ( MITER .EQ. 1 ) * CALL DERIVF(T,XC(I),UVAL,UVAL(1,2),UVAL(1,3), * DFDU,DFDUX,DFDUXX,NPDE) IF ( MITER .EQ. 2 ) * CALL DIFFF(T,XC(I),I,UVAL,UVAL(1,2),UVAL(1,3), * DFDU,DFDUX,DFDUXX,NPDE,CMAX,SAVE2) ICOL = ILEFT(I) - I + IQUAD - 1 KLOW = MAX0(1,I+2-NCPTS) KUP = MIN0(KORD,KORD+I-2) DO 30 KBLK=KLOW,KUP J1 = (ICOL+KBLK)*NPDE J2 = I2 + KBLK J3 = J2 + KORD J4 = J3 + KORD DO 30 L=1,NPDE DO 30 K=1,NPDE PW(I1+K,J1-K+L) = DFDU(K,L)*A(J2) + DFDUX(K,L)*A(J3) * + DFDUXX(K,L)*A(J4) 30 CONTINUE C----------------------------------------------------------------------- C MODIFY THE LAST AND THE FIRST BLOCK ROWS FOR THE BOUNDARY CONDITIONS. C CURRENT INFORMATION FOR THE RIGHT BOUNDARY CONDITION IS ALREADY IN C THE ARRAYS DBDU, DBDUX AS A RESULT OF A PREVIOUS CALL TO GFUN. C----------------------------------------------------------------------- IROW = NEQN - NPDE DO 50 K=1,NPDE IROW = IROW + 1 IF(DBDU(K,K) .EQ. 0.0 .AND. DBDUX(K,K) .EQ. 0.0) GO TO 50 DO 40 J=1,MW PW(IROW,J) = 0.0 40 CONTINUE 50 CONTINUE CALL EVAL(1,NPDE,C,UVAL,A,ILEFT) CALL BNDRY(T,XC(1),UVAL,UVAL(1,2),DBDU,DBDUX,DZDT,NPDE) DO 70 K=1,NPDE IF(DBDU(K,K) .EQ. 0.0 .AND. DBDUX(K,K) .EQ. 0.0) GO TO 70 DO 60 J=1,MW PW(K,J) = 0.0 60 CONTINUE 70 CONTINUE DO 80 I = 1,N0 DO 85 J=1,MW 85 PW(I,J)=PW(I,J)*CON 80 CONTINUE C----------------------------------------------------------------------- C ADD MATRIX A(C,T) TO PW. C----------------------------------------------------------------------- CALL ADDA (PW, N0, A, ILEFT, BC, NPDE) C----------------------------------------------------------------------- C DO LU DECOMPOSITION ON PW. C----------------------------------------------------------------------- CALL DECB (N0, N, ML, MU, PW, IPIV, IER) RETURN END C C C ############################################################################## C C SUBROUTINE DIFFF( T,X,IPT,U,UX,UXX,DFDU,DFDUX,DFDUXX,NPDE,CMAX, * SAVE2) IMPLICIT REAL*8 (A-H, O-Z) C----------------------------------------------------------------------- C CALLING ARGUMENTS ARE DEFINED BELOW AND IN PDECOL. C C SUBROUTINE DIFFF IS USED IF MITER=2 TO PROVIDE FINITE DIFFERENCE C APPROXIMATIONS FOR THE PARTIAL DERIVATIVES OF THE K-TH USER DEFINED C FUNCTION IN THE F ROUTINE WITH RESPECT TO THE VARIABLES U, UX, AND C UXX. THESE PARTIALS WITH RESPECT TO U, UX, AND UXX ARE COMPUTED, C STORED, AND RETURNED IN THE NPDE BY NPDE ARRAYS DFDU, DFDUX, AND C DFDUXX, RESPECTIVELY, AT COLLOCATION POINT NUMBER IPT. C C PACKAGE ROUTINES CALLED.. NONE C USER ROUTINES CALLED.. F C CALLED BY.. PSETIB C FORTRAN FUNCTIONS USED.. DMAX1 C----------------------------------------------------------------------- COMMON /GEAR9/ EPSJ,R0,ML,MU,MW,NM1,N0ML,N0W COMMON /SIZES/ NINT,KORD,NCC,NPD,NCPTS,NEQN,IQUAD DIMENSION U(NPDE),UX(NPDE),UXX(NPDE),DFDU(NPDE,NPDE), * DFDUX(NPDE,NPDE),DFDUXX(NPDE,NPDE),CMAX(NEQN),SAVE2(NEQN) ID = (IPT-1) * NPDE DO 40 J=1,NPDE UJ = U(J) R = EPSJ * CMAX(J) R = DMAX1(R,R0) U(J) = U(J) + R RINV = 1. / R CALL F(T,X,U,UX,UXX,DFDU(1,J),NPDE) DO 10 I=1,NPDE 10 DFDU(I,J) = ( DFDU(I,J) - SAVE2(I+ID) ) * RINV U(J) = UJ UJ = UX(J) UX(J) = UX(J) + R CALL F(T,X,U,UX,UXX,DFDUX(1,J),NPDE) DO 20 I=1,NPDE 20 DFDUX(I,J) = ( DFDUX(I,J) - SAVE2(I+ID) ) * RINV UX(J) = UJ UJ = UXX(J) UXX(J) = UXX(J) + R CALL F(T,X,U,UX,UXX,DFDUXX(1,J),NPDE) DO 30 I=1,NPDE 30 DFDUXX(I,J) = ( DFDUXX(I,J) - SAVE2(I+ID) ) * RINV UXX(J) = UJ 40 CONTINUE RETURN END C C C ############################################################################## C C SUBROUTINE INTERP ( TOUT, Y, N0, Y0 ) IMPLICIT REAL*8 (A-H, O-Z) C----------------------------------------------------------------------- C CALLING ARGUMENTS ARE DEFINED BELOW AND IN STIFIB C C SUBROUTINE INTERP COMPUTES INTERPOLATED VALUES OF THE DEPENDENT C VARIABLE Y AND STORES THEM IN Y0. THE INTERPOLATION IS TO THE C POINT T = TOUT, AND USES THE NORDSIECK HISTORY ARRAY Y, AS FOLLOWS.. C NQ C Y0(I) = SUM Y(I,J+1)*S**J , C J=0 C WHERE S = -(T-TOUT)/H. C C PACKAGE ROUTINES CALLED.. NONE C USER ROUTINES CALLED.. NONE C CALLED BY.. PDECOL C FORTRAN FUNCTIONS USED.. NONE C----------------------------------------------------------------------- COMMON /SIZES/ NINT,KORD,NCC,NPD,NCPTS,NEQN,IQUAD COMMON /OPTION/ NOGAUS,MAXDER COMMON /GEAR1/ T,H,DUMMY(4),N,IDUMMY(2),JSTART DIMENSION Y0(NEQN),Y(NEQN,MAXDER+1) DO 10 I = 1,N 10 Y0(I) = Y(I,1) L = JSTART + 1 S = (TOUT - T)/H S1 = 1. DO 30 J = 2,L S1 = S1*S DO 20 I = 1,N 20 Y0(I) = Y0(I) + S1*Y(I,J) 30 CONTINUE RETURN END C C C ############################################################################## C C SUBROUTINE COSET ( METH, NQ, EL, TQ ) IMPLICIT REAL*8 (A-H, O-Z) C----------------------------------------------------------------------- C COSET IS CALLED BY THE INTEGRATOR AND SETS COEFFICIENTS USED THERE. C THE VECTOR EL, OF LENGTH NQ + 1, DETERMINES THE BASIC METHOD. C THE VECTOR TQ, OF LENGTH 4, IS INVOLVED IN ADJUSTING THE STEP SIZE C IN RELATION TO TRUNCATION ERROR. ITS VALUES ARE GIVEN BY THE C PERTST ARRAY. C C THE VECTORS EL AND TQ DEPEND ON METH AND NQ. C THE MAXIMUM ORDER, MAXDER, OF THE METHODS AVAILABLE IS CURRENTLY C 12 FOR THE ADAMS METHODS AND 5 FOR THE BDF METHODS. MAXDER DEFAULTS C TO 5 UNLESS THE USER SETS MAXDER TO SOME OTHER LEGITIMATE VALUE C THROUGH THE COMMON BLOCK /OPTION/. SEE PDECOL FOR ADDITIONAL DETAILS. C LMAX = MAXDER + 1 IS THE NUMBER OF COLUMNS IN THE Y ARRAY (SEE STIFIB C AND THE VARIABLE C, Y, OR WORK(IW10) IN PDECOL. C C THE COEFFICIENTS IN PERTST NEED BE GIVEN TO ONLY ABOUT C ONE PERCENT ACCURACY. THE ORDER IN WHICH THE GROUPS APPEAR BELOW C IS.. COEFFICIENTS FOR ORDER NQ - 1, COEFFICIENTS FOR ORDER NQ, C COEFFICIENTS FOR ORDER NQ + 1. WITHIN EACH GROUP ARE THE C COEFFICIENTS FOR THE ADAMS METHODS, FOLLOWED BY THOSE FOR THE C BDF METHODS. C C REFERENCE C C GEAR, C.W., NUMERICAL INITIAL VALUE PROBLEMS IN ORDINARY C DIFFERENTIAL EQUATIONS, PRENTICE-HALL, ENGLEWOOD CLIFFS, C N. J., 1971. C C PACKAGE ROUTINES CALLED.. NONE C USER ROUTINES CALLED.. NONE C CALLED BY.. STIFIB C FORTRAN FUNCTIONS USED.. FLOAT C----------------------------------------------------------------------- DIMENSION PERTST(12,2,3),EL(13),TQ(4) DATA PERTST / 1.,1.,2.,1.,.3158,.07407,.01391,.002182, * .0002945,.00003492,.000003692,.0000003524, * 1.,1.,.5,.1667,.04167,1.,1.,1.,1.,1.,1.,1., * 2.,12.,24.,37.89,53.33,70.08,87.97,106.9, * 126.7,147.4,168.8,191.0, * 2.0,4.5,7.333,10.42,13.7,1.,1.,1.,1.,1.,1.,1., * 12.0,24.0,37.89,53.33,70.08,87.97,106.9, * 126.7,147.4,168.8,191.0,1., * 3.0,6.0,9.167,12.5,1.,1.,1.,1.,1.,1.,1.,1. / C GO TO (1,2),METH 1 GO TO (101,102,103,104,105,106,107,108,109,110,111,112),NQ 2 GO TO (201,202,203,204,205),NQ C----------------------------------------------------------------------- C THE FOLLOWING COEFFICIENTS SHOULD BE DEFINED TO MACHINE ACCURACY. C FOR A GIVEN ORDER NQ, THEY CAN BE CALCULATED BY USE OF THE C GENERATING POLYNOMIAL L(T), WHOSE COEFFICIENTS ARE EL(I).. C L(T) = EL(1) + EL(2)*T + ... + EL(NQ+1)*T**NQ. C FOR THE IMPLICIT ADAMS METHODS, L(T) IS GIVEN BY C DL/DT = (T+1)*(T+2)* ... *(T+NQ-1)/K, L(-1) = 0, C WHERE K = FACTORIAL(NQ-1). C FOR THE BDF METHODS, C L(T) = (T+1)*(T+2)* ... *(T+NQ)/K, C WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). C C THE ORDER IN WHICH THE GROUPS APPEAR BELOW IS.. C IMPLICIT ADAMS METHODS OF ORDERS 1 TO 12, C BDF METHODS OF ORDERS 1 TO 5. C----------------------------------------------------------------------- 101 EL(1) = 1.0D-00 GO TO 900 102 EL(1) = 0.5D-00 EL(3) = 0.5D-00 GO TO 900 103 EL(1) = 4.1666666666667D-01 EL(3) = 0.75D-00 EL(4) = 1.6666666666667D-01 GO TO 900 104 EL(1) = 0.375D-00 EL(3) = 9.1666666666667D-01 EL(4) = 3.3333333333333D-01 EL(5) = 4.1666666666667D-02 GO TO 900 105 EL(1) = 3.4861111111111D-01 EL(3) = 1.0416666666667D-00 EL(4) = 4.8611111111111D-01 EL(5) = 1.0416666666667D-01 EL(6) = 8.3333333333333D-03 GO TO 900 106 EL(1) = 3.2986111111111D-01 EL(3) = 1.1416666666667D-00 EL(4) = 0.625D-00 EL(5) = 1.7708333333333D-01 EL(6) = 0.025D-00 EL(7) = 1.3888888888889D-03 GO TO 900 107 EL(1) = 3.1559193121693D-01 EL(3) = 1.225D-00 EL(4) = 7.5185185185185D-01 EL(5) = 2.5520833333333D-01 EL(6) = 4.8611111111111D-02 EL(7) = 4.8611111111111D-03 EL(8) = 1.9841269841270D-04 GO TO 900 108 EL(1) = 3.0422453703704D-01 EL(3) = 1.2964285714286D-00 EL(4) = 8.6851851851852D-01 EL(5) = 3.3576388888889D-01 EL(6) = 7.7777777777778D-02 EL(7) = 1.0648148148148D-02 EL(8) = 7.9365079365079D-04 EL(9) = 2.4801587301587D-05 GO TO 900 109 EL(1) = 2.9486800044092D-01 EL(3) = 1.3589285714286D-00 EL(4) = 9.7655423280423D-01 EL(5) = 0.4171875D-00 EL(6) = 1.1135416666667D-01 EL(7) = 0.01875D-00 EL(8) = 1.9345238095238D-03 EL(9) = 1.1160714285714D-04 EL(10)= 2.7557319223986D-06 GO TO 900 110 EL(1) = 2.8697544642857D-01 EL(3) = 1.4144841269841D-00 EL(4) = 1.0772156084656D-00 EL(5) = 4.9856701940035D-01 EL(6) = 0.1484375D-00 EL(7) = 2.9060570987654D-02 EL(8) = 3.7202380952381D-03 EL(9) = 2.9968584656085D-04 EL(10)= 1.3778659611993D-05 EL(11)= 2.7557319223986D-07 GO TO 900 111 EL(1) = 2.8018959644394D-01 EL(3) = 1.4644841269841D-00 EL(4) = 1.1715145502646D-00 EL(5) = 5.7935819003527D-01 EL(6) = 1.8832286155203D-01 EL(7) = 4.1430362654321D-02 EL(8) = 6.2111441798942D-03 EL(9) = 6.2520667989418D-04 EL(10)= 4.0417401528513D-05 EL(11)= 1.5156525573192D-06 EL(12)= 2.5052108385442D-08 GO TO 900 112 EL(1) = 2.7426554003160D-01 EL(3) = 1.5099386724387D-00 EL(4) = 1.2602711640212D-00 EL(5) = 6.5923418209877D-01 EL(6) = 2.3045800264550D-01 EL(7) = 5.5697246105232D-02 EL(8) = 9.4394841269841D-03 EL(9) = 1.1192749669312D-03 EL(10)= 9.0939153439153D-05 EL(11)= 4.8225308641975D-06 EL(12)= 1.5031265031265D-07 EL(13)= 2.0876756987868D-09 GO TO 900 201 EL(1) = 1.0D-00 GO TO 900 202 EL(1) = 6.6666666666667D-01 EL(3) = 3.3333333333333D-01 GO TO 900 203 EL(1) = 5.4545454545455D-01 EL(3) = EL(1) EL(4) = 9.0909090909091D-02 GO TO 900 204 EL(1) = 0.48D-00 EL(3) = 0.7D-00 EL(4) = 0.2D-00 EL(5) = 0.02D-00 GO TO 900 205 EL(1) = 4.3795620437956D-01 EL(3) = 8.2116788321168D-01 EL(4) = 3.1021897810219D-01 EL(5) = 5.4744525547445D-02 EL(6) = 3.6496350364964D-03 C 900 DO 910 K = 1,3 910 TQ(K) = PERTST(NQ,METH,K) TQ(4) = .5D-00*TQ(2)/ FLOAT(NQ+2) RETURN END C C C ############################################################################## C C SUBROUTINE DECB ( NDIM, N, ML, MU, B, IPIV, IER ) IMPLICIT REAL*8 (A-H, O-Z) C----------------------------------------------------------------------- C SUBROUTINES DECB AND SOLB FORM A TWO SUBROUTINE PACKAGE FOR THE C DIRECT SOLUTION OF A SYSTEM OF LINEAR EQUATIONS IN WHICH THE C COEFFICIENT MATRIX IS REAL AND BANDED. C C LU DECOMPOSITION OF BAND MATRIX A.. L*U = P*A , WHERE P IS A C PERMUTATION MATRIX, L IS A UNIT LOWER TRIANGULAR MATRIX, C AND U IS AN UPPER TRIANGULAR MATRIX. C N = ORDER OF MATRIX. C B = N BY (2*ML+MU+1) ARRAY CONTAINING THE MATRIX A ON INPUT C AND ITS FACTORED FORM ON OUTPUT. C ON INPUT, B(I,K) (1.LE.I.LE.N) CONTAINS THE K-TH C DIAGONAL OF A, OR A(I,J) IS STORED IN B(I,J-I+ML+1). C ON OUTPUT, B CONTAINS THE L AND U FACTORS, WITH C U IN COLUMNS 1 TO ML+MU+1, AND L IN COLUMNS C ML+MU+2 TO 2*ML+MU+1. C ML,MU = WIDTHS OF THE LOWER AND UPPER PARTS OF THE BAND, NOT C COUNTING THE MAIN DIAGONAL. TOTAL BANDWIDTH IS ML+MU+1. C NDIM = THE FIRST DIMENSION (COLUMN LENGTH) OF THE ARRAY B. C NDIM MUST BE .GE. N. C IPIV = ARRAY OF LENGTH N CONTAINING PIVOT INFORMATION. C IER = ERROR INDICATOR.. C = 0 IF NO ERROR, C = K IF THE K-TH PIVOT CHOSEN WAS ZERO (A IS SINGULAR). C THE INPUT ARGUMENTS ARE NDIM, N, ML, MU, B. C THE OUTPUT ARGUMENTS ARE B, IPIV, IER. C C PACKAGE ROUTINES CALLED.. NONE C USER ROUTINES CALLED.. NONE C CALLED BY.. DIFFUN,INITAL,PSETIB C FORTRAN FUNCTIONS USED.. ABS,MIN0 C----------------------------------------------------------------------- DIMENSION B(NDIM,2*ML+MU+1),IPIV(N) IER = 0 IF (N .EQ. 1) GO TO 92 LL = ML + MU + 1 N1 = N - 1 IF (ML .EQ. 0) GO TO 32 DO 30 I = 1,ML II = MU + I K = ML + 1 - I DO 10 J = 1,II 10 B(I,J) = B(I,J+K) K = II + 1 DO 20 J = K,LL 20 B(I,J) = 0. 30 CONTINUE 32 LR = ML DO 90 NR = 1,N1 NP = NR + 1 IF (LR .NE. N) LR = LR + 1 MX = NR XM = DABS(B(NR,1)) IF (ML .EQ. 0) GO TO 42 DO 40 I = NP,LR IF ( DABS(B(I,1)) .LE. XM) GO TO 40 MX = I XM = DABS(B(I,1)) 40 CONTINUE 42 IPIV(NR) = MX IF (MX .EQ. NR) GO TO 60 DO 50 I = 1,LL XX = B(NR,I) B(NR,I) = B(MX,I) 50 B(MX,I) = XX 60 XM = B(NR,1) IF (XM .EQ. 0.) GO TO 100 B(NR,1) = 1./XM IF (ML .EQ. 0) GO TO 90 XM = -B(NR,1) KK = MIN0(N-NR,LL-1) DO 80 I = NP,LR J = LL + I - NR XX = B(I,1)*XM B(NR,J) = XX DO 70 II = 1,KK 70 B(I,II) = B(I,II+1) + XX*B(NR,II+1) 80 B(I,LL) = 0. 90 CONTINUE 92 NR = N IF (B(N,1) .EQ. 0.) GO TO 100 B(N,1) = 1./B(N,1) RETURN 100 IER = NR RETURN END C C C ############################################################################## C C SUBROUTINE SOLB ( NDIM, N, ML, MU, B, Y, IPIV ) IMPLICIT REAL*8 (A-H, O-Z) C----------------------------------------------------------------------- C SUBROUTINES DECB AND SOLB FORM A TWO SUBROUTINE PACKAGE FOR THE C DIRECT SOLUTION OF A SYSTEM OF LINEAR EQUATIONS IN WHICH THE C COEFFICIENT MATRIX IS REAL AND BANDED. C C SOLUTION OF A*X = C GIVEN LU DECOMPOSITION OF A FROM DECB. C Y = RIGHT-HAND VECTOR C, OF LENGTH N, ON INPUT, C = SOLUTION VECTOR X ON OUTPUT. C ALL THE ARGUMENTS ARE INPUT ARGUMENTS. C THE OUTPUT ARGUMENT IS Y. C C PACKAGE ROUTINES CALLED.. NONE C USER ROUTINES CALLED.. NONE C CALLED BY.. DIFFUN,INITAL,STIFIB C FORTRAN FUNCTIONS USED.. MIN0 C----------------------------------------------------------------------- DIMENSION B(NDIM,2*ML+MU+1),Y(N),IPIV(N) IF (N .EQ. 1) GO TO 60 N1 = N - 1 LL = ML + MU + 1 IF (ML .EQ. 0) GO TO 32 DO 30 NR = 1,N1 IF (IPIV(NR) .EQ. NR) GO TO 10 J = IPIV(NR) XX = Y(NR) Y(NR) = Y(J) Y(J) = XX 10 KK = MIN0(N-NR,ML) DO 20 I = 1,KK 20 Y(NR+I) = Y(NR+I) + Y(NR)*B(NR,LL+I) 30 CONTINUE 32 LL = LL - 1 Y(N) = Y(N)*B(N,1) KK = 0 DO 50 NB = 1,N1 NR = N - NB IF (KK .NE. LL) KK = KK + 1 DP = 0. IF (LL .EQ. 0) GO TO 50 DO 40 I = 1,KK 40 DP = DP + B(NR,I+1)*Y(NR+I) 50 Y(NR) = (Y(NR) - DP)*B(NR,1) RETURN 60 Y(1) = Y(1)*B(1,1) RETURN END C ------------------------------------------------------------------------------ fAsianOptions/man/0000755000176200001440000000000012161636326013610 5ustar liggesusersfAsianOptions/man/HypergeometricFunctions.Rd0000644000176200001440000001066311370220760020754 0ustar liggesusers\name{HypergeometricFunctions} \alias{HypergeometricFunctions} \alias{kummerM} \alias{kummerU} \alias{whittakerM} \alias{whittakerW} \alias{hermiteH} \title{Confluent Hypergeometric Functions} \description{ A collection and description of special mathematical functions which compute the confluent hypergeometric and related functions. For example, these functions are required to valuate Asian Options based on the theory of exponential Brownian motion. \cr The functions are: \tabular{ll}{ \code{kummerM} \tab the Confluent Hypergeometric Function of the 1st Kind, \cr \code{kummerU} \tab the Confluent Hypergeometric Function of the 2nd Kind, \cr \code{whittakerM} \tab the Whittaker M Function, \cr \code{whittakerW} \tab the Whittaker W Function, \cr \code{hermiteH} \tab the Hermite Polynomials. } } \usage{ kummerM(x, a, b, lnchf = 0, ip = 0) kummerU(x, a, b, ip = 0) whittakerM(x, kappa, mu, ip = 0) whittakerW(x, kappa, mu, ip = 0) hermiteH(x, n, ip = 0) } \arguments{ \item{x}{ [kummer*] - \cr a complex numeric value or vector. } \item{a, b}{ [kummer*] - \cr complex numeric indexes of the Kummer functions. } \item{ip}{ an integer value that specifies how many array positions are desired, usually 10 is sufficient. Setting \code{ip=0} causes the function to estimate the number of array positions. } \item{kappa, mu}{ complex numeric indexes of the Whittaker functions. } \item{lnchf}{ an integer value which selects how the result should be represented. A \code{0} will return the value in standard exponential form, a \code{1} will return the LOG of the result. } \item{n}{ [hermiteH] - \cr the index of the Hermite polynomial, a positive integer value. } } \details{ The functions use the TOMS707 Algorithm by M. Nardin, W.F. Perger and A. Bhalla (1989). A numerical evaluator for the confluent hypergeometric function for complex arguments with large magnitudes using a direct summation of the Kummer series. The method used allows an accuracy of up to thirteen decimal places through the use of large real arrays and a single final division. The confluent hypergeometric function is the solution to the differential equation: zf"(z) + (a-z)f'(z) - bf(z) = 0 The Whittaker functions and the Hermite Polynomials are dervived from Kummer's functions. } \value{ The functions return the values of the selected special mathematical function. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \references{ Abramowitz M., Stegun I.A. (1972); \emph{Handbook of Mathematical Functions with Formulas, Graphs, and Mathematical Tables}, 9th printing, New York, Dover Publishing. Weisstein E.W. (2004); \emph{MathWorld -- A Wolfram Web Resource}, http://mathworld.wolfram.com } \examples{ ## kummerM - # Abramowitz-Stegun: Formula 13.6.3/13.6.21 x = c(0.001, 0.01, 0.1, 1, 10, 100, 1000) nu = 1; a = nu+1/2; b = 2*nu+1 M = Re ( kummerM(x = 2*x, a = a, b = b) ) Bessel = gamma(1+nu) * exp(x)*(x/2)^(-nu) * BesselI(x, nu) cbind(x, M, Bessel) ## kummerM - # Abramowitz-Stegun: Formula 13.6.14 x = c(0.001, 0.01, 0.1, 1, 10, 100, 1000) M = Re ( kummerM(2*x, a = 1, b = 2) ) Sinh = exp(x)*sinh(x)/(x) cbind(x, M, Sinh) # Now the same for complex x: y = rep(1, length = length(x)) x = complex(real = x, imag = y) M = kummerM(2*x, a = 1, b = 2) Sinh = exp(x)*sinh(x)/(x) cbind(x, M, Sinh) ## kummerU - # Abramowitz-Stegun: Formula 13.1.3 x = c(0.001, 0.01, 0.1, 1, 10, 100, 1000) a = 1/3; b = 2/3 U = Re ( kummerU(x, a = a, b = b) ) cbind(x, U) ## whittakerM - # Abramowitz-Stegun: Example 13 AS = c(1.10622, 0.57469) W = c( whittakerM(x = 1, kappa = 0, mu = -0.4), whittakerW(x = 1, kappa = 0, mu = -0.4) ) data.frame(AS, W) ## kummerM # Abramowitz-Stegun: Example 17 x = seq(0, 16, length = 200) plot(x = x, y = kummerM(x, -4.5, 1), type = "l", ylim = c(-25,125), main = "Figure 13.2: M(-4.5, 1, x)") lines(x = c(0, 16), y = c(0, 0), col = 2) } \keyword{math} fAsianOptions/man/GammaFunctions.Rd0000644000176200001440000001077411370220760017013 0ustar liggesusers\name{GammaFunctions} \alias{GammaFunctions} \alias{erf} \alias{Psi} \alias{igamma} \alias{cgamma} \alias{Pochhammer} \title{Gamma and Related Functions} \description{ A collection and description of special mathematical functions. The functions include the error function, the Psi function, the incomplete Gamma function, the Gamma function for complex argument, and the Pochhammer symbol. The Gamma function the logarithm of the Gamma function, their first four derivatives, and the Beta function and the logarithm of the Beta function are part of R's base package. For example, these functions are required to valuate Asian Options based on the theory of exponential Brownian motion. \cr The functions are: \tabular{ll}{ \code{erf} \tab the Error function, \cr \code{gamma*} \tab the Gamma function, \cr \code{lgamma*} \tab the logarithm of the Gamma function, \cr \code{digamma*} \tab the first derivative of the Log Gamma function, \cr \code{trigamma*} \tab the second derivative of the Log Gamma function, \cr \code{tetragamma*} \tab the third derivative of the Log Gamma function, \cr \code{pentagamma*} \tab the fourth derivative of the Log Gammafunction, \cr \code{beta*} \tab the Beta function, \cr \code{lbeta*} \tab the logarithm of the Beta function, \cr \code{Psi} \tab Psi(x) the Psi or Digamma function, \cr \code{igamma} \tab P(a,x) the incomplete Gamma function, \cr \code{cgamma} \tab Gamma function for complex argument, \cr \code{Pochhammer} \tab the Pochhammer symbol. } The functions marked by an asterisk are part of R's base package. } \usage{ erf(x) Psi(x) igamma(x, a) cgamma(x, log = FALSE) Pochhammer(x, n) } \arguments{ \item{x}{ [erf] - \cr a real numeric value or vector. \cr [Psi][*gamma][Pochhammer] - \cr a complex numeric value or vector. } \item{a}{ a complex numeric value or vector. } \item{n}{ an integer value \code{n >= 0}. A notation used in the theory of special functions for the rising factorial, also known as the rising factorial power, Graham et al. 1994. } \item{log}{ a logical, if \code{TRUE} the logarithm of the complex Gamma function is calculated otherwise if \code{FALSE}, the complex Gamma function itself will be calculated. } } \value{ The functions return the values of the selected special mathematical function. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \references{ Abramowitz M., Stegun I.A. (1972); \emph{Handbook of Mathematical Functions with Formulas, Graphs, and Mathematical Tables}, 9th printing, New York, Dover Publishing. Artin, E. (1964); \emph{The Gamma Function}, New York, Holt, Rinehart, and Winston Publishing. Weisstein E.W. (2004); \emph{MathWorld--A Wolfram Web Resource}, http://mathworld.wolfram.com } \examples{ ## Calculate Error, Gamma and Related Functions ## gamma - # Abramowitz-Stegun: Figure 6.1 x = seq(-4.01, 4.01, by = 0.011) plot(x, gamma(x), ylim = c(-5,5), type = "l", main = "Gamma Function") lines(x = c(-4, 4), y = c(0, 0)) ## Psi - # Abramowitz-Stegun: Figure 6.1 x = seq(-4.01, 4.01, by = 0.011) plot(x, Psi(x), ylim = c(-5, 5), type = "l", main = "Psi Function") lines(x = c(-4, 4), y = c(0, 0)) # Note: Is digamma defined for positive values only ? ## igamma - # Abramowitz-Stegun: Figure 6.3. gammaStar = function(x, a) { igamma(x,a)/x^a } # ... create Figure as an exercise. ## igamma - # Abramowitz-Stegun: Formula 6.5.12 # Relation to Confluent Hypergeometric Functions a = sqrt(2) x = pi Re ( (x^a/a) * kummerM(-x, a, 1+a) ) Re ( (x^a*exp(-x)/a) * kummerM(x, 1, 1+a) ) pgamma(x,a) * gamma(a) igamma(x, a) ## cgamma - # Abramowitz-Stegun: Tables 6.7 x = 1 y = seq(0, 5, by = 0.1); x = rep(x, length = length(y)) z = complex(real = x, imag = y) c = cgamma(z, log = TRUE) cbind(y, Re(c), Im(c)) ## cgamma - # Abramowitz-Stegun: Examples 4-8: options(digits = 10) gamma(6.38); lgamma(56.38) # 1/2 Psi(6.38); Psi(56.38) # 3/4 cgamma(complex(real = 1, imag = -1), log = TRUE ) # 5 cgamma(complex(real = 1/2, imag = 1/2), log = TRUE ) # 6 cgamma(complex(real = 3, imag = 7), log = TRUE ) # 7/8 } \keyword{math} fAsianOptions/man/EBMDistribution.Rd0000644000176200001440000001273211370220760017077 0ustar liggesusers\name{EBMDistribution} \alias{EBMDistribution} \alias{dlognorm} \alias{plognorm} \alias{dgam} \alias{pgam} \alias{drgam} \alias{prgam} \alias{djohnson} \alias{pjohnson} \alias{mnorm} \alias{mlognorm} \alias{mrgam} \alias{mjohnson} \alias{masian} \alias{derivative} \alias{dEBM} \alias{pEBM} \alias{d2EBM} \alias{dasymEBM} \title{Exponential Brownian Motion Distributions} \description{ A collection and description of distributions and related functions which are useful in the theory of exponential Brownian motion and Asian option valuation. The functions compute densities and probabilities for the log-Normal distribution, the Gamma distribution, the Reciprocal-Gamma distribution, and the Johnson Type-I distribution. Functions are made available for the compution of moments including the Normal, the log-Normal, the Reciprocal-Gamma, and the Asian-Option Density. In addition a function is given to compute numerically first and second derivatives of a given function. \cr The functions are: \tabular{ll}{ \code{dlognorm} \tab the log-Normal density and derivatives, \cr \code{plognorm} \tab the log-Normal, a synonyme for R's plnorm, \cr \code{dgam} \tab the Gamma density, a synonyme for R's dgamma, \cr \code{pgam} \tab the Gamma probability, a synonyme for R's pgamma, \cr \code{drgam} \tab the Reciprocal-Gamma density, \cr \code{prgam} \tab the Reciprocal-Gamma probability, \cr \code{djohnson} \tab the Johnson Type I density, \cr \code{pjohnson} \tab the Johnson Type I probability, \cr \code{mnorm} \tab the Moments of Normal density, \cr \code{mlognorm} \tab the Moments of log-Normal density, \cr \code{mrgam} \tab the Moments of reciprocal-Gamma density, \cr \code{masian} \tab the Moments of Asian Option density, \cr \code{derivative} \tab the First and second numerical derivative. } } \usage{ dlognorm(x, meanlog = 0, sdlog = 1, deriv = c(0, 1, 2)) plognorm(q, meanlog = 0, sdlog = 1) dgam(x, alpha, beta) pgam(q, alpha, beta, lower.tail = TRUE) drgam(x, alpha, beta, deriv = c(0, 1, 2)) prgam(q, alpha, beta, lower.tail = TRUE) djohnson(x, a = 0, b = 1, c = 0, d = 1, deriv = c(0, 1, 2)) pjohnson(q, a = 0, b = 1, c = 0, d = 1) mnorm(mean = 0, sd = 1) mlognorm(meanlog = 0, sdlog = 1) mrgam(alpha = 1/2, beta = 1) mjohnson(a, b, c, d) masian(Time = 1, r = 0.045, sigma = 0.30) derivative(x, y, deriv = c(1, 2)) dEBM(u, t = 1) pEBM(u, t = 1) d2EBM(u, t = 1) dasymEBM(u, t = 1) } \arguments{ \item{a, b, c, d}{ [*johnson] - \cr the parameters of the Johnson Type I distribution. The default values are \code{a=1}, \code{b=1}, \code{c=0}, and \code{d=1}. } \item{alpha, beta}{ [*gam] - \cr the parameters of the Gamma distribution. } \item{deriv}{ an integer value, the degree of differentiation, either 0, 1 or 2. } \item{lower.tail}{ a logical, if \code{TRUE}, the default, then the probabilities are \code{P[X <= x]}, otherwise, \code{P[X > x]}. } \item{mean, sd}{ [*lognorm] - \cr the parameters of the Normal distribution, the mean and the standard deviation respectively. The default values are \code{mean=0} and \code{sd=1}. } \item{meanlog, sdlog}{ [*lognorm] - \cr the parameters of the Log Normal distribution, the mean and the standard deviation respectively. The default values are \code{mean=0} and \code{sd=1}. } \item{q}{ a real numeric value or vector. } \item{t}{ ... } \item{Time, r, sigma}{ the parameters of the Asian Option distribution. } \item{u}{ ... } \item{x}{ a real numeric value or vector. } \item{y}{ [derivative] - \cr a real numeric value or vector, the function values from which to compute the first and second derivative. } } \value{ The functions \code{d*} and \code{p*} return the values or numeric vectors of the density and probability of the the corresponding distribution. The functions \code{m*} return a list with three elements, the values of the first four moments \code{rawMoments}, the values of the first four central moments \code{centralMoments}, and the skewness and kurtosis \code{fisher}, also called Fisher parameters. The function \code{derivative} returns a list of two elemtes, \code{$x} and \code{$y}, where \code{$y($x)} is either the first or second derivative of \code{y(x)} as selected by the argument \code{deriv}. } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## dlognorm - # Calculate Log-Normal Density and its Derivaties: x = exp(seq(-2.8, 1.2, length = 100)) y0 = dlognorm(x, deriv = 0) y1 = dlognorm(x, deriv = 1) y2 = dlognorm(x, deriv = 2) ## derivative - # Compare with Numerical Differentiation: par(mfrow = c(2, 2)) xa = exp(seq(-2.5, 1.5, length = 20)) plot(x, y0, type = "l", main = "Log-Normal Density") plot(x, y1, type = "l", main = "1st Derivative") z = derivative(xa, dlognorm(xa, deriv = 0), deriv = 1) points(z$x, z$y, col = "steelblue") plot(x, y2, type = "l", main = "2nd Derivative") z = derivative(xa, dlognorm(xa, deriv = 0), deriv = 2) points(z$x, z$y, col = "steelblue") } \keyword{math} fAsianOptions/man/EBMAsianOptions.Rd0000644000176200001440000002214311370220760017024 0ustar liggesusers\name{EBMAsianOptions} \alias{EBMAsianOptions} \alias{MomentMatchedAsianOption} \alias{MomentMatchedAsianDensity} \alias{GramCharlierAsianOption} \alias{AsianOptionMoments} \alias{DufresneAsianOptionMoments} \alias{AbrahamsonAsianOptionMoments} \alias{TurnbullWakemanAsianOptionMoments} \alias{TolmatzAsianOptionMoments} %\alias{Schroeder1AsianDensity} %\alias{Schroeder2AsianDensity} %\alias{Yor1AsianDensity} %\alias{Yor2AsianDensity} %\alias{TolmatzAsianDensity} %\alias{TolmatzAsianProbability} \alias{ZhangAsianOption} \alias{VecerAsianOption} \alias{ZhangApproximateAsianOption} \alias{gGemanYor} \alias{GemanYorAsianOption} \alias{gLinetzky} \alias{LinetzkyAsianOption} \alias{BoundsOnAsianOption} \alias{CurranThompsonAsianOption} \alias{RogerShiThompsonAsianOption} \alias{ThompsonAsianOption} \alias{TolmatzAsianOption} \alias{CallPutParityAsianOption} \alias{WithDividendsAsianOption} \alias{FuMadanWangTable} \alias{FusaiTaglianiTable} \alias{GemanTable} \alias{LinetzkyTable} \alias{ZhangTable} \alias{ZhangLongTable} \alias{ZhangShortTable} \title{Exponential Brownian Motion Distributions} \description{ A collection and description of functions used in the theory of exponential Brownian Motion and in the valuation of Asian options. \cr The functions for Moment matching and Series Expansions are: \tabular{ll}{ \code{MomentMatchedAsianOption} \tab Valuate moment matched option prices, \cr \code{... method="LN"} \tab Log-Normal Approximation of Levy, Turnbull and Wakeman, \cr \code{... method="RG"} \tab Reciprocal-Gamma Approximation of Milevski and Posner, \cr \code{... method="JI"} \tab Johnson Type I Approximation of Posner and Milevsky, \cr \code{MomentMatchedAsianDensity} \tab Valuate moment matched option densities, \cr \code{... method="LN"} \tab Log-Normal Approximation, \cr \code{... method="RG"} \tab Reciprocal-Gamma Approximation, \cr \code{... method="JI"} \tab Johnson Type I Approximation, \cr \code{GramCharlierAsianOption} \tab Calculate Gram-Charlier option prices. } \tabular{ll}{ \code{AsianOptionMoments} \tab Methods to calculate Asian Moments, \cr \code{... method="A"} \tab Moments from Abrahamson's Formula, \cr \code{... method="D"} \tab Moments from Dufresne's Formula, \cr \code{... method="TW"} \tab First 2 Moments from Turnbull-Wakeman, \cr \code{... method="T"} \tab Asymptotic Behavior after Tolmatz. } %\tabular{ll}{ %\code{Schroeder1AsianDensity} \tab %\code{Schroeder2AsianDensity} \tab %\code{Yor1AsianDensity} \tab %\code{Yor2AsianDensity} \tab %\code{TolmatzAsianDensity} \tab %\code{TolmatzAsianProbability} \tab \tabular{ll}{ \code{ZhangAsianOption} \tab Asian option price by Zhang's 1D PDE, \cr \code{VecerAsianOption} \tab Asian option price by Vecer's 1D PDE. } \tabular{ll}{ \code{gGemanYor} \tab Function to be Laplace inverted, \cr \code{GemanYorAsianOption} \tab Asian option price by Laplace Inversion, \cr \code{gLinetzky} \tab Function to be integrated, \cr \code{LinetzkyAsianOption} \tab Asian option price by Spectral Expansion. } \tabular{ll}{ \code{BoundsOnAsianOption} \tab Lower and upper bonds on Asian calls, \cr \code{CurranThompsonAsianOption} \tab From Thompson's continuous limit, \cr \code{RogerShiThompsonAsianOption} \tab From Thompson's single integral formula, \cr \code{ThompsonAsianOption} \tab Thompson's upper bound, \cr \code{TolmatzAsianOption} \tab Lower Bound from Tolmatz' symptotics. } \tabular{ll}{ \code{CallPutParityAsianOption} \tab Call-Put parity Relation, \cr \code{WithDividendsAsianOption} \tab Adds dividends to Asian option formula. } \tabular{ll}{ \code{FuMadanWangTable} \tab Table from Fu, Madan and Wang's paper, \cr \code{FusaiTaglianiTable} \tab Table from Fusai und tagliani's paper, \cr \code{GemanTable} \tab Table from Geman's paper, \cr \code{LinetzkyTable} \tab Table from Linetzky's paper, \cr \code{ZhangTable} \tab Table from Zhang's paper, \cr \code{ZhangLongTable} \tab Long Table from Zhang's paper, \cr \code{ZhangShortTable} \tab Short Table from Zhang's paper. } Sorry - The Documentation is still Uncomplete. } \usage{ MomentMatchedAsianOption(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30, table = NA, method = c("LN", "RG", "JI")) MomentMatchedAsianDensity(x, Time = 1, r = 0.09, sigma = 0.30, method = c("LN", "RG", "JI")) GramCharlierAsianOption(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30, table = NA, method = c("LN", "RG", "JI")) AsianOptionMoments(M = 4, Time = 1, r = 0.045, sigma = 0.30, log = FALSE, method = c("A", "D", "TW", "T")) %Schroeder1AsianDensity() %Schroeder2AsianDensity() %Yor1AsianDensity() %Yor2AsianDensity() %TolmatzAsianDensity() %TolmatzAsianProbability() ZhangAsianOption(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30, table = NA, correction = TRUE, nint = 800, eps = 1.0e-8, dt = 1.0e-10) VecerAsianOption(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30, table = NA, nint = 800, eps = 1.0e-8, dt = 1.0e-10) gGemanYor(lambda, S = 100, X = 100, Time = 1, r = 0.05, sigma = 0.30, log = FALSE, doplot = FALSE) GemanYorAsianOption(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30, doprint = FALSE) gLinetzky(x, y, tau, nu, ip = 0) LinetzkyAsianOption(TypeFlag = c("c", "p"), S = 2, X = 2, Time = 1, r = 0.02, sigma = 0.1, table = NA, lower = 0, upper = 100, method = "adaptive", subdivisions = 100, ip = 0, doprint = TRUE, doplot = TRUE, \dots) BoundsOnAsianOption(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30, table = NA, method = c("CT", "RST", "T")) CurranThompsonAsianOption(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30) RogerShiThompsonAsianOption(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30) ThompsonAsianOption(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30) TolmatzAsianOption(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30) CallPutParityAsianOption(TypeFlag = "p", Price = 8.828759, S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.3, table = NA) WithDividendsAsianOption(TypeFlag = "c", Dividends = 0.45, S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.3, calculator = MomentMatchedAsianOption, method = "LN") FuMadanWangTable() FusaiTaglianiTable() GemanTable() LinetzkyTable() ZhangTable() ZhangLongTable() ZhangShortTable() } \arguments{ \item{calculator}{ [WithDividendsAsianOption] - \cr the name of the function selecting the option calculator to be used. } \item{correction}{ [ZhangAsianOption] - \cr xxx. } \item{Dividends}{ [WithDividendsAsianOption] - \cr xxx. } \item{doplot}{ [gGemanYor][LinetzkyAsianOption] - \cr xxx. } \item{doprint}{ [GemanYorAsianOption][LinetzkyAsianOption] - \cr xxx. } \item{dt}{ [VecerAsianOption][ZhangAsianOption] - \cr xxx. } \item{eps}{ [VecerAsianOption][ZhangAsianOption] - \cr xxx. } \item{ip}{ [gLinetzky] - \cr xxx. } \item{lambda}{ [gGemanYor] - \cr xxx. } \item{log}{ [AsianOptionMoments][gGemanYor] - \cr xxx. } \item{lower, upper}{ [LinetzkyAsianOption] - \cr xxx. } \item{M}{ [*] - \cr xxx. } \item{method}{ [*] - \cr xxx. } \item{nint}{ [*] - \cr xxx. } \item{nu}{ [*] - \cr xxx. } \item{Price}{ [*] - \cr xxx. } \item{r}{ a numeric value, the annualized rate of interest; e.g. 0.25 means 25\% pa. } \item{S}{ the asset price, a numeric value. } \item{sigma}{ a numeric value, the annualized volatility of the underlying security; e.g. 0.3 means 30\% volatility pa. } \item{subdivisions}{ [*] - \cr xxx. } \item{table}{ [*] - \cr xxx. } \item{tau}{ [*] - \cr xxx. } \item{Time}{ a numeric value, the time to maturity measured in years; e.g. 0.5 means 6 months. } \item{TypeFlag}{ a character string either \code{"c"} for a call option or a \code{"p"} for a put option. } \item{x}{ [*] - \cr xxx. } \item{X}{ a numeric value, the exercise price. } \item{y}{ [*] - \cr xxx. } \item{\dots}{ [*] - \cr xxx. } } %\details{ % % ... % %} %\value{ % % The functions ... % %} \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## Examples: # none ... } \keyword{math} fAsianOptions/man/BesselFunctions.Rd0000644000176200001440000000601511370220760017177 0ustar liggesusers\name{BesselFunctions} \alias{BesselFunctions} \alias{BesselI} \alias{BesselK} \alias{BesselDI} \alias{BesselDK} \title{Modified Bessel Functions} \description{ A collection and description of special mathematical functions which compute the modified Bessel functions of integer order of the first and second kind as well as their derivatives. \cr The functions are: \tabular{ll}{ \code{BesselI} \tab modified Bessel function of the 1st Kind, \cr \code{BesselDI} \tab its derivative, \cr \code{BesselK} \tab the modified Bessel function of the 3nd Kind, \cr \code{BesselDK} \tab its derivative. } } \usage{ BesselI(x, nu, expon.scaled = FALSE) BesselK(x, nu, expon.scaled = FALSE) BesselDI(x, nu) BesselDK(x, nu) } \arguments{ \item{expon.scaled}{ a logical; if TRUE, the results are exponentially scaled. } \item{nu}{ an integer value greater or equal to zero, the integer order of the modified Bessel function. } \item{x}{ a positive numeric value or a vector of positive numerical values. } } \value{ The functions return the values of the selected special mathematical function. } \references{ Abramowitz M., Stegun I.A. (1972); \emph{Handbook of Mathematical Functions with Formulas, Graphs, and Mathematical Tables}, 9th printing, New York, Dover Publishing. Weisstein E.W. (2004); \emph{MathWorld -- A Wolfram Web Resource}, http://mathworld.wolfram.com } \author{ Diethelm Wuertz for the Rmetrics \R-port. } \examples{ ## Bessel I0 and K0 - # Abramowitz-Stegun: Table 9.8, p. 416-422 x = c(0.0, 0.01, 0.1, 0.2, 0.5, 1, 2, 5, 10, 20, 50) data.frame(x, I = exp(-x)*BesselI(x, 0), K = exp(x)*BesselK(x, 0)) # Compare with R's internal function: # data.frame(x, ratio = BesselI(x, 0) / besselI(x, 0)) # data.frame(x, ratio = BesselK(x, 0) / besselK(x, 0)) ## x = 0: c(BesselI(0, 0), BesselI(0, 1), BesselI(0, 2), BesselI(0, 5)) # Compare with R's internal function: # c(besselI(0, 0), besselI(0, 1), besselI(0, 2), besselI(0, 5)) c(BesselK(0, 0), BesselK(0, 1), BesselK(0, 2), BesselK(0, 5)) # Compare with R's internal function: # c(besselK(0, 0), besselK(0, 1), besselK(0, 2), besselK(0, 5)) ## Bessel I2 and K2 - # Abramowitz-Stegun: Table 9.8, p. 416-422 x = c(0.0, 0.01, 0.1, 0.2, 0.5, 1, 2, 5, 10, 20, 50) data.frame(x, I = BesselI(x, 2)/x^2, K = BesselK(x, 2)*x^2) # Compare with R's internal function: # data.frame(x, ratio = BesselI(x, 0) / besselI(x, 0)) # data.frame(x, ratio = BesselK(x, 0) / besselK(x, 0)) # data.frame(x, ratio = BesselI(x, 1) / besselI(x, 1)) # data.frame(x, ratio = BesselK(x, 1) / besselK(x, 1)) # data.frame(x, ratio = BesselI(x, 5) / besselI(x, 5)) # data.frame(x, ratio = BesselK(x, 5) / besselK(x, 5)) # data.frame(x, ratio = BesselI(x,50) / besselI(x,50)) # data.frame(x, ratio = BesselK(x,50) / besselK(x,50)) } \keyword{math} fAsianOptions/inst/0000755000176200001440000000000012161636326014012 5ustar liggesusersfAsianOptions/inst/unitTests/0000755000176200001440000000000012161636326016014 5ustar liggesusersfAsianOptions/inst/unitTests/runit.HypergeometricFunctions.R0000644000176200001440000001375211370220760024156 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: KUMMER DESCRIPTION: # kummerM Computes Confluent Hypergeometric Function of the 1st Kind # kummerU Computes Confluent Hypergeometric Function of the 2nd Kind # FUNCTION: WHITTAKER DESCRIPTION: # whittakerM Computes Whittaker's M Function # whittakerW Computes Whittaker's M Function # FUNCTION: HERMITE POLYNOMIAL: # hermiteH Computes the Hermite Polynomial ################################################################################ test.kummer = function() { # kummerM(x, a, b, lnchf = 0, ip = 0) # kummerU(x, a, b, ip = 0) # Relation to Modified Bessel Function: # Abramowitz-Stegun: Formula 13.6.3, p. 509 x = c(0.001, 0.01, 0.1, 1, 10, 100, 1000) nu = 1; a = nu+1/2; b = 2*nu+1 M = Re ( kummerM(x = 2*x, a = a, b = b) ) Bessel = gamma(1+nu) * exp(x)*(x/2)^(-nu) * BesselI(x, nu) cbind(x, M, Bessel) # Relation to Hyperbolic Function: # Abramowitz-Stegun: Formula 13.6.14, p. 509 x = c(0.001, 0.01, 0.1, 1, 10, 100, 1000) M = Re ( kummerM(2*x, a = 1, b = 2) ) Sinh = exp(x)*sinh(x)/(x) cbind(x, M, Sinh) # Relation to Complex Hyperbolic Function: # Abramowitz-Stegun: Formula 13.6.14, p. 509 y = rep(1, length = length(x)) x = complex(real = x, imag = y) M = kummerM(2*x, a = 1, b = 2) Sinh = exp(x)*sinh(x)/(x) cbind(x, M, Sinh) # Abramowitz-Stegun: Examples, p. 511 M = function(a, b, x) { Re (kummerM(x, a, b)) } # Example 1 M( 0.3, 0.2, -0.1) - 0.8578490 # 2 M( 17.0, 16.0, 1) - 2.8881744 # 3 M( -1.3, 1.2, 0.1) - 0.8924108 # 4 # M( -1, -1.0, 0) # undefined # 6 M( 0.9, 0.1, 10) - 1227235 # 7 M(-52.5, 0.1, 1) - 16.34 # CHECK # Abramowitz-Stegun: Examples, p. 511 U = function(a, b, x) { Re (kummerU(x, a, b)) } # 9 U( 1.1, 0.2, 1) - 0.38664 U(-0.9, 0.2, 1) - 0.91272 # 10 U( 0.1, 0.2, 1)*0.9 - 0.85276 # 11 U( 1.0, 0.1, 100) - 0.0098153 # CHECK # 12 U( 0.1, 0.2, 0.01) - 1.09 # Abramowitz-Stegun: Example 17, Figure 13.2, p. 513 # M(-4.5, 1, x) x = seq(0, 17, length = 200) plot(x = x, y = kummerM(x, -4.5, 1), type = "l", ylim = c(-25,125), main = "Figure 13.2: M(-4.5, 1, x)") lines(x = c(0, 16), y = c(0, 0), col = 2) # Abramowitz-Stegun: Example 17, Figure 13.3, p. 513 # M(a, 1, x) x = seq(0, 8, length = 200) plot(x = c(0, 8), y = c(-10, 10), type = "n", main = "Figure 13.2: M(-4.5, 1, x)") grid() for (a in seq(-4, 0, by = 0.5)) lines(x = x, y = kummerM(x, a, 1), type = "l") abline(h = 0, lty = 3, col = "red") # Abramowitz-Stegun: Example 17, Figure 13.4, p. 513 # M(a, 0.5, x) x = seq(0, 7, length = 200) plot(x = c(0, 7), y = c(-10, 15), type = "n", main = "Figure 13.2: M(-4.5, 1, x)") grid() for (a in seq(-4, 0, by = 0.5)) lines(x = x, y = kummerM(x, a, 0.5), type = "l") abline(h = 0, lty = 3, col = "red") # Return Value: return() } # ------------------------------------------------------------------------------ test.whittaker = function() { # whittakerM(x, kappa, mu, ip = 0) # whittakerW(x, kappa, mu, ip = 0) # Abramowitz-Stegun: Example 13 AS = c(1.10622, 0.57469) W = c( whittakerM(x = 1, kappa = 0, mu = -0.4), whittakerW(x = 1, kappa = 0, mu = -0.4) ) data.frame(AS, W) # Return Value: return() } # ------------------------------------------------------------------------------ test.hermite = function() { # Hermite Polynomial - internally computed from Kummer U # hermiteH(x, n, ip = 0) # http://mathworld.wolfram.com/HermitePolynomial.html x = seq(-2, 2, length = 401) par(mfrow = c(1, 1)) plot(x = c(-2,2), y = c(-30, 30), type = "n", main = "Hermite Polynomials") grid() for (i in 1:4) lines(x, hermiteH(x, i), col = i) # Test H4: H4 = function(x) { 16*x^4 -48*x^2 + 12 } x = -5:5 cbind(x, hermite = hermiteH(x, 4), H = H4(x)) # Return Value: return() } # ------------------------------------------------------------------------------ if (FALSE) { require(RUnit) testResult <- runTestFile("C:/Rmetrics/SVN/trunk/fOptions/tests/runit3C.R", rngKind = "Marsaglia-Multicarry", rngNormalKind = "Inversion") printTextProtocol(testResult) } ################################################################################ fAsianOptions/inst/unitTests/runit.GammaFunctions.R0000644000176200001440000001522511370220760022207 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # erf Error function # [gamma] Gamma function # [lgamma] LogGamma function, returns log(gamma) # [digamma] First derivative of of LogGamma, dlog(gamma(x))/dx # [trigamma] Second derivative of of LogGamma, dlog(gamma(x))/dx # {tetragamma} Third derivative of of LogGamma, dlog(gamma(x))/dx # {pentagamma} Fourth derivative of LogGamma, dlog(gamma(x))/dx # [beta]* Beta function # [lbeta]* LogBeta function, returns log(Beta) # Psi Psi(x) (Digamma) function # igamma P(a,x) Incomplete Gamma Function # cgamma Gamma function for complex arguments # Pochhammer Pochhammer symbol # NOTES: # Functions in [] paranthesis are part of the R's and SPlus' base distribution # Functions in {} paranthesis are only availalble in R # Function marked by []* are compute through the gamma function in SPlus ################################################################################ test.erf = function() { # Error Function # erf(x) - Abramowitz-Stegun p. 310 ff erf(0.0) erf(0.5) - 0.5204998788 erf(1.0) - 0.8427007929 erf(2.0) - 0.9953222650 erf(-0.5) + 0.5204998788 erf(-1.0) + 0.8427007929 erf(-2.0) + 0.9953222650 x = seq(-5, 5, length = 101) y = erf(x) par(mfrow = c(1,1)) plot(x, y, type = "b", pch = 19) # Symmetry Relation, p. 297 # erf(-x) = - erf(x) erf(-0.5) + erf(0.5) erf(-pi) + erf(pi) # Abramowitz-Stegun: Example 1, p. 304 erf(0.745) - 0.707928920 # Return Value: return() } # ------------------------------------------------------------------------------ test.erfc = function() { # Complementary Error Function # Add functions: erfc = function(x) { 1 - erf(x) } erfc(0.5) erf(0.5) + erfc(0.5) # Abramowitz-Stegun: Example 2, p. 304 1.1352e-11 1 - erf(4.8) # Return Value: return() } # ------------------------------------------------------------------------------ test.gamma = function() { # Gamma Function # Abramowitz-Stegun: Figure 6.1, p. 255 x = seq(-4.01, 4.01, by = 0.011) # Plot: plot(x, gamma(x), ylim = c(-5,5), type = "l", main = "Gamma Function") grid() abline(h = 0, col = "red", lty = 3) for (i in c(-4:0)) abline(v = i, col = "white") for (i in c(-4:0)) abline(v = i, col = "red", lty = 3) # Add 1/Gamma: lines(x, 1/gamma(x), lty = 3) # Return Value: return() } # ------------------------------------------------------------------------------ test.Psi = function() { # Psi Function # Abramowitz-Stegun: Figure 6.2, p. 258 x = seq(-4.01, 4.01, by = 0.011) plot(x, Psi(x), ylim = c(-5, 5), type = "l", main = "Psi Function") grid() abline(h = 0, col = "red", lty = 3) for (i in c(-4:0)) abline(v = i, col = "white") for (i in c(-4:0)) abline(v = i, col = "red", lty = 3) # Return Value: return() } # ------------------------------------------------------------------------------ test.incompleteGamma = function() { # Incomplete Gamma Function # Abramowitz-Stegun: Figure 6.3. gammaStar = function(x, a) { igamma(x,a)/x^a } # ... create Figure as an exercise. # Abramowitz-Stegun: Formula 6.5.12 # Relation to Confluent Hypergeometric Functions a = sqrt(2) x = pi Re ( (x^a/a) * kummerM(-x, a, 1+a) ) Re ( (x^a*exp(-x)/a) * kummerM(x, 1, 1+a) ) pgamma(x, a) * gamma(a) igamma(x, a) # Return Value: return() } # ------------------------------------------------------------------------------ test.complexGamma = function() { # Complex Gamma Function # Abramowitz-Stegun: Tables 6.7, p. 277 x = 1 y = seq(0, 5, by = 1); x = rep(x, length = length(y)) z = complex(real = x, imag = y) c = cgamma(z, log = TRUE) cbind(x, y, "Re ln" = Re(c), "Im ln" = Im(c)) # Abramowitz-Stegun: Tables 6.7, p.287 x = 2 y = seq(0, 5, by = 1); x = rep(x, length = length(y)) z = complex(real = x, imag = y) c = cgamma(z, log = TRUE) cbind(x, y, "Re ln" = Re(c), "Im ln" = Im(c)) # cgamma - # Abramowitz-Stegun: Examples, p. 263 options(digits = 10) # Example 1, 2 gamma(6.38); lgamma(56.38) # 3, 4 Psi(6.38); Psi(56.38) # 5 cgamma(complex(real = 1, imag = -1), log = TRUE ) # 6 cgamma(complex(real = 1/2, imag = 1/2), log = TRUE ) # 7, 8 cgamma(complex(real = 3, imag = 7), log = TRUE ) # Return Value: return() } # ------------------------------------------------------------------------------ test.Pochhammer = function() { # Pochhammer Symbol # Abramowitz-Stegun: Formula 6.1.22, p. 256 # Pochhammer(x, n) Pochhammer(x = 1, n = 0) - 1 Pochhammer(x = 1, n = 1) - 1 Pochhammer(x = 2, n = 2) - gamma(2+2)/gamma(2) # Return Value: return() } # ------------------------------------------------------------------------------ if (FALSE) { require(RUnit) testResult <- runTestFile("C:/Rmetrics/SVN/trunk/fOptions/tests/runit3B.R", rngKind = "Marsaglia-Multicarry", rngNormalKind = "Inversion") printTextProtocol(testResult) } ################################################################################ fAsianOptions/inst/unitTests/runit.EBMDistribution.R0000644000176200001440000002221511370220760022274 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EBM DENSITY APPROXIMATIONS: # dlognorm log-Normal density an derivatives # plognorm log-Normal, synonyme for plnorm # dgam Gamma density, synonyme for dgamma # pgam Gamma probability, synonyme for pgamma # drgam Reciprocal-Gamma density # prgam Reciprocal-Gamma probability # djohnson Johnson Type I density # pjohnson Johnson Type I probability # FUNCTION : MOMENTS FOR EBM DENSITY APPROXIMATIONS: # mnorm Moments of Normal density # mlognorm Moments of log-Normal density # mrgam Moments of reciprocal-Gamma density # masian Moments of Asian Option density # .DufresneMoments Internal Function used by masian() # FUNCTION: NUMERICAL DERIVATIVES: # derivative First and second numerical derivative # FUNCTION: ASIAN DENSITY: # d2EBM Double Integrated EBM density # .thetaEBM Internal Function used to compute *2EBM() # .psiEBM Internal Function used to compute *2EBM() # dEBM Exponential Brownian motion density # pEBM Exponential Brownian motion probability # .gxuEBM Internal Function used to compute *EBM() # .gxtEBM Internal Function used to compute *EBM() # .gxtuEBM Internal Function used to compute *EBM() # dasymEBM Exponential Brownian motion asymptotic density ################################################################################ test.lognorm = function() { # dlognorm - log-Normal density an derivatives # plognorm - log-Normal, synonyme for plnorm # Calculate Log-Normal Density and its Derivatives: x = exp(seq(-2.8, 1.2, length = 100)) y0 = dlognorm(x, deriv = 0) y1 = dlognorm(x, deriv = 1) y2 = dlognorm(x, deriv = 2) # Compare with Numerical Differentiation: par(mfrow = c(2, 2)) xa = exp(seq(-2.5, 1.5, length = 20)) plot(x, y0, type = "l", main = "Log-Normal Density") plot(x, y1, type = "l", main = "1st Derivative") z = derivative(xa, dlognorm(xa, deriv = 0), deriv = 1) points(z$x, z$y, col = "steelblue") plot(x, y2, type = "l", main = "2nd Derivative") z = derivative(xa, dlognorm(xa, deriv = 0), deriv = 2) points(z$x, z$y, col = "steelblue") # Return Value: return() } # ------------------------------------------------------------------------------ test.gam = function() { # dgam - Gamma density, synonyme for dgamma # pgam - Gamma probability, synonyme for pgamma # Return Value: return() } # ------------------------------------------------------------------------------ test.rgam = function() { # drgam - Reciprocal-Gamma density # prgam - Reciprocal-Gamma probability # Calculate Reciprocal-Gamma Density and its Derivaties: alpha = 2; beta = 1 x = exp(seq(-2.8, 1.2, length = 100)) y0 = drgam(x, alpha, beta, deriv = 0) y1 = drgam(x, alpha, beta, deriv = 1) y2 = drgam(x, alpha, beta, deriv = 2) # Compare with Numerical Differentiation: par(mfrow = c(2, 2)) xa = exp(seq(-2.5, 1.5, length = 20)) plot(x, y0, type = "l", main = "Rec-Gamma Density") plot(x, y1, type = "l", main = "1st Derivative") z = derivative(xa, drgam(xa, alpha, beta, deriv = 0), deriv = 1) points(z$x, z$y, col = "steelblue") plot(x, y2, type = "l", main = "2nd Derivative") z = derivative(xa, drgam(xa, alpha, beta, deriv = 0), deriv = 2) points(z$x, z$y, col = "steelblue") # Return Value: return() } # ------------------------------------------------------------------------------ test.johnson = function() { # djohnson - Johnson Type I density # pjohnson - Johnson Type I probability # Calculate Johnson-Type-I Density and its Derivaties: a = 0.3; b = 1.2; c = -0.2; d = 0.8 x = exp(seq(-2.8, 1.2, length = 100)) y0 = djohnson(x, a, b, c, d, deriv = 0) y1 = djohnson(x, a, b, c, d, deriv = 1) y2 = djohnson(x, a, b, c, d, deriv = 2) # Compare with Numerical Differentiation: par(mfrow = c(2, 2)) xa = exp(seq(-2.5, 1.5, length = 20)) plot(x, y0, type = "l", main = "Johnson Type I Density") plot(x, y1, type = "l", main = "1st Derivative") z = derivative(xa, djohnson(xa, a, b, c, d, deriv = 0), deriv = 1) points(z$x, z$y, col = "steelblue") plot(x, y2, type = "l", main = "2nd Derivative") z = derivative(xa, djohnson(xa, a, b, c, d, deriv = 0), deriv = 2) points(z$x, z$y, col = "steelblue") # Return Value: return() } # ------------------------------------------------------------------------------ test.moments = function() { # mnorm - Moments of Normal density # mlognorm - Moments of log-Normal density # mrgam - Moments of reciprocal-Gamma density # masian - Moments of Asian Option density # .DufresneMoments - Internal Function used by masian() # mnorm(mean = 0, sd = 1) mnorm() # mlognorm(meanlog = 0, sdlog = 1) mlognorm() # mrgam(alpha = 1/2, beta = 1) mrgam() # CHECK # mjohnson(a, b, c, d) a = 0.3; b = 1.2; c = -0.2; d = 0.8 mjohnson(a, b, c, d) # CHECK # masian(Time = 1, r = 0.045, sigma = 0.3) masian() # .DufresneMoments(M = 4, Time = 1, r = 0.045, sigma = 0.30) .DufresneMoments(M = 12, Time = 1, r = 0.045, sigma = 0.30) # Return Value: return() } # ------------------------------------------------------------------------------ test.d2EBM = function() { # d2EBM - Double Integrated EBM density # .thetaEBM - Internal Function used to compute *2EBM() # .psiEBM - Internal Function used to compute *2EBM() # d2EBM(u, t = 1) x = c(0.1, 0.5, 1, 2) # Density: d2 = d2EBM(u = x) d2 # Compare with: d = dEBM(u = x) d # Print cbind(d2, d, difference = abs(d2-d)) # Return Value: return() } # ------------------------------------------------------------------------------ test.dEBM = function() { # dEBM - Exponential Brownian motion density # pEBM - Exponential Brownian motion probability # .gxuEBM - Internal Function used to compute *EBM() # .gxtEBM - Internal Function used to compute *EBM() # .gxtuEBM - Internal Function used to compute *EBM() # Density: x = c( seq(-1.0, 0.0, length = 5), seq( 0.0, 0.5, length = 20), seq( 0.5, 5.0, length = 20)) x = unique(sort(x)) d = dEBM(u = x) print(d) par(mfrow = c(1,1)) plot(x, y = d, type = "b", pch = 19, cex = 0.7) # Probability: x = c(-1, -0.5, 0, 0.1, 0.2, 0.5, 0.75, seq(1, 5, by = 0.5)) p = pEBM(u = x) print(p) par(mfrow = c(1,1)) plot(x, y = p, type = "b", pch = 19, cex = 0.7) # Return Value: return() } # ------------------------------------------------------------------------------ test.dasymEBM = function() { # dasymEBM - Exponential Brownian motion asymptotic density # Density: x = c( seq(0.50, 1.10, length = 21), seq(1.10, 1.40, length = 21), seq(1.40, 5.00, length = 31)) d = dasymEBM(u = x) print(d) par(mfrow = c(1,1)) plot(x, y = d, type = "b", pch = 19, cex = 0.7) abline(h =0, lty = 3, col = "grey") # Return Value: return() } # ------------------------------------------------------------------------------ if (FALSE) { require(RUnit) testResult <- runTestFile("C:/Rmetrics/SVN/trunk/fOptions/tests/runit3A.R", rngKind = "Marsaglia-Multicarry", rngNormalKind = "Inversion") printTextProtocol(testResult) } ################################################################################ fAsianOptions/inst/unitTests/runit.EBMAsianOptions.R0000644000176200001440000001726111370220760022231 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # MOMENT MATCHING: DESCRIPTION: # MomentMatchedAsianOption Valuate moment matched option prices # .LevyTurnbullWakemanAsianOption Log-Normal Approximation # .MilevskyPosnerAsianOption Reciprocal-Gamma Approximation # .PosnerMilevskyAsianOption Johnson Type I Approximation # MomentMatchedAsianDensity Valuate moment matched option densities # .LevyTurnbullWakemanAsianDensity Log-Normal Approximation # .MilevskyPosnerAsianDensity Reciprocal-Gamma Approximation # .PosnerMilevskyAsianDensity Johnson Type I Approximation # GRAM CHARLIER SERIES EXPANSION: DESCRIPTION: # GramCharlierAsianOption Calculate Gram-Charlier option prices # .GramCharlierAsianDensity NA # STATE SPACE MOMENTS: DESCRIPTION: # AsianOptionMoments Methods to calculate Asian Moments # .DufresneAsianOptionMoments Moments from Dufresne's Formula # .AbrahamsonAsianOptionMoments Moments from Abrahamson's Formula # .TurnbullWakemanAsianOptionMoments First 2 Moments from Turnbull-Wakeman # .TolmatzAsianOptionMoments Asymptotic Behavior after Tolmatz # STATE SPACE DENSITIES: DESCRIPTION: # StateSpaceAsianDensity NA # .Schroeder1AsianDensity NA # .Schroeder2AsianDensity NA # .Yor1AsianDensity NA # .Yor2AsianDensity NA # .TolmatzAsianDensity NA # .TolmatzAsianProbability NA # PARTIAL DIFFERENTIAL EQUATIONS: DESCRIPTION: # PDEAsianOption PDE Asian Option Pricing # .ZhangAsianOption Asian option price by Zhang's 1D PDE # ZhangApproximateAsianOption # .VecerAsianOption Asian option price by Vecer's 1D PDE # LAPLACE INVERSION: DESCRIPTION: # GemanYorAsianOption Asian option price by Laplace Inversion # gGemanYor Function to be Laplace inverted # SPECTRAL EXPANSION: DESCRIPTION: # LinetzkyAsianOption Asian option price by Spectral Expansion # gLinetzky Function to be integrated # BOUNDS ON OPTION PRICES: DESCRIPTION: # BoundsOnAsianOption Lower and upper bonds on Asian calls # CurranThompsonAsianOption From Thompson's continuous limit # RogerShiThompsonAsianOption From Thompson's single integral formula # ThompsonAsianOption Thompson's upper bound # SYMMETRY RELATIONS: DESCRIPTION: # CallPutParityAsianOption Call-Put parity Relation # WithDividendsAsianOption Adds dividends to Asian Option Formula # TABULATED RESULTS: DESCRIPTION: # FuMadanWangTable Table from Fu, Madan and Wang's paper # FusaiTaglianiTable Table from Fusai und tagliani's paper # GemanTable Table from Geman's paper # LinetzkyTable Table from Linetzky's paper # ZhangTable Table from Zhang's paper # ZhangLongTable Long Table from Zhang's paper # ZhangShortTable Short Table from Zhang's paper ################################################################################ test.MomentMatchedAsianOption = function() { # MomentMatchedAsianOption # Return Value: return() } # ------------------------------------------------------------------------------ test.MomentMatchedAsianDensity = function() { # MomentMatchedAsianDensity # Return Value: return() } # ------------------------------------------------------------------------------ test.GramCharlierAsianOption = function() { # GramCharlierAsianOption # Return Value: return() } # ------------------------------------------------------------------------------ test.AsianOptionMoments = function() { # AsianOptionMoments # Return Value: return() } # ------------------------------------------------------------------------------ test.StateSpaceAsianDensity = function() { # StateSpaceAsianDensity # Return Value: return() } # ------------------------------------------------------------------------------ test.PDEAsianOption = function() { # PDEAsianOption # Return Value: return() } # ------------------------------------------------------------------------------ test.GemanYorAsianOption = function() { # GemanYorAsianOption # Return Value: return() } # ------------------------------------------------------------------------------ test.LinetzkyAsianOption = function() { # LinetzkyAsianOption # Return Value: return() } # ------------------------------------------------------------------------------ test.BoundsOnAsianOption = function() { # BoundsOnAsianOption # Return Value: return() } # ------------------------------------------------------------------------------ test.CurranThompsonAsianOption = function() { # CurranThompsonAsianOption # Return Value: return() } # ------------------------------------------------------------------------------ test.RogerShiThompsonAsianOption = function() { # RogerShiThompsonAsianOption # Return Value: return() } # ------------------------------------------------------------------------------ test.ThompsonAsianOption = function() { # ThompsonAsianOption # Return Value: return() } # ------------------------------------------------------------------------------ test.CallPutParityAsianOption = function() { # CallPutParityAsianOption # Return Value: return() } # ------------------------------------------------------------------------------ test.WithDividendsAsianOption = function() { # WithDividendsAsianOption # Return Value: return() } # ------------------------------------------------------------------------------ test.Table = function() { # Table # Return Value: return() } # ------------------------------------------------------------------------------ if (FALSE) { require(RUnit) testResult <- runTestFile("C:/Rmetrics/SVN/trunk/fOptions/tests/runit3E.R", rngKind = "Marsaglia-Multicarry", rngNormalKind = "Inversion") printTextProtocol(testResult) } ################################################################################ fAsianOptions/inst/unitTests/runit.BesselFunctions.R0000644000176200001440000001241611370220760022401 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2007, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # BesselI Modified Bessel Function of first kind # BesselK Modified Bessel Function of third kind # BesselDI Derivative of BesselI # BesselDK Derivative of BesselK # INTERNAL FUNCTION: DESCRIPTION: # .BesselN For internal use only # .Bessel01 ... # .Bessel.MSTA1 ... # .Bessel.MSTA2 ... # .Bessel.ENVJ ... ################################################################################ test.Bessel = function() { # BesselI - Modified Bessel Function of first kind # BesselK - Modified Bessel Function of third kind # Modified Bessel Functions I and K, Abramowitz-Stegun, Chapter 9.6, p. 374 # Abramowitz-Stegun, Figure 9.7, p. 374 plot(x = c(0, 3), y = c(0, 2.5), type = "n", xlab = "x", ylab = " I0 I1 K0 K1 ") grid() x = seq(0, 3, length = 301) lines(x, BesselI(x, 0)) lines(x, BesselI(x, 1), lty = 3) lines(x, BesselK(x, 0)) lines(x, BesselK(x, 1), lty = 3) # Abramowitz-Stegun, Figure 9.8, p. 375 plot(x = c(0, 10), y = c(0, 1.9), type = "n", xlab = "x", ylab = "y") grid() x = seq(0, 10, length = 501) lines(x, exp(-x)*BesselI(x, 0)) lines(x, exp(-x)*BesselI(x, 1), lty = 3) lines(x, exp(x)*BesselK(x, 0)) lines(x, exp(x)*BesselK(x, 1), lty = 3) # Abramowitz-Stegun, Figure 9.9, p. 375 # Use R's internally implemented Bessel Functions ... plot(x = c(-10, 10), y = c(-5, 30), type = "n", xlab = "nu", ylab = "y") grid() nu = seq(-10, 10, length = 501) lines(nu, besselI(x = 5, nu)) lines(nu, besselK(x = 5, nu), lty = 3) # Bessel I0 and K0 # Abramowitz-Stegun: Table 9.8, p. 416-422 x = c(0.0, 0.01, 0.1, 0.2, 0.5, 1, 2, 5, 10, 20, 50) data.frame(x, I = exp(-x)*BesselI(x, 0), K = exp(x)*BesselK(x, 0)) # Compare with R's internal function: data.frame(x, I = exp(-x)*besselI(x, 0), K = exp(x)*besselK(x, 0)) # Bessel I2 and K2 # Abramowitz-Stegun: Table 9.8, p. 416-422 x = c(0.01, 0.1, 0.2, 0.5, 1, 2, 5, 10, 20, 50) data.frame(x, I = BesselI(x, 2)/x^2, K = BesselK(x, 2)*x^2) # Compare with R's internal function: data.frame(x, I = besselI(x, 2)/x^2, K = besselK(x, 2)*x^2) # Return Value: return() } # ------------------------------------------------------------------------------ test.BesselAssociatedSeries = function() { # Associated Hyperbolic Series, Abramowitz-Stegun 9.6.39, p. 376 besselI(x = 1, 0) + 2 * sum((-1)^(1:10)*besselI(x = 1, 2*(1:10))) 1 # Associated Hyperbolic Series, Abramowitz-Stegun 9.6.39, p. 376 besselI(x = 1, 0) + 2 * sum(besselI(x = 1, 1:20)) exp(1) # Associated Hyperbolic Series, Abramowitz-Stegun 9.6.39, p. 376 besselI(x = 1, 0) + 2 * sum((-1)^(1:20)*besselI(x = 1, 1:20)) exp(-1) # Associated Hyperbolic Series, Abramowitz-Stegun 9.6.39, p. 376 besselI(x = 1, 0) + 2 * sum(besselI(x = 1, 2*(1:10))) cosh(1) # Associated Hyperbolic Series, Abramowitz-Stegun 9.6.40, p. 376 2* sum(besselI(x = 1, 2*(0:10)+1)) sinh(1) # Return Value: return() } # ------------------------------------------------------------------------------ test.BesselD = function() { # BesselDI - Derivative of BesselI # BesselDK - Derivative of BesselK # Check: # I0'(x) = I1(x) x = c(0.01, 0.1, 0.2, 0.5, 1, 2, 5, 10, 20, 50) BesselDI(x, 0) / BesselI(x, 1) # Check: # K0'(x) = -K1(x) x = c(0.01, 0.1, 0.2, 0.5, 1, 2, 5, 10, 20, 50) - BesselDK(x, 0) / BesselK(x, 1) # Return Value: return() } # ------------------------------------------------------------------------------ if (FALSE) { require(RUnit) testResult <- runTestFile("C:/Rmetrics/SVN/trunk/fOptions/tests/runit3D.R", rngKind = "Marsaglia-Multicarry", rngNormalKind = "Inversion") printTextProtocol(testResult) } ################################################################################ fAsianOptions/inst/unitTests/runTests.R0000644000176200001440000000453511370220760017765 0ustar liggesuserspkg <- "fAsianOptions" if(require("RUnit", quietly = TRUE)) { library(package=pkg, character.only = TRUE) if(!(exists("path") && file.exists(path))) path <- system.file("unitTests", package = pkg) ## --- Testing --- ## Define tests testSuite <- defineTestSuite(name = paste(pkg, "unit testing"), dirs = path) if(interactive()) { cat("Now have RUnit Test Suite 'testSuite' for package '", pkg, "' :\n", sep='') str(testSuite) cat('', "Consider doing", "\t tests <- runTestSuite(testSuite)", "\nand later", "\t printTextProtocol(tests)", '', sep = "\n") } else { ## run from shell / Rscript / R CMD Batch / ... ## Run tests <- runTestSuite(testSuite) if(file.access(path, 02) != 0) { ## cannot write to path -> use writable one tdir <- tempfile(paste(pkg, "unitTests", sep="_")) dir.create(tdir) pathReport <- file.path(tdir, "report") cat("RUnit reports are written into ", tdir, "/report.(txt|html)", sep = "") } else { pathReport <- file.path(path, "report") } ## Print Results: printTextProtocol(tests, showDetails = FALSE) printTextProtocol(tests, showDetails = FALSE, fileName = paste(pathReport, "Summary.txt", sep = "")) printTextProtocol(tests, showDetails = TRUE, fileName = paste(pathReport, ".txt", sep = "")) ## Print HTML Version to a File: ## printHTMLProtocol has problems on Mac OS X if (Sys.info()["sysname"] != "Darwin") printHTMLProtocol(tests, fileName = paste(pathReport, ".html", sep = "")) ## stop() if there are any failures i.e. FALSE to unit test. ## This will cause R CMD check to return error and stop tmp <- getErrors(tests) if(tmp$nFail > 0 | tmp$nErr > 0) { stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail, ", R errors: ", tmp$nErr, ")\n\n", sep="")) } } } else { cat("R package 'RUnit' cannot be loaded -- no unit tests run\n", "for package", pkg,"\n") } ################################################################################ fAsianOptions/inst/unitTests/Makefile0000644000176200001440000000042511370220760017445 0ustar liggesusersPKG=fAsianOptions TOP=../.. SUITE=doRUnit.R R=R all: inst test inst: # Install package -- but where ?? -- will that be in R_LIBS ? cd ${TOP}/..;\ ${R} CMD INSTALL ${PKG} test: # Run unit tests export RCMDCHECK=FALSE;\ cd ${TOP}/tests;\ ${R} --vanilla --slave < ${SUITE}fAsianOptions/inst/COPYRIGHT.html0000644000176200001440000002041111370220760016236 0ustar liggesusers Rmetrics::COPYRIGHT

Rmetrics Copyrights

2005-12-18 Built 221.10065 

  
________________________________________________________________________________
Copyrights (C) for 

    R:  
      see R's copyright and license file
      
    Version R 2.0.0 claims:
    - The stub packages from 1.9.x have been removed.
    - All the datasets formerly in packages 'base' and 'stats' have
      been moved to a new package 'datasets'. 
    - Package 'graphics' has been split into 'grDevices' (the graphics
      devices shared between base and grid graphics) and 'graphics'
      (base graphics). 
    - Packages must have been re-installed for this version, and
      library() will enforce this.
    - Package names must now be given exactly in library() and
      require(), regardless of whether the underlying file system is
      case-sensitive or not.    

________________________________________________________________________________
for 
    
    Rmetrics:
      (C) 1999-2005, Diethelm Wuertz, GPL
      Diethelm Wuertz 
      www.rmetrics.org
      info@rmetrics.org
 
________________________________________________________________________________
for non default loaded basic packages part of R's basic distribution

    MASS:    
      Main Package of Venables and Ripley's MASS.
      We assume that MASS is available. 
      Package 'lqs' has been returned to 'MASS'.  
      S original by Venables & Ripley.
      R port by Brian Ripley .
      Earlier work by Kurt Hornik and Albrecht Gebhardt.
    methods: 
      Formally defined methods and classes for R objects, plus other 
      programming tools, as described in the reference "Programming 
      with Data" (1998), John M. Chambers, Springer NY. 
      R Development Core Team.
    mgcv:   
      Routines for GAMs and other generalized ridge regression
      with multiple smoothing parameter selection by GCV or UBRE.
      Also GAMMs by REML or PQL. Includes a gam() function.
      Simon Wood 
    nnet: 
      Feed-forward Neural Networks and Multinomial Log-Linear Models
      Original by Venables & Ripley. 
      R port by Brian Ripley .
      Earlier work by Kurt Hornik and Albrecht Gebhardt.
      
________________________________________________________________________________
for the code partly included as builtin functions from other R ports:

    fBasics:CDHSC.F
      GRASS program for distributional testing.
      By James Darrell McCauley 
      Original Fortran Source by Paul Johnson EZ006244@ALCOR.UCDAVIS.EDU>
    fBasics:nortest
      Five omnibus tests for the composite hypothesis of normality
      R-port by Juergen Gross 
    fBasics:SYMSTB.F
      Fast numerical approximation to the Symmetric Stable distribution 
      and density functions.  
      By Hu McCulloch 
    fBasics:tseries
      Functions for time series analysis and computational finance.
      Compiled by Adrian Trapletti 
         
    fCalendar:date     
      The tiny C program from Terry Therneau  is used
      R port by Th. Lumley ,
      K. Halvorsen , and 
      Kurt Hornik 
    fCalendar:holidays
      The holiday information was collected from the internet and 
      governmental sources obtained from a few dozens of websites
    fCalendar:libical
      Libical is an Open Source implementation of the IETF's 
      iCalendar Calendaring and Scheduling protocols. (RFC 2445, 2446, 
      and 2447). It parses iCal components and provides a C API for 
      manipulating the component properties, parameters, and subcomponents.
    fCalendar:vtimezone
      Olsen's VTIMEZONE database consists of data files are released under 
      the GNU General Public License, in keeping with the license options of 
      libical. 
     
    fSeries:bdstest.c
      C Program to compute the BDS Test.
      Blake LeBaron
    fSeries:fracdiff  
      R functions, help pages and the Fortran Code for the 'fracdiff' 
      function are included. 
      S original by Chris Fraley 
      R-port by Fritz Leisch 
      since 2003-12: Martin Maechler
    fSeries:lmtest
      R functions and help pages for the linear modelling tests are included .
      Compiled by Torsten Hothorn ,
      Achim Zeileis , and
      David Mitchell
    fSeries:mda    
      R functions, help pages and the Fortran Code for the 'mars' function
      are implemeted.
      S original by Trevor Hastie & Robert Tibshirani,
      R port by Friedrich Leisch, Kurt Hornik and Brian D. Ripley 
    fSeries:modreg
      Brian Ripley and the R Core Team
    fSeries:polspline   
      R functions, help pages and the C/Fortran Code for the 'polymars' 
      function are implemented
      Charles Kooperberg 
    fSeries:systemfit
      Simultaneous Equation Estimation Package.
      R port by Jeff D. Hamann  and 
      Arne Henningsen 
    fSeries:tseries
      Functions for time series analysis and computational finance.
      Compiled by Adrian Trapletti 
    fSeries:UnitrootDistribution:
      The program uses the Fortran routine and the tables 
      from J.G. McKinnon. 
    fSeries:urca
      Unit root and cointegration tests for time series data.
      R port by Bernhard Pfaff .
     
    fExtremes:evd
      Functions for extreme value distributions.
      R port by Alec Stephenson 
      Function 'fbvpot' by Chris Ferro.
    fExtremes:evir
      Extreme Values in R
      Original S functions (EVIS) by Alexander McNeil 
      R port by Alec Stephenson   
    fExtremes:ismev
      An Introduction to Statistical Modeling of Extreme Values
      Original S functions by Stuart Coles 
      R port/documentation by Alec Stephenson 
      
    fOptions
      Option Pricing formulas are implemented along the book and 
      the Excel spreadsheets of E.G. Haug, "The Complete Guide to Option 
      Pricing"; documentation is partly taken from www.derivicom.com which 
      implements a C Library based on Haug. For non-academic and commercial 
      use we recommend the professional software from "www.derivicom.com".  
    fOptions:SOBOL.F
      ACM Algorithm 659 by P. Bratley and B.L. Fox
      Extension on Algorithm 659 by S. Joe and F.Y. Kuo
    fOptions:CGAMA.F
      Complex gamma and related functions.
      Fortran routines by Jianming Jin.
    fOptions:CONHYP.F
      Confluenet Hypergeometric and related functions.
      ACM Algorithm 707 by mark Nardin, W.F. Perger, A. Bhalla
             
    fPortfolio:mvtnorm
      Multivariate Normal and T Distribution.
      Alan Genz , 
      Frank Bretz 
      R port by Torsten Hothorn 
    fPortfolio:quadprog
      Functions to solve Quadratic Programming Problems.
      S original by Berwin A. Turlach  
      R port by Andreas Weingessel 
    fPortfolio:sn
      The skew-normal and skew-t distributions.
      R port by Adelchi Azzalini 
    fPortfolio:tseries
      Functions for time series analysis and computational finance.
      Compiled by Adrian Trapletti
fAsianOptions/R/0000755000176200001440000000000012161636326013236 5ustar liggesusersfAsianOptions/R/zzz.R0000644000176200001440000000257412157313045014221 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2008, Diethelm Wuertz, Rmetrics Foundation, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ if(!exists("Sys.setenv", mode = "function")) # pre R-2.5.0, use "old form" Sys.setenv <- Sys.putenv ################################################################################ fAsianOptions/R/HypergeometricFunctions.R0000644000176200001440000001346311734074114020243 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR Description. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2004, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: KUMMER DESCRIPTION: # kummerM Computes Confluent Hypergeometric Function of the 1st Kind # kummerU Computes Confluent Hypergeometric Function of the 2nd Kind # FUNCTION: WHITTAKER DESCRIPTION: # whittakerM Computes Whittaker's M Function # whittakerW Computes Whittaker's M Function # FUNCTION: HERMITE POLYNOMIAL: # hermiteH Computes the Hermite Polynomial ################################################################################ ################################################################################ # KUMMER: kummerM = function(x, a, b, lnchf = 0, ip = 0) { # A function implemented by Diethelm Wuertz # Description: # Calculate the Confluent Hypergeometric Function of the First # Kind for complex argument "x" and complex indexes "a" and "b" # Arguments: # x - complex function argument # a, b - complex indexes # lnchf - # ip - # FUNCTION: # You can also input real arguments: if (!is.complex(x)) x = complex(real = x, imaginary = 0*x) if (!is.complex(a)) a = complex(real = a, imaginary = 0) if (!is.complex(b)) b = complex(real = b, imaginary = 0) # Calculate KummerM: chm = rep(complex(real = 0, imaginary = 0), length = length(x)) value = .Fortran("chfm", as.double(Re(x)), as.double(Im(x)), as.double(Re(a)), as.double(Im(a)), as.double(Re(b)), as.double(Im(b)), as.double(Re(chm)), as.double(Im(chm)), as.integer(length(x)), as.integer(lnchf), as.integer(ip), PACKAGE = "fAsianOptions") result = complex(real = value[[7]], imaginary = value[[8]]) # Return Value: result } # ------------------------------------------------------------------------------ kummerU = function(x, a, b, ip = 0) { # A function implemented by Diethelm Wuertz # Description: # Calculate the Confluent Hypergeometric Function of the Second # Kind for complex argument "x" and complex indexes "a" and "b" # Arguments: # FUNCTION: # Todo ... lnchf = 0 # Test for complex arguments: if (!is.complex(x)) x = complex(real = x, imaginary = 0*x) if (!is.complex(a)) a = complex(real = a, imaginary = 0) if (!is.complex(b)) b = complex(real = b, imaginary = 0) # Calculate KummerU: # From KummerM: # Uses the formula ... # pi/sin(pi*b) [ M(a,b,z) / (Gamma(1+a-b)*Gamma(b)) - # x^(1-b) * M(1+a-b,2-b,z) / (Gamma(a)*Gamma(2-b)) ] ans = ( pi/sin(pi*b) ) * ( kummerM(x, a = a, b = b, lnchf = lnchf, ip=ip) / ( cgamma(1+a-b)*cgamma(b) ) - (x^(1-b)) * kummerM(x, a = (1+a-b), b=2-b, lnchf = lnchf, ip = ip) / ( cgamma(a)*cgamma(2-b) ) ) # Return Value: ans } ################################################################################ # WHITTAKER: whittakerM = function(x, kappa, mu, ip = 0) { # A function implemented by Diethelm Wuertz # Description: # Computes Whittaker's M Function # Arguments: # FUNCTION: # Test for complex arguments: if (!is.complex(x)) x = complex(real = x, imaginary = 0*x) if (!is.complex(kappa)) kappa = complex(real = kappa, imaginary = 0) if (!is.complex(mu)) mu = complex(real = mu, imaginary = 0) # Calculate: ans = exp(-x/2) * x^(1/2+mu) * kummerM(x, 1/2+mu-kappa, 1+2*mu, ip = ip) # Return Value: ans } # ------------------------------------------------------------------------------ whittakerW = function(x, kappa, mu, ip = 0) { # A function implemented by Diethelm Wuertz # Description: # Computes Whittaker's M Function # Arguments: # FUNCTION: # Test for complex arguments: if (!is.complex(x)) x = complex(real = x, imaginary = 0*x) if (!is.complex(kappa)) kappa = complex(real = kappa, imaginary = 0) if (!is.complex(mu)) mu = complex(real = mu, imaginary = 0) # Calculate: ans = exp(-x/2) * x^(1/2+mu) * kummerU(x, 1/2+mu-kappa, 1+2*mu, ip = ip) # Return Value: ans } ################################################################################ # HERMITE POLYNOMIAL: hermiteH = function(x, n, ip = 0) { # A function implemented by Diethelm Wuertz # Description: # Computes the Hermite Polynomial # Arguments: # n - the index of the Hermite polynomial. # FUNCTION: # Check stopifnot(n - round(n, 0) == 0) # Result: S = sign(x) + (1-sign(abs(x))) ans = (S*2)^n * Re ( kummerU(x^2, -n/2, 1/2, ip = ip) ) # Return Value: ans } ################################################################################ fAsianOptions/R/GammaFunctions.R0000644000176200001440000001752212157313045016276 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # this R-port: # by Diethelm Wuertz # for the code accessed (or partly included) from other R-ports: # R: see R's copyright and license file # for Haug's Option Pricing Formulas: # Formulas are implemented along the book and the Excel spreadsheets of # E.G. Haug, "The Complete Guide to Option Pricing"; documentation # is partly taken from www.derivicom.com which implements # a C Library based on Haug. For non-academic and commercial use # we recommend the professional software from "www.derivicom.com". ################################################################################ # FUNCTION: DESCRIPTION: # erf Error function # [gamma] Gamma function # [lgamma] LogGamma function, returns log(gamma) # [digamma] First derivative of of LogGamma, dlog(gamma(x))/dx # [trigamma] Second derivative of of LogGamma, dlog(gamma(x))/dx # {tetragamma} Third derivative of of LogGamma, dlog(gamma(x))/dx # {pentagamma} Fourth derivative of LogGamma, dlog(gamma(x))/dx # [beta]* Beta function # [lbeta]* LogBeta function, returns log(Beta) # Psi Psi(x) (Digamma) function # igamma P(a,x) Incomplete Gamma Function # cgamma Gamma function for complex arguments # Pochhammer Pochhammer symbol # NOTES: # Functions in [] paranthesis are part of the R's and SPlus' base distribution # Functions in {} paranthesis are only availalble in R # Function marked by []* are compute through the gamma function in SPlus ################################################################################ erf = function(x) { # A function implemented by Diethelm Wuertz # Description: # Computes the Error function for real argument "x" # Arguments: # x - a real numeric value or vector. # FUNCTION: # Result # DW 2005-05-04 ans = 2 * pnorm(sqrt(2) * x) - 1 # Return Value: ans } # ------------------------------------------------------------------------------ cgamma = function(x, log = FALSE) { # A function implemented by Diethelm Wuertz # Description: # Computes the Gamma Function for complex argument "x" # Arguments: # z - a complex or real vector # log - if TRUE the logarithm of the gamma is calculated # otherwise if FALSE, the gamma function itself # will be calculated. # Source: # For the Fortran Routine: # http://iris-lee3.ece.uiuc.edu/~jjin/routines/routines.html # FUNCTION: # Test for complex arguments: if (!is.complex(x)) x = complex(real = x, imaginary = 0*x) # Calculate Gamma: KF = 1 if (log) { KF = KF - 1 } result = rep(NA, times = length(x)) for ( i in 1:length(x) ) { value = .Fortran("cgama", as.double(Re(x[i])), as.double(Im(x[i])), as.integer(KF), as.double(0), as.double(0), PACKAGE = "fAsianOptions") result[i] = complex(real = value[[4]], imaginary = value[[5]]) } # Return Value: result } # ------------------------------------------------------------------------------ Psi = function(x) { # A function implemented by Diethelm Wuertz # Description: # Computes the Psi or Digamma function for complex or real argument # Arguments: # z - a complex numeric value or vector. # Details: # [AS} formula 6.3.1 # $ \Psi(x) = d ln \Gamma(z) / dz = \Gamma prime (z) / \Gamma(z) $ # Arguments: # x - complex or real vector # Source: # For the Fortran Routine: # http://iris-lee3.ece.uiuc.edu/~jjin/routines/routines.html # FUNCTION: # Psi: result = rep(NA, times = length(x)) if (!is.complex(x)) { # Use R's digamma() function: result = digamma(x) } else { for ( i in 1:length(Re(x)) ) { value = .Fortran("cpsi", as.double(Re(x[i])), as.double(Im(x[i])), as.double(0), as.double(0), PACKAGE = "fAsianOptions") result[i] = complex(real = value[[3]], imaginary = value[[4]]) } } # Return Value: result } # ------------------------------------------------------------------------------ igamma = function(x, a) { # A function implemented by Diethelm Wuertz # Description: # Computes the Incomplete Gamma Function P(a, x) with # Re(a) > 0 for complex or real argument "x" and for # complex or real index "z" # Arguments: # z - a complex or real vector # a - a complex or real numeric value # Details: # [AS] formula 6.5.1 # $ frac{1}{Gamma(a)} * \int_0^x e^{-t} t^{a-1} dt $ # FUNCTION: # igamma: if (!is.complex(x) && !is.complex(a)) { # Use R's pgamma() function: # if (a < 0) Not suppported ... result = pgamma(x, a) } else { # Why not derive the result from KummersM ? log = FALSE if (log) { # Not yet supported: result = kummerM(a, a + 1, -x, lnchf = 1) + a*log(x) - log(a) } else { result = kummerM(a, a + 1, -x, lnchf = 0) * x^a / a } } # Return Value: result } # ------------------------------------------------------------------------------ Pochhammer = function(x, n) { # A function implemented by Diethelm Wuertz # Description: # Computes Pochhammer's Symbol # Arguments: # x - a complex numeric value or vector. # n - an integer n >=0. An notation used in the theory of special # functions for the rising factorial, also known as the rising # factorial power (Graham et al. 1994). # Details: # as defined in [AS] by formula 6.1.22 # FUNCTION: # Note: # $ (z)_0 = 1 $ # $ (z)_n = z(z+1)(z+2) \dots (z+n-1) = frac{\Gamma(z+n)}{Gamma(z)} $ # In case of wrong argument Type: Pochhammer = NA # For Complex Arguments: if (is.complex(x)) { Pochhammer = cgamma(x + n)/cgamma(x) } # For Real Arguments: # DW: 2006-05-10 is.real(z) replaced by is.real(x) # YC: is.real is deprecated -> replaced by is.double if (is.double(x)) { Pochhammer = gamma(x + n)/gamma(x) } # Return Value: Pochhammer } ################################################################################ # SPlus Addon for beta() and lbeta() # quick and dirty implementation ... .S = FALSE # ------------------------------------------------------------------------------ if (.S) { beta = function(a, b) { # A function implemented by Diethelm Wuertz # Description: # Computes the beta function # Result: ans = gamma(a) * gamma(b) / gamma(a+b) # Return Value: ans } lbeta = function(a, b) { # A function implemented by Diethelm Wuertz # Description: # Computes the beta function # Result: ans = lgamma(a) + lgamma(b) - lgamma(a+b) # Return Value: ans } } ################################################################################ fAsianOptions/R/EBMDistribution.R0000644000176200001440000005262011370220760016361 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2004, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: EBM DENSITY APPROXIMATIONS: # dlognorm log-Normal density an derivatives # plognorm log-Normal, synonyme for plnorm # dgam Gamma density, synonyme for dgamma # pgam Gamma probability, synonyme for pgamma # drgam Reciprocal-Gamma density # prgam Reciprocal-Gamma probability # djohnson Johnson Type I density # pjohnson Johnson Type I probability # FUNCTION : MOMENTS FOR EBM DENSITY APPROXIMATIONS: # mnorm Moments of Normal density # mlognorm Moments of log-Normal density # mrgam Moments of reciprocal-Gamma density # mjohnson Moments of the Johnson Type-I density # masian Moments of Asian Option density # .DufresneMoments Internal Function used by masian() # FUNCTION: NUMERICAL DERIVATIVES: # derivative First and second numerical derivative # FUNCTION: ASIAN DENSITY: # d2EBM Double Integrated EBM density # .thetaEBM Internal Function used to compute *2EBM() # .psiEBM Internal Function used to compute *2EBM() # dEBM Exponential Brownian motion density # pEBM Exponential Brownian motion probability # .gxuEBM Internal Function used to compute *EBM() # .gxtEBM Internal Function used to compute *EBM() # .gxtuEBM Internal Function used to compute *EBM() # dasymEBM Exponential Brownian motion asymptotic density ################################################################################ ################################################################################ # EBM DENSITY APPROXIMATIONS: dlognorm = function(x, meanlog = 0, sdlog = 1, deriv = c(0, 1, 2)) { # A function implemented by Diethelm Wuertz # Description: # Calculates the log-Normal density or its first or # second derivative. # Arguments: # Details: # Uses the function dlnorm(). # See also: # dlnorm(x, meanlog = 0, sdlog = 1, log = FALSE) # plnorm(q, meanlog = 0, sdlog = 1, lower.tail = TRUE, log.p = FALSE) # qlnorm(p, meanlog = 0, sdlog = 1, lower.tail = TRUE, log.p = FALSE) # rlnorm(n, meanlog = 0, sdlog = 1) # FUNCTION: # Settings: deriv = deriv[1] # Function: result = dlnorm(x, meanlog = meanlog, sdlog = sdlog) # First derivative, if desired: if (deriv == 1) { h1 = -(1/x + (log(x)-meanlog)/(sdlog^2*x)) result = result * h1 } # Second derivative, if desired: if (deriv == 2) { h1 = -(1/x + (log(x)-meanlog)/(sdlog^2*x)) h2 = -(-1/x^2 + (-1/x^2)*(log(x)-meanlog)/sdlog^2 + 1/(sdlog^2*x^2)) result = result * (h1^2 + h2) } # Return Value: result } # ------------------------------------------------------------------------------ plognorm = function(q, meanlog = 0, sdlog = 1) { # A function implemented by Diethelm Wuertz # Description: # Calculates the log-Normal probability. # Details: # Uses the function plnorm(). # See also: # dlnorm(x, meanlog = 0, sdlog = 1, log = FALSE) # plnorm(q, meanlog = 0, sdlog = 1, lower.tail = TRUE, log.p = FALSE) # qlnorm(p, meanlog = 0, sdlog = 1, lower.tail = TRUE, log.p = FALSE) # rlnorm(n, meanlog = 0, sdlog = 1) # FUNCTION: # Resul: result = plnorm(q = q, meanlog = meanlog, sdlog = sdlog) # Return Value: result } # ****************************************************************************** dgam = function(x, alpha, beta) { # A function implemented by Diethelm Wuertz # Description: # Calculates the Gamma density. # Details: # The function is a synonym to "dgamma". # See also: # dgamma(x, shape, rate=1, scale=1/rate, log = FALSE) # pgamma(q, shape, rate=1, scale=1/rate, lower.tail = TRUE, log = FALSE) # qgamma(p, shape, rate=1, scale=1/rate, lower.tail = TRUE, log = FALSE) # rgamma(n, shape, rate=1, scale=1/rate) # FUNCTION: # Return Value: dgamma(x = x, shape = alpha, scale = beta) } # ------------------------------------------------------------------------------ pgam = function(q, alpha, beta, lower.tail = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Calculates the Gamma probability. # Details: # The function is a synonym to "pgamma". # See also: # dgamma(x, shape, rate=1, scale=1/rate, log = FALSE) # pgamma(q, shape, rate=1, scale=1/rate, lower.tail = TRUE, log.p = FALSE) # qgamma(p, shape, rate=1, scale=1/rate, lower.tail = TRUE, log.p = FALSE) # rgamma(n, shape, rate=1, scale=1/rate) # FUNCTION: # Return Value: pgamma(q = q, shape = alpha, scale = beta, lower.tail = lower.tail) } # ------------------------------------------------------------------------------ drgam = function(x, alpha = 1, beta = 1, deriv = c(0, 1, 2)) { # A function implemented by Diethelm Wuertz # Description: # Calculates the reciprocal-Gamma density. # See also: # dgamma(x, shape, rate=1, scale=1/rate, log = FALSE) # pgamma(q, shape, rate=1, scale=1/rate, lower.tail = TRUE, log.p = FALSE) # qgamma(p, shape, rate=1, scale=1/rate, lower.tail = TRUE, log.p = FALSE) # rgamma(n, shape, rate=1, scale=1/rate) # FUNCTION: # Function Value: deriv = deriv[1] gr = dgamma(x = 1/x, shape = alpha, scale = beta) / (x^2) result = gr # First Derivative: if (deriv == 1) { h = function(x, alpha, beta) { -(alpha+1)/x + 1/(beta*x^2) } gr1 = gr*h(x, alpha, beta) result = gr1 } # Second Derivative: if (deriv == 2) { h = function(x, alpha, beta) { -(alpha+1)/x + 1/(beta*x^2) } h1 = function(x, alpha, beta) { +(alpha+1)/x^2 - 2/(beta*x^3) } gr2 = gr*(h(x, alpha, beta)^2 + h1(x, alpha, beta)) result = gr2 } # Return Value: result } # ------------------------------------------------------------------------------ prgam = function(q, alpha = 1, beta = 1, lower.tail = TRUE) { # A function implemented by Diethelm Wuertz # Description: # Calculates the reciprocal-Gamma probability # See also: # dgamma(x, shape, rate=1, scale=1/rate, log = FALSE) # pgamma(q, shape, rate=1, scale=1/rate, lower.tail = TRUE, log.p = FALSE) # qgamma(p, shape, rate=1, scale=1/rate, lower.tail = TRUE, log.p = FALSE) # rgamma(n, shape, rate=1, scale=1/rate) # FUNCTION: # Return Value: 1 - pgamma(q = 1/q, shape = alpha, scale = beta, lower.tail = lower.tail) } # ------------------------------------------------------------------------------ djohnson = function(x, a = 0, b = 1, c = 0, d = 1, deriv = c(0, 1, 2)) { # A function implemented by Diethelm Wuertz # Description: # Calculates the Johnson Type-I density. # FUNCTION: # Function Value: deriv = deriv[1] z = a + b * log( (x-c)/d ) z1 = b / (x-c) phi = dnorm(z, mean = 0, sd = 1) johnson = phi * z1 result = johnson # First Derivative: if (deriv == 1) { z2 = -b / (x-c)^2 johnson1 = phi * ( z2 - z*z1^2 ) result = johnson1 } # Second Derivative: if (deriv == 2) { z2 = -b / (x-c)^2 z3 = 2 * b / (x-c)^3 johnson2 = phi * ( - z*z1*z2 + z^2*z1^3 + z3 -z1^3 - 2*z*z1*z2 ) result = johnson2 } # Return Value: result } # ------------------------------------------------------------------------------ pjohnson = function(q, a = 0, b = 1, c = 0, d = 1) { # A function implemented by Diethelm Wuertz # Description: # Calculates the Johnson Type-I probability. # FUNCTION: # Type I: z = a + b * log( (q-c) / d ) # Return Value: pnorm(q = z, mean = 0, sd = 1) } ################################################################################ # MOMENTS FOR EBM DENSITY APPROXIMATIONS: mnorm = function(mean = 0, sd = 1) { # A function implemented by Diethelm Wuertz # Description: # Computes the moments for the Normal distribution. # FUNCTION: # Raw Moments: M = c( mean, mean^2+sd^2, mean*(mean^2+3*sd*2), mean^4+6*mean^2*sd^2+3*sd^4 ) # Centered Moments: m = M m[2] = M[2] - 2*M[1]*M[1] + M[1]^2 m[3] = M[3] - 3*M[2]*M[1] + 3*M[1]*M[1]^2 - M[1]^3 m[4] = M[4] - 4*M[3]*M[1] + 6*M[2]*M[1]^2 - 4*M[1]*M[1]^3 + M[1]^4 # Fischer Parameters - Skewness and Kurtosis: f = c(NA, NA) f[1] = m[3] / m[2]^(3/2) f[2] = m[4] / m[2]^2 - 3 # Return Value: list(rawMoments = M, centralMoments = m, fisher = f) } # ------------------------------------------------------------------------------ mlognorm = function(meanlog = 0, sdlog = 1) { # A function implemented by Diethelm Wuertz # Description: # Computes the moments for the Log-Normal distribution. # FUNCTION: # Raw Moments: n = 1:4 M = exp ( n * meanlog + n^2 * sdlog^2/2 ) # Centered Moments: m = M m[2] = M[2] - 2*M[1]*M[1] + M[1]^2 m[3] = M[3] - 3*M[2]*M[1] + 3*M[1]*M[1]^2 - M[1]^3 m[4] = M[4] - 4*M[3]*M[1] + 6*M[2]*M[1]^2 - 4*M[1]*M[1]^3 + M[1]^4 # Fischer Parameters - Skewness and Kurtosis: f = c(NA, NA) f[1] = m[3] / m[2]^(3/2) f[2] = m[4] / m[2]^2 - 3 # Return Value: list(rawMoments = M, centralMoments = m, fisher = f) } # ------------------------------------------------------------------------------ mrgam = function(alpha = 1/2, beta = 1) { # A function implemented by Diethelm Wuertz # Description: # Computes the moments for the Reciprocal-Gamma distribution. # FUNCTION: # Raw Moments: M = rep(0, times = 4) M[1] = 1 / (beta*(alpha - 1)) M[2] = M[1] / (beta*(alpha - 2)) M[3] = M[2] / (beta*(alpha - 3)) M[4] = M[3] / (beta*(alpha - 4)) # Centered Moments: m = M m[2] = M[2] - 2*M[1]*M[1] + M[1]^2 m[3] = M[3] - 3*M[2]*M[1] + 3*M[1]*M[1]^2 - M[1]^3 m[4] = M[4] - 4*M[3]*M[1] + 6*M[2]*M[1]^2 - 4*M[1]*M[1]^3 + M[1]^4 # Fischer Parameters - Skewness and Kurtosis: f = c(NA, NA) f[1] = m[3] / m[2]^(3/2) f[2] = m[4] / m[2]^2 - 3 # Return Value: list(rawMoments = M, centralMoments = m, fisher = f) } # ------------------------------------------------------------------------------ mjohnson = function(a, b, c, d) { # A function implemented by Diethelm Wuertz # Description: # Computes the moments for the Johnson Type-I distribution # FUNCTION: # Raw Moments: M = c(NA, NA, NA, NA) # Centered Moments: m = M m[2] = M[2] - 2*M[1]*M[1] + M[1]^2 m[3] = M[3] - 3*M[2]*M[1] + 3*M[1]*M[1]^2 - M[1]^3 m[4] = M[4] - 4*M[3]*M[1] + 6*M[2]*M[1]^2 - 4*M[1]*M[1]^3 + M[1]^4 # Fischer Parameters - Skewness and Kurtosis: f = c(NA, NA) f[1] = m[3] / m[2]^(3/2) f[2] = m[4] / m[2]^2 - 3 # Return Value: list(rawMoments = M, centralMoments = m, fisher = f) } # ------------------------------------------------------------------------------ masian = function(Time = 1, r = 0.045, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Description: # Computes the moments for the Asian-Option distribution # FUNCTION: # Raw Moments: M = .DufresneMoments(M = 4, Time = Time, r = r, sigma = sigma) # Centered Moments: m = M m[2] = M[2] - 2*M[1]*M[1] + M[1]^2 m[3] = M[3] - 3*M[2]*M[1] + 3*M[1]*M[1]^2 - M[1]^3 m[4] = M[4] - 4*M[3]*M[1] + 6*M[2]*M[1]^2 - 4*M[1]*M[1]^3 + M[1]^4 # Fischer Parameters - Skewness and Kurtosis: f = c(NA, NA) f[1] = m[3] / m[2]^(3/2) f[2] = m[4] / m[2]^2 - 3 # Return Value: list(rawMoments = M, centralMoments = m, fisher = f) } # ------------------------------------------------------------------------------ .DufresneMoments = function (M = 4, Time = 1, r = 0.045, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Description: # Computes raw moments for the Asian-Option distribution. # Note: # Called by function masian() # FUNCTION: # Internal Function: moments = function (M, tau, nu) { d = function(j, n, beta) { d = 2^n for (i in 0:n) if (i != j) d = d / ( (beta+j)^2 - (beta+i)^2 ) d } moments = rep(0, length = M) for (n in 1:M) { moments[n] = 0 for (j in 0:n) moments[n] = moments[n] + d(j, n, nu/2)*exp(2*(j^2+j*nu)*tau) moments[n] = prod(1:n) * moments[n] / (2^(2*n)) } moments } # Compute: tau = sigma^2*Time/4 nu = 2*r/sigma^2-1 ans = (4/sigma^2)^(1:M) * moments(M, tau, nu) # Return Value: ans } ################################################################################ derivative = function(x, y, deriv = c(1, 2)) { # A function implemented by Diethelm Wuertz # Description: # Calculates numerically the first or second derivative # of the functuin y(x) by finite differences. # Arguments: # x - a numeric vector of values # y - a numeric vectror of function values y(x) # deriv - the degree of differentiation, either 1 or 2. # FUNCTION: # Stop in the case of wrong argument deriv: dseriv = deriv[1] if (deriv < 1 || deriv > 2) stop("argument error") # Function to calculate the next derivative by differences: "calcderiv" = function(x,y) { list(x = x[2:length(x)]-diff(x)/2, y = diff(y)/diff(x))} # First Numerical Derivative: result = calcderiv(x, y) # Second Numerical Derivative, if desired: if (deriv == 2) result = calcderiv(result$x, result$y) # Return Value: list(x = result$x, y = result$y) } ################################################################################ d2EBM = function(u, t = 1) { # A function written by Diethelm Wuertz # Description: # Calculate the density integral "f_A_t(u)" given by # equation 4.36 in: R. Gould, "The Distribution of the # Integral of Exponential Brownian Motion". # Arguments: # t - numeric value # u - numeric value # FUNCTION: # Function to be integrated: f = function(x, tt, uu) { fx = rep(0, length=length(x)) for (i in 1:length(x) ) fx[i] = (1/uu) * exp(-(1+exp(2*x[i]))/(2*uu)) * .thetaEBM(r=exp(x[i])/uu, u=tt) fx } # Integrate: result = rep(0, length = length(u)) for (i in 1:length(u)) { result[i] = integrate(f, lower = -16, upper = 4, tt = t, uu = u[i], subdivisions = 100, rel.tol=.Machine$double.eps^0.25, abs.tol=.Machine$double.eps^0.25)$value } # Return Value: result } # ------------------------------------------------------------------------------ .thetaEBM = function(r, u) { # A function written by Diethelm Wuertz # Description: # Calculate the integral "\theta_r(u)" given by equations # 2.22 and 2.23 in: R. Gould, "The Distribution of the # Integral of Exponential Brownian Motion". # Arguments: # r - vector of numeric values # u - numeric value # FUNCTION: # Function to be integrated: f = function(x, rr, uu) { fx = rep(0, length = length(x)) for (i in 1:length(x) ) fx[i] = exp(-x[i]^2/(2*uu)) * exp(-rr*cosh(x[i])) * sinh(x[i]) * sin(pi*x[i]/uu) fx } # Loop over r-Vector: result = rep(0, length=length(r)) for ( i in 1: length(r) ) { result[i] = integrate(f, lower = 0, upper = 30, rr = r[i], uu = u, subdivisions = 100, rel.tol = .Machine$double.eps^0.25, abs.tol = .Machine$double.eps^0.25)$value result[i] = result[i] * (r/sqrt((2*u*pi^3))) * exp(pi^2/(2*u)) } # Return Value: result } # ------------------------------------------------------------------------------ .psiEBM = function(r, u) { # A function written by Diethelm Wuertz # Description: # Calculate the integral "\psi_r(u)" given by equations # 2.22 and 2.23 in: R. Gould, "The Distribution of the # Integral of Exponential Brownian Motion". # Arguments: # r - vector of numeric values # u - numeric value # FUNCTION: # Calculate psi() from theta(): result = sqrt(2*u*pi^3) * exp(-pi^2/(2*u)) * .thetaEBM(r, u) # Return Value: result } # ------------------------------------------------------------------------------ dEBM = function(u, t = 1) { # A function written by Diethelm Wuertz # Arguments; # t - a numeric value # u - a vector of numeric values # FUNCTION: # Calculate Density: result = rep(0, times = length(u)) for (i in 1:length(u) ) { result[i] = integrate(.gxtuEBM, lower = 0, upper = 100, t = t, u = u[i])$value } # Return Value: result } # ------------------------------------------------------------------------------ pEBM = function(u, t = 1) { # A function written by Diethelm Wuertz # Arguments; # t - a numeric value # u - a vector of numeric value # FUNCTION: # Calculate Probability: result = rep(0, times = length(u)) result[1] = integrate(dEBM, lower = 0, upper = u[1], t = t)$value if (length(u) > 1) { for (i in 2:length(u) ) { result[i] = result[i-1] + integrate( dEBM, lower = u[i-1], upper = u[i], t = t)$value } } # Return Value: result } # ------------------------------------------------------------------------------ .gxuEBM = function(x, u) { # A function written by Diethelm Wuertz # Description: # Interchange the Integrals - and first integrate: # 1/u^2 * sinh(x) * exp(-(1/(2*u))*(1+exp(2*x))) * exp(x) * # exp(-exp(x)*cosh(y)/u) # FUNCTION: # Compute g(x, u): fx = rep(0, length = length(x)) if (u > 0) { for ( i in 1:length(x) ) { su = (u)^(-3/2) * sinh(x[i]) cx = cosh(x[i])/sqrt(u) sx = sinh(x[i])/sqrt(u) Asymptotics = exp(x[i]) / sqrt(u) / 2 if (Asymptotics <= 33.0) { fx[i] = su * pnorm(-cx) / dnorm(sx) } else { fx[i] = su * exp(-1/(2*u)) * (1-1/cx^2+3/cx^4) / cx } } } # Return Value: fx } # ------------------------------------------------------------------------------ .gxtEBM = function(x, t) { # A function written by Diethelm Wuertz # Description: # FUNCTION: # Compute g(x, t): fx = exp(pi^2/(2*t)) / sqrt(2*t*pi^3) * exp(-x^2/(2*t)) # Return Value: fx } # ------------------------------------------------------------------------------ .gxtuEBM = function(x, t, u) { # A function written by Diethelm Wuertz # FUNCTION: # Result: fx = .gxtEBM(x = x, t = t) * .gxuEBM(x = x, u = u) * sin(pi*x/t) # Return Value: fx } # ------------------------------------------------------------------------------ dasymEBM = function(u, t = 1) { # A function written by Diethelm Wuertz # Description: # Calculates the asymptotic behavior of the density # function f of the exponential Brownian maotion # FUNCTION: # Asymptotic Density: alpha = log ( 8*u*exp(-2*t) ) beta = exp ( -((log(alpha/(4*t)))^2)/(8*t) ) f = sqrt(t) * exp(t/2) * exp(-alpha^2/(8*t)) * beta # Take care of gamma function ... warn = options()$warn options(warn = -1) # f = f / (u * sqrt(u) * alpha * gamma(alpha/(4 * t))) f = f / (u * sqrt(u) * (4*t) * gamma(alpha/(4 * t)+1)) f[is.na(f)] = 0 options(warn = warn) # Return Value: f } ################################################################################ fAsianOptions/R/EBMAsianOptions.R0000644000176200001440000016377011734074114016326 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR Description. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2004, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # MOMENT MATCHING: DESCRIPTION: # MomentMatchedAsianOption Valuate moment matched option prices # .LevyTurnbullWakemanAsianOption Log-Normal Approximation # .MilevskyPosnerAsianOption Reciprocal-Gamma Approximation # .PosnerMilevskyAsianOption Johnson Type I Approximation # MomentMatchedAsianDensity Valuate moment matched option densities # .LevyTurnbullWakemanAsianDensity Log-Normal Approximation # .MilevskyPosnerAsianDensity Reciprocal-Gamma Approximation # .PosnerMilevskyAsianDensity Johnson Type I Approximation # GRAM CHARLIER SERIES EXPANSION: DESCRIPTION: # GramCharlierAsianOption Calculate Gram-Charlier option prices # .GramCharlierAsianDensity NA # STATE SPACE MOMENTS: DESCRIPTION: # AsianOptionMoments Methods to calculate Asian Moments # .DufresneAsianOptionMoments Moments from Dufresne's Formula # .AbrahamsonAsianOptionMoments Moments from Abrahamson's Formula # .TurnbullWakemanAsianOptionMoments First 2 Moments from Turnbull-Wakeman # .TolmatzAsianOptionMoments Asymptotic Behavior after Tolmatz # STATE SPACE DENSITIES: DESCRIPTION: # StateSpaceAsianDensity NA # .Schroeder1AsianDensity NA # .Schroeder2AsianDensity NA # .Yor1AsianDensity NA # .Yor2AsianDensity NA # .TolmatzAsianDensity NA # .TolmatzAsianProbability NA # PARTIAL DIFFERENTIAL EQUATIONS: DESCRIPTION: # PDEAsianOption PDE Asian Option Pricing # .ZhangAsianOption Asian option price by Zhang's 1D PDE # ZhangApproximateAsianOption # .VecerAsianOption Asian option price by Vecer's 1D PDE # LAPLACE INVERSION: DESCRIPTION: # GemanYorAsianOption Asian option price by Laplace Inversion # gGemanYor Function to be Laplace inverted # SPECTRAL EXPANSION: DESCRIPTION: # LinetzkyAsianOption Asian option price by Spectral Expansion # gLinetzky Function to be integrated # BOUNDS ON OPTION PRICES: DESCRIPTION: # BoundsOnAsianOption Lower and upper bonds on Asian calls # CurranThompsonAsianOption From Thompson's continuous limit # RogerShiThompsonAsianOption From Thompson's single integral formula # ThompsonAsianOption Thompson's upper bound # SYMMETRY RELATIONS: DESCRIPTION: # CallPutParityAsianOption Call-Put parity Relation # WithDividendsAsianOption Adds dividends to Asian Option Formula # TABULATED RESULTS: DESCRIPTION: # FuMadanWangTable Table from Fu, Madan and Wang's paper # FusaiTaglianiTable Table from Fusai und tagliani's paper # GemanTable Table from Geman's paper # LinetzkyTable Table from Linetzky's paper # ZhangTable Table from Zhang's paper # ZhangLongTable Long Table from Zhang's paper # ZhangShortTable Short Table from Zhang's paper ################################################################################ ################################################################################ # MOMENT MATCHING: MomentMatchedAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30, table = NA, method = c("LN", "RG", "JI")) { # A function implemented by Diethelm Wuertz # Description: # Calculates price for Asian options based on moment matching # LN: Levy-Turnbull-Wakeman Log-Normal Approximation # RG: Milevsky-Posner Reciprocal-Gamma Approximation # JI: Posner-Milevski Johnson Type I Approximation # FUNCTION: # Set Default TypeFlag and Method, if no other is selected: TypeFlag = TypeFlag[1] method = method[1] # Test for Table: if (is.data.frame(table)) { S = table[,1] X = table[,2] Time = table[,3] r = table[,4] sigma = table[,5] } call = rep(0, length=length(S)) # Log-Normal Approximation: if (method == "LN") { for ( i in 1:length(S) ) { moments = masian(Time = Time[i], r = r[i], sigma = sigma[i])$rawMoments moments = moments / Time[i]^(1:4) meanlog = ( 2*log(moments[1]) - log(moments[2])/2 ) sdlog = ( sqrt ( log(moments[2]) - 2*log(moments[1]) ) ) d2 = ( -log(X[i]/S[i]) + meanlog*Time[i] ) / ( sdlog*sqrt(Time[i]) ) d1 = d2 + sdlog*sqrt(Time[i]) call[i] = moments[1]*pnorm(d1)-(X[i]/S[i])*pnorm(d2) } } # Reciprocal-Gamma Approximation: if (method == "RG") { for ( i in 1:length(S) ) { moments = masian(Time = Time[i], r = r[i], sigma = sigma[i])$rawMoments moments = moments / Time[i]^(1:4) alpha = (2*moments[2] - moments[1]^2) / (moments[2] - moments[1]^2) beta = (moments[2] - moments[1]^2) / (moments[1]*moments[2]) call[i] = moments[1]*pgamma(S[i]/X[i], shape=alpha-1, scale=beta) - (X[i]/S[i])*pgamma(S[i]/X[i], shape=alpha, scale=beta) } } # Johnson-Type-I Approximation: if (method == "JI") { for ( i in 1:length(S) ) { cmoments = masian(Time = Time[i], r = r[i], sigma = sigma[i])$centralMoments cmoments = cmoments / Time[i]^(1:4) mu = cmoments[1] varsigma = sqrt(cmoments[2]) eta = cmoments[3] / varsigma^3 omega = 0.5 * ( 8 + 4*eta^2 + 4*sqrt(4*eta^2+eta^4) )^(1/3) omega = omega + 1/omega - 1 b = 1 / sqrt(log(omega)) a = 0.5 * b * log(omega*(omega-1)/varsigma^2) d = sign(eta) c = d*mu - exp( (0.5/b-a)/b ) Q = a + b*log((X[i]/S[i]-c)/d) call[i] = mu - X[i]/S[i] + (X[i]/S[i] - c) * pnorm( Q ) - d * exp ( (1-2*a*b)/(2*b^2) ) * pnorm ( Q - 1/b ) } } # Call Price: Price = S* exp(-r*Time) * call # Put Price: if (TypeFlag == "p") { Parity = (1/(r*Time))*(1-exp(-r*Time))*S - exp(-r*Time)*X Price = Price - Parity } # Return Value: option = list( price = Price, call = match.call() ) class(option) = "option" option } # ------------------------------------------------------------------------------ .LevyTurnbullWakemanAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Return Value: MomentMatchedAsianOption(TypeFlag[1], S, X, Time, r, sigma, method = "LN") } # ------------------------------------------------------------------------------ .MilevskyPosnerAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Return Value: MomentMatchedAsianOption(TypeFlag[1], S, X, Time, r, sigma, method = "RG") } # ------------------------------------------------------------------------------ .PosnerMilevskyAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Return Value: MomentMatchedAsianOption(TypeFlag[1], S, X, Time, r, sigma, method = "JI") } # ------------------------------------------------------------------------------ MomentMatchedAsianDensity = function(x, Time = 1, r = 0.09, sigma = 0.30, method = c("LN", "RG", "JI")) { # A function implemented by Diethelm Wuertz # Description: # Calculates price for Asian options based on moment matching # LN: Levy-Turnbull-Wakeman Log-Normal Approximation # RG: Milevsky-Posner Reciprocal-Gamma Approximation # JI: Posner-Milevski Johnson Type I Approximation # FUNCTION: # Set Default Method, if no other is selected: method = method[1] # Log-Normal Approximation: if (method == "LN") { moments = masian(Time = Time, r = r, sigma = sigma)$rawMoments moments = moments / Time^(1:4) meanlog = 2*log(moments[1]) - log(moments[2])/2 sdlog = sqrt ( log(moments[2]) - 2*log(moments[1]) ) density = dlnorm(x = x, meanlog = meanlog, sdlog = sdlog) } # Reciprocal-Gamma Approximation: if (method == "RG") { moments = masian(Time = Time, r = r, sigma = sigma)$rawMoments moments = moments / Time^(1:4) alpha = (2*moments[2] - moments[1]^2) / (moments[2] - moments[1]^2) beta = (moments[2] - moments[1]^2) / (moments[1]*moments[2]) density = drgam(x = x, alpha = alpha, beta = beta) } # Johnson Type I Approximation: if (method == "JI") { cmoments = masian(Time = Time, r = r, sigma = sigma)$centralMoments cmoments = cmoments / Time^(1:4) mu = cmoments[1] varsigma = sqrt(cmoments[2]) eta = cmoments[3] / varsigma^3 omega = 0.5 * ( 8 + 4*eta^2 + 4*sqrt(4*eta^2+eta^4) )^(1/3) omega = omega + 1/omega - 1 b = 1 / sqrt(log(omega)) a = 0.5 * b * log(omega*(omega-1)/varsigma^2) d = sign(eta) c = d*mu - exp( (0.5/b-a)/b ) density = djohnson(x = x, a = a, b = b, c = c, d = d) } # Return Value: density } # ------------------------------------------------------------------------------ .LevyTurnbullWakemanAsianDensity = function(x, Time = 1, r = 0.09, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Return Value: MomentMatchedAsianDensity(x, Time, r, sigma, method = "LN") } # ------------------------------------------------------------------------------ .MilevskyPosnerAsianDensity = function(x, Time = 1, r = 0.09, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Return Value: MomentMatchedAsianDensity(x, Time, r, sigma, method = "RG") } # ------------------------------------------------------------------------------ .PosnerMilevskyAsianDensity = function(x, Time = 1, r = 0.09, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Return Value: MomentMatchedAsianDensity(x, Time, r, sigma, method = "JI") } ################################################################################ # GRAM CHARLIER: GramCharlierAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30, table = NA, method = c("LN", "RG", "JI")) { # A function implemented by Diethelm Wuertz # Description: # Calculate arithmetic Asian options price using # Gram Charlier Statistical Series Expansion around # LN: Log-Normal Distribution # RG: Reciprocal-Gamma Distribution # JI: Johnson-Type-I Distribution # FUNCTION: # Select Method: TypeFlag = TypeFlag[1] method = method[1] # Test for Table: if (is.data.frame(table)) { S = table[,1] X = table[,2] Time = table[,3] r = table[,4] sigma = table[,5] } # Calculate Price: Price = MomentMatchedAsianOption("c", S = S, X = X, Time = Time, r = r, sigma = sigma, method=method)$price gc3 = gc4 = rep(0, length(Price)) # Log-Normal Approximation: if (method == "LN") { for ( i in 1:length(S) ) { moments = masian(Time[i], r[i], sigma[i])$rawMoments/Time[i]^(1:4) meanlog = 2*log(moments[1]) - log(moments[2])/2 sdlog = sqrt ( log(moments[2]) - 2*log(moments[1]) ) asian.cm = masian(Time[i], r[i], sigma[i])$centralMoments/Time[i]^(1:4) lnorm.cm = mlognorm(meanlog, sdlog)$centralMoments/Time[i]^(1:4) kappa = (asian.cm-lnorm.cm) gc3[i] = kappa[3]*dlognorm(X[i]/S[i], meanlog, sdlog, deriv=1)/6 gc4[i] = kappa[4]*dlognorm(X[i]/S[i], meanlog, sdlog, deriv=2)/24 } } # Reciprocal-Gamma Approximation: if (method == "RG" ) { for ( i in 1:length(S) ) { moments = masian(Time[i], r[i], sigma[i])$rawMoments/Time[i]^(1:4) alpha = (2*moments[2] - moments[1]^2) / (moments[2] - moments[1]^2) beta = (moments[2] - moments[1]^2) / (moments[1]*moments[2]) asian.cm = masian(Time[i], r[i], sigma[i])$centralMoments/Time[i]^(1:4) rgam.cm = mrgam(alpha, beta)$centralMoments/Time[i]^(1:4) kappa = (asian.cm-rgam.cm) gc3[i] = kappa[3]*drgam(X[i]/S[i], alpha, beta, deriv = 1)/6 gc4[i] = kappa[4]*drgam(X[i]/S[i], alpha, beta, deriv = 2)/24 } } # Johnson-Type-I Approximation: if (method == "JI" ) { for ( i in 1:length(S) ) { cmoments = masian(Time = Time[i], r = r[i], sigma = sigma[i])$centralMoments cmoments = cmoments / Time[i]^(1:4) mu = cmoments[1] varsigma = sqrt(cmoments[2]) eta = cmoments[3] / varsigma^3 omega = 0.5 * ( 8 + 4*eta^2 + 4*sqrt(4*eta^2+eta^4) )^(1/3) omega = omega + 1/omega - 1 b = 1 / sqrt(log(omega)) a = 0.5 * b * log(omega*(omega-1)/varsigma^2) d = sign(eta) c = d*mu - exp( (0.5/b-a)/b ) asian.cm = cmoments johnson.cm = cmoments skewness = sqrt((omega-1)*(omega+2)^2) kurtosis = omega^4 + 2*omega^3 + 3* omega^2 - 3 johnson.cm[3] = skewness * varsigma^3 johnson.cm[4] = kurtosis * varsigma^4 kappa = (asian.cm-johnson.cm) gc3[i] = kappa[3]*djohnson(X[i]/S[i], a, b, c, d, deriv = 1)/6 gc4[i] = kappa[4]*djohnson(X[i]/S[i], a, b, c, d, deriv = 2)/24 } } # Gram-Charlier Approximated Call Price: Price = Price - S * exp(-r*Time) * (gc3-gc4) # Put Price: if (TypeFlag == "p") { Parity = (1/(r*Time))*(1-exp(-r*Time))*S - exp(-r*Time)*X Price = Price - Parity } # Return Value: option = list( price = Price, call = match.call() ) class(option) = "option" option } .GramCharlierAsianDensity = function(Time = 1, r = 0.09, sigma = 0.30, method = c("LN", "RG", "JI")) { # A function ported by Diethelm Wuertz # Return Value: NA } ################################################################################ # STATE SPACE MOMENTS: AsianOptionMoments = function(M = 4, Time = 1, r = 0.045, sigma = 0.30, log = FALSE, method = c("A", "D", "TW", "T")) { # A function implemented by Diethelm Wuertz # Description: # Calculates Asian Moments using several approaches: # A - Moments from Abrahamson's Formula # D - Moments from Dufresne's Formula # TW - First 2 Moments from Turnbull-Wakeman # T - Asymptotic Behavior after Tolmatz # FUNCTION: # Settings: method = method[1] result = NA # Abrahamson Formula: if (method == "A") result = .AbrahamsonAsianOptionMoments(M = M, Time = Time, r = r, sigma = sigma) # Dufresne Formula: if (method == "D") result = .DufresneAsianOptionMoments(M = M, Time = Time, r = r, sigma = sigma) # Tolmatz Formula - Asymptotic Behavior: if (method == "T") result = .TolmatzAsianOptionMoments(M = M, Time = Time, r = r, sigma = sigma, log = log) # Turnbull Wakeman - Explicit 1st and Second Moment: if (method == "TW") result = .TurnbullWakemanAsianOptionMoments(M = M, Time = Time, r = r, sigma = sigma) # Return Value: result } # ------------------------------------------------------------------------------ .DufresneAsianOptionMoments = function(M = 4, Time = 1, r = 0.045, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Description: # Calculates Moments of Asian Options Density # according to the formula of Dufresne-GemanYor # FUNCTION: # Calculates: E[(A_\tau^{(\nu)})^n] moments = function (M, tau, nu) { d = function(j, n, beta) { d = 2^n for (i in 0:n) if (i != j) d = d / ( (beta+j)^2 - (beta+i)^2 ) d } moments = rep(0, length=M) for (n in 1:M) { moments[n] = 0 for (j in 0:n) moments[n] = moments[n] + d(j, n, nu/2)*exp(2*(j^2+j*nu)*tau) moments[n] = prod(1:n) * moments[n] / (2^(2*n)) } moments } # Calculate for: tau = sigma^2*Time/4 nu = 2*r/sigma^2-1 # Return Value: (4/sigma^2)^(1:M) * moments(M, tau, nu) } # ------------------------------------------------------------------------------ .AbrahamsonAsianOptionMoments = function (M = 4, Time = 1, r = 0.045, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Description: # Calculates Moments of Asian Options Density # according to the formula of Abrahamson # FUNCTION: # Calculates: E[(A_\tau^{(\nu)})^n] moments = function (M, tau, nu) { moments = rep(0, times = M) for (N in 1:M) { d = c = 2 * ( (1:N)^2 + (1:N)*nu ) for (m in 1:N) { for (j in 1:N) { if (j!= m) d[m] = d[m]*(c[m]-c[j]) } d[m] = exp(c[m]*tau) / d[m] } moments[N] = prod(1:N) * ( sum(d) + (-1)^N/prod(c) ) } moments } # Calculate for: tau = sigma^2*Time/4 nu = 2*r/sigma^2-1 # Return Value: (4/sigma^2)^(1:M) * moments(M, tau, nu) } # ------------------------------------------------------------------------------ .TurnbullWakemanAsianOptionMoments = function (M = 2, Time = 1, r = 0.045, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Description: # Calculates the first two moments as derived explicitly # by Turnbull and Wakeman. It can serve as a test for # other implementations. # Note: # Maximum M is 2! # FUNCTION: # Moments: moments = rep(NA, times = M) if (M == 1 || M == 2) moments[1] = (exp(r*Time)-1)/(r*Time) if (M == 2) moments[2] = 2*exp((2*r+sigma^2)*Time)/ ((r+sigma^2)*(2*r+sigma^2)*Time^2) + (2/(r*Time^2)) * ( 1/(2*r+sigma^2) - exp(r*Time)/(r+sigma^2) ) # Return Value: moments } # ------------------------------------------------------------------------------ .TolmatzAsianOptionMoments = function (M = 100, Time = 1, r = 0.045, sigma = 0.30, log = FALSE) { # A function implemented by Diethelm Wuertz # Description: # Calculates Asymptotic Moments of Asian Options Density # according to the formula of Tolmatz for nu=0 and Wuertz # for nu different from zero - Log returns can be selected # FUNCTION: # Calculates: log { E[(A_\tau^{(\nu)})^n] } moments = function (M, tau, nu=0) { moments = rep(0, times=M) M = 1:M log.moments = -M*log(2) + lgamma(nu+M) - lgamma(nu+2*M) + 2*(M^2+M*nu)*tau log.moments } # Calculate for: tau = sigma^2*Time/4 nu = 2*r/sigma^2-1 # Return Value: moments = (1:M)*log(4/sigma^2) + moments(M, tau, nu) # Return value: if (!log) moments = exp(moments) moments } ################################################################################ # ASIAN DENSITY: # STATE SPACE DENSITIES: DESCRIPTION: # StateSpaceAsianDensity # .Schroeder1AsianDensity S1 # .Schroeder2AsianDensity S2 # .Yor1AsianDensity Y1 # .Yor2AsianDensity Y2 # .TolmatzAsianDensity T # .TolmatzAsianProbability ################################################################################ # PDE SOLVER: ZhangAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30, table = NA, correction = TRUE, nint = 800, eps = 1.0e-8, dt = 1.0e-10) { # A function implemented by Diethelm Wuertz # Description: # Valuates Asian options by Solving Zhang's one # dimensional Partial Differential Equations # Source: # For the Fortran Routine: # TOMS ... # FUNCTION: # Settings: TypeFlag = TypeFlag[1] # Test for Table: if (is.data.frame(table)) { S = table[, 1] X = table[, 2] Time = table[, 3] r = table[, 4] sigma = table[, 5] } Price = rep(0, times = length(S)) # Set Model Identifier: modsel = 2 # Option Parameters: if (TypeFlag == "c") z = +1 if (TypeFlag == "p") z = -1 # PDE Parameters - Do not change: T0 = 0; Tout = 1 np = 0; Price.by.S = 0 mf = 12 npde = 1; kord = 4; ncc = 2; maxder = 5 # Fill Working Arrays: xbkpt = rep(0, times = nint+1) length.work = kord+npde*(4+9*npde)+(kord+(nint-1)*(kord-ncc)) * (3*kord+2+npde*(3*(kord-1)*npde+maxder+4)) work = rep(0, times = length.work) length.iwork = (npde+1)*(kord+(nint-1)*(kord-ncc)) iwork = rep(0, times = length.iwork) # Compute Prices: for ( i in 1:length(S) ) { result = .Fortran("asianval", as.double(z), as.double(S[i]), as.double(X[i]), as.double(X[i]), as.double(X[i]), as.double(Time[i]), as.double(r[i]), as.double(sigma[i]), as.double(T0), as.double(Tout), as.double(eps), as.double(dt), as.double(Price.by.S), as.integer(np), as.integer(modsel), as.integer(mf), as.integer(npde), as.integer(kord), as.integer(nint), as.integer(ncc), as.integer(maxder), as.double(X[i]/S[i]), as.double(xbkpt), as.double(work), as.integer(iwork), PACKAGE = "fAsianOptions" ) Price[i] = result[[13]]*S[i] } # ? Price = Price + ZhangApproximateAsianOption(TypeFlag, S, X, Time, r, sigma, table) # Return Value: Price } ZhangApproximateAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30, table = NA) { # Settings: TypeFlag = TypeFlag[1] # Test for Table: if (is.data.frame(table)) { S = table[, 1] X = table[, 2] Time = table[, 3] r = table[, 4] sigma = table[, 5] } # Compute: I = 0 xi = (Time*X-I)*exp(-r*Time)/S - (1-exp(-r*Time))/r eta = (sigma^2/(4*r^3)) * (-3 + 2*r*Time + 4*exp(-r*Time) - exp(-2*r*Time)) # Call: price = (S/Time) * ( -xi * pnorm(-xi/sqrt(2*eta)) + sqrt(eta/pi)*exp(-xi^2/(4*eta)) ) if (TypeFlag == "c") { ans = price } else { ans = CallPutParityAsianOption(TypeFlag = "c", price, S, X, Time, sigma, r, table = table) } # Return Value: ans } # ------------------------------------------------------------------------------ VecerAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30, table = NA, nint = 800, eps = 1.0e-8, dt = 1.0e-10) { # A function implemented by Diethelm Wuertz # Description: # Valuates Asian options by Solving Vecer's one # dimensional Partial Differential Equations # FUNCTION: # Vecer's PDE modeled by: modsel == 1 # SUBROUTINE ASIANVAL( # ZZ, SS, XS, XSMIN, XSMAX, TIME, RR, SIGMA, # T0, TOUT, EPS, DT, PRICEBYS, NP, MODSEL, # MF1, NPDE1, KORD1, MX1, NCC1, MAXDER1, # XBYS, XBKPT, WORK, IWORK) # Settings: TypeFlag = TypeFlag[1] # Test for Table: if (is.data.frame(table)) { S = table[, 1] X = table[, 2] Time = table[, 3] r = table[, 4] sigma = table[, 5] } Price = rep(0, times = length(S)) # Set Model Identifier: modsel = 1 # Option Parameters: if (TypeFlag == "c") z = +1 if (TypeFlag == "p") z = -1 # PDE Parameters - Do not change: T0 = 0 Tout = 1 np = 0 Price.by.S = 0 mf = 12 npde = 1 kord = 4 ncc = 2 maxder = 5 # Fill Working Arrays: xbkpt = rep(0, times = nint+1) length.work = kord+npde*(4+9*npde)+(kord+(nint-1)*(kord-ncc)) * (3*kord+2+npde*(3*(kord-1)*npde+maxder+4)) work = rep(0, times = length.work) length.iwork = (npde+1)*(kord+(nint-1)*(kord-ncc)) iwork = rep(0, times = length.iwork) # Compute Prices: for ( i in 1:length(S) ) { result = .Fortran("asianval", as.double(z), as.double(S[i]), as.double(X[i]), as.double(X[i]), as.double(X[i]), as.double(Time[i]), as.double(r[i]), as.double(sigma[i]), as.double(T0), as.double(Tout), as.double(eps), as.double(dt), as.double(Price.by.S), as.integer(np), as.integer(modsel), as.integer(mf), as.integer(npde), as.integer(kord), as.integer(nint), as.integer(ncc), as.integer(maxder), as.double(X[i]/S[i]), as.double(xbkpt), as.double(work), as.integer(iwork), PACKAGE = "fAsianOptions" ) Price[i] = result[[13]]*S[i] } # Return Value: Price } ################################################################################ # LAPLACE INVERSION: gGemanYor = function(lambda, S = 100, X = 100, Time = 1, r = 0.05, sigma = 0.30, log = FALSE, doplot = FALSE) { # A function written by Diethelm Wuertz # Description: # Calculates function to be Laplace inverted # Arguments: # lambda - complex vector # Notes: # Equation 4.9 with notation as in # Sudler G.F. [1999], "Asian Options: Inverse Laplace # Transform and Martingale Methods Revisited". # FUNCTION: # Settings: x = lambda g = rep(complex(real = 0, imaginary = 0), length = length(x)) # Calculate for each lambda value from Kummer Function: # Note Kummer function is not vectorized in Indexes ! for ( i in 1:length(x) ) { # Settings: nu = 2*r/(sigma^2) - 1 mu = sqrt(2*lambda[i] + nu^2) q = (sigma^2)*X*Time/(4*S) gamma1 = (mu-nu)/2 gamma2 = (mu+nu)/2 # Convergence Parameters: a = gamma1-2 + 1 b = gamma2+1 + a + 1 z = -1/(2*q) # From Kummer Function [one of ...]: # Use logarithmic Kummer and Gamma Functions to prevent # from numerical overflow! g[i] = kummerM(-z, b-a, b, lnchf = 1) + a*log(-z) + z + cgamma(b-a, log = TRUE) - cgamma(b, log = TRUE) - log (lambda[i]*(lambda[i] - 2 - 2 * nu)) if (!log) g[i] = exp(g[i]) } # Plot function if desired: if (doplot) { if (!is.complex(lambda)) { lam = lambda xlab = "lambda" ylab = "g" } else { lam = Im(lambda) xlab = "Im(lambda)" ylab = "Re(g)" } lambda.min = 4*r/sigma^2 cat("\nmin lambda:", lambda.min, "\n") # Function to be Laplace inverted: print(cbind(lambda, g)) plot(lam, Re(g), type = "l", main = "Laplace Inverse", xlab = xlab, ylab = ylab) lines(lam, 0*Re(g)) # Convergence Indexes: mu = sqrt(2*lambda + nu^2) gamma1 = (mu-nu)/2; a = Re(gamma1-2 + 1) gamma2 = (mu+nu)/2; b = Re(gamma2+1 + a + 1) plot(lam, b, ylim = c(min(c(a,b)), max(c(a,b))), type = "n", xlab = xlab, ylab = "a b", main = "Convergence Indexes") lines(lam, a, col = "red") lines(lam, b, col = "blue") lines(lam, 0*b, type = "l", col = "black") lines(x = lambda.min*c(1,1), y = c( min(c(a,b)), max(c(a,b)) ) ) } # Return Value: g } # ------------------------------------------------------------------------------ GemanYorAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30, doprint = FALSE) { # A function written by Diethelm Wuertz # Description: # Valuate Asian options by Laplace inversion. # FUNCTION: # Parameters: TypeFlag = TypeFlag[1] nu = (2*r)/(sigma^2) - 1 alpha = 1 / sigma^2 * (2*nu + 2) h = sigma^2*Time/4 # Function to be inverted: fx = function(x, S, X, Time, roh, sigma) { nu = (2*roh)/(sigma^2) - 1 alpha = 1 / sigma^2 * (2*nu + 2) h = sigma^2*Time/4 zi = complex(real = 0, imaginary = x) zc = complex(real = alpha, imaginary = x) g2 = gGemanYor(lambda = zc, S = S, X = X, Time = Time, r = roh, sigma = sigma, log = TRUE) # Return Value: Re ( exp(zi*h + g2) / (2*pi) ) } # Call: # Integrate stepwise until (hopefully) convergence is reached: q = (sigma^2)*X*Time/(4*S) delta = 10/(2*q) eps = 1.0e-20 if (doprint) { cat("\nDelta:", delta) cat("\nS:", S, "X:", X) cat("\nTime:", Time, "r:", r, "sigma:", sigma, "\n") } i = 1 I = integrate(fx, lower = 0, upper = delta, S = S, X = X, Time=Time, roh = r, sigma = sigma) Price = Increment = exp(-r*Time)*(S/h)*exp(alpha*h)*2*I$value while (abs(Increment)/abs(Price) > eps) { i = i+1 I = integrate(fx, lower = (i-1)*delta, upper = i*delta, S = S, X = X, Time = Time, roh = r, sigma = sigma) Increment = exp(-r*Time)*(S/h)*exp(alpha*h)*2*I$value Price = Price + Increment if (doprint) print(c(i*delta, Price, Increment)) } # Put: # Use Call-Put Parity: if (TypeFlag == "p") { Parity = (1/(r*Time))*(1-exp(-r*Time))*S - exp(-r*Time)*X Price = Price - Parity } # Return Value: option = list( price = Price, call = match.call() ) class(option) = "option" option } ################################################################################ # SPECTRAL EXPANSION: gLinetzky = function(x, y, tau, nu, ip = 0) { # A function implemented by Diethelm Wuertz # Description: # Calculates the function to be integrated for the Put Price # in the expression for the spectral representation of # $ P^{(\nu)} (k, \tau) $. Proposition 2 described bu eq. (16) # Note: # Requires Confluent Hypergeometric Functions # Reference: # [L] V. Linetzky, Spectral Expansions for Asian (Average Price) # Options, Preprint, revised Version from October 2002 # Function: result = V = rep(0, length = length(x)) for (i in 1:length(x)) { p = x[i] if (p == 0) { result[i] = 0 } else { z = 1/(2*y) kappa = -(nu+3)/2 mu = complex(real = 0, imaginary = p/2) # V1 = exp( -(nu^2+p^2)*tau/2 ) * z^kappa * exp(-z/2) logV1 = -(nu^2+p^2)*tau/2 + kappa*log(z) - z/2 # V2 = (abs(cgamma(nu/2+mu)))^2 if (p < 100) { logV2 = log ( (abs(cgamma(nu/2+mu)))^2 ) } else { # Shift by Pi - Take of the proper Phi g = cgamma(nu/2+mu, log = TRUE) r = abs(g) phi = atan(Im(g)/Re(g)) + pi logV2 = 2*r*cos(phi) } # V3 = sinh(pi*p) * p logV3 = pi*p + log(1/2 - exp(-2*pi*p)/2) + log(p) # Whittaker: if (p < 100) { V4 = Re ( whittakerW(z, kappa, mu, ip ) ) } else { # Use: 2 * Re ( (cgamma(-2*mu)/cgamma(1/2-mu-kappa)) * # exp(-z/2) * z^(1/2+mu) * kummerM(z, 1/2+mu-kappa, 1+2*mu) g = log(2) + cgamma(-2*mu, log=TRUE) - cgamma(1/2-mu-kappa, log=TRUE) - z/2 +(1/2+mu)*log(z) + kummerM(z, 1/2+mu-kappa, 1+2*mu, lnchf=1, ip=ip) r = abs(g) # Shift by Pi - Take of the proper Phi phi = atan(Im(g)/Re(g)) + pi logV4 = r*cos(phi) argV4 = cos(r*sin(phi)) } # Collect all terms: if ( p < 100) { result[i] = exp(logV1+logV2+logV3)*V4/(8*pi^2) } else { result[i] = exp(logV1+logV2+logV3+logV4)*argV4/(8*pi^2) } # print(c(p, logV5, logV5a, argV5, argV5a)) } } # Return Value: result } # ------------------------------------------------------------------------------ LinetzkyAsianOption = function(TypeFlag = c("c", "p"), S = 2, X = 2, Time = 1, r = 0.02, sigma = 0.1, table = NA, lower = 0, upper = 100, method = "adaptive", subdivisions = 100, ip = 0, doprint = TRUE, doplot = TRUE,...) { # A function implemented by Diethelm Wuertz # Test for Table: if (is.data.frame(table)) { S = table[,1] X = table[,2] Time = table[,3] r = table[,4] sigma = table[,5] } if (doprint) print(cbind(S, X, Time, r, sigma)) Price = rep(0, length=length(S)) # Settings: tau = sigma^2*Time/4 k = tau*X/S nu = 2*r/sigma^2 - 1 if (doprint) print(cbind(k, tau, nu)) # Parameters: z = 1 / (2*k) kappa = -(nu+3)/2 mu.max = upper/2 if (doprint) print(cbind(z, kappa, mu.max)) # Calculate Spectral Measure: P = P1 = rep(0, times=length(S)) for (i in 1:length(S)) { if (method == "adaptive") { P[i] = integrate(gLinetzky, lower = lower, upper = upper, y = k[i], tau = tau[i], nu = nu[i], ip = ip, subdivisions = subdivisions, rel.tol = .Machine$double.eps^0.25, abs.tol = .Machine$double.eps^0.25, stop.on.error = FALSE)$value } if (method == "trapez") { x = seq(lower, upper, length = subdivisions+1) delta = (upper-lower)/subdivisions F = gLinetzky(x = x, y = k[i], tau[i], nu[i]) # print(c(F[1], F[length(F)], min(F), max(F))) P[i] = ( sum(F)-(F[1]+F[length(F)])/2 ) * delta } if (method == "simpson") { x = seq(lower, upper, length = subdivisions+1) delta = (upper-lower)/subdivisions F = gLinetzky(x = x, y = k[i], tau = tau[i], nu = nu[i], ip = ip) # print(c(F[1], F[length(F)], min(F), max(F))) FF = matrix(F[2:length(F)], byrow = TRUE, ncol = 2) P[i] = (F[1]+4*sum(FF[,1])+2*sum(FF[,2])-F[length(F)]) * delta[i]/3 } # For nu < 0 add: P1[i] = 0 if (nu[i] < 0) { z = 1/(2*k[i]) P1[i] = (2*k[i]*pgamma(abs(nu[i]), z) - pgamma(abs(nu[i])-1, z)) / ( 2 * gamma(abs(nu[i])) ) P[i] = P[i] + P1[i] } # Plot: if (doplot) { x = seq(lower, upper, length = subdivisions) F = gLinetzky(x = x, y = k[i], tau = tau[i], nu = nu[i]) plot(x, F, type = "l") lines(x, 0*x, col = "red") lines(x, F) } } if (doprint) print(cbind(P, P1)) # Derive Call/Put Price: # Put Price: Linetzky = exp(-r*Time) * (S/tau) * P # Call Price: if (TypeFlag == "c") { Linetzky = Linetzky + S*(1-exp(-r*Time))/(r*Time) - X*exp(-r*Time) } # Return Value: option = list( price = Linetzky, call = match.call() ) class(option) = "option" option } ################################################################################ # ASIAN BOUNDS: # Note: # We have not implemented the formula for the upper bound derived # by Rogers and Shi. Thompson's upper bound formula is much more # precise and therefore we have concentrated ourself on their # approach. BoundsOnAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30, table = NA, method = c("CT", "RST", "T")) { # A function implemented by Diethelm Wuertz # Description: # Calculates Bounds on Asian Option Prices # CT - Curran-Thompson Lower Bound # RST - Roger-Shi-Thompson Lower Bound # T - Thompson Upper Bound # FUNCTION: # Set Default Method, if no other is selected: TypeFlag = TypeFlag[1] if (length(method) == 3) method = "T" # Test for Table: if (is.data.frame(table)) { S = table[,1] X = table[,2] Time = table[,3] r = table[,4] sigma = table[,5] } Price = rep(NA, length = length(S)) # Curran-Thompson Lower Bound: if (method == "CT") { for ( i in 1:length(S) ) { Price[i] = CurranThompsonAsianOption(TypeFlag=TypeFlag, S=S[i], X=X[i], Time[i], r=r[i], sigma[i])$price } } # Roger-Shi-Thompson Lower Bound: if (method == "RST") { for ( i in 1:length(S) ) { Price[i] = RogerShiThompsonAsianOption(TypeFlag=TypeFlag, S = S[i], X = X[i], Time[i], r = r[i], sigma[i])$price } } # Thompson Upper Bound: if (method == "T") { for ( i in 1:length(S) ) { Price[i] = ThompsonAsianOption(TypeFlag = TypeFlag, S = S[i], X = X[i], Time[i], r = r[i], sigma[i])$price } } # Return Value: option = list( price = Price, call = match.call() ) class(option) = "option" option } # ------------------------------------------------------------------------------ CurranThompsonAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Description: # Calculates "lower bound" for Asian Call Option from # Thompson's formula describing the continuous limit # of Curran's approximation. # Note: # Rescale sigma: # Note the formula of Thompson work for Time=1 only! # Thus the easiest way to cover times to maturity different # from unity can be achieved by scale the volatility and # interest rate! - Just do it # FUNCTION: # Settings: TypeFlag = TypeFlag[1] sigma = sigma*sqrt(Time) r = r*Time Time = 1 # Settings: alpha = r - 0.5*sigma^2 # Solve for gamma star: f1 = function(x, S, X, alpha, sigma) { exp( 3 * ( log(X/S)-alpha/2 ) * x *(1-x/2) + alpha * x + 0.5 * sigma^2 * (x-3*x^2*(1-x/2)^2) ) } # Integrate: gs = integrate(f1, lower = 0, upper = 1, S = S, X = X, alpha = alpha, sigma = sigma, subdivisions = 1000, rel.tol = .Machine$double.eps^0.5, abs.tol = .Machine$double.eps^0.5)$value # Final Calculate: g.star = ( log(2*X/S-gs) - alpha/2 ) / sigma # Solve for lower bound: f = function(x, g.star, alpha, sigma) { time = x arg = (-g.star + sigma*time*(1-time/2))*sqrt(3) f = exp( (alpha+sigma^2/2)*time ) * pnorm(arg) f } # Integrate: value = integrate(f, lower=0, upper=1, g.star=g.star, alpha=alpha, sigma=sigma, subdivisions=1000, rel.tol=.Machine$double.eps^0.5, abs.tol=.Machine$double.eps^0.5)$value # Call Price: CurranThompson = exp(-r*Time) * ( S*value - X*pnorm(-g.star*sqrt(3)) ) # Put Price: if (TypeFlag == "p") { Parity = (1/(r*Time))*(1-exp(-r*Time))*S - exp(-r*Time)*X CurranThompson = CurranThompson - Parity } # Return Value: option = list( price = CurranThompson, call = match.call() ) class(option) = "option" option } # ------------------------------------------------------------------------------ RogerShiThompsonAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Description: # Calculates "lower bound" for Asian Call Option from # Thompson's formula. Thompson's result is the same # as can be obtained from Roger and Shi's formula. # However, Thompson's formula is numerically more # efficient since it requires a single integration # only, whereas Roger and Shi's formula requires # double integration. # Note: # Rescale sigma: # Note the formula of Thompson work for Time=1 only! # Thus the easiest way to cover times to maturity different # from unity can be achieved by scale the volatility and # interest rate! - Just do it # FUNCTION: # Settings: TypeFlag = TypeFlag[1] sigma = sigma*sqrt(Time) r = r*Time Time = 1 # Function from which to calculate gamma star: gamma.star = function(S, X, r, sigma, lower = -99, upper = 99) { func = function(gamma, S, X, r, sigma) { f = function(x, gamma, roh, sigma) { time = x alpha = roh - sigma*sigma/2 f = exp( 3 * gamma * sigma * time * (1-time/2) + alpha * time + sigma * sigma * (time-3*time^2*(1-time/2)^2)/2 ) f } # Integrate: integrate(f, lower = 0, upper = 1, gamma = gamma, roh = r, sigma = sigma, subdivisions = 1000, rel.tol = .Machine$double.eps^0.5, abs.tol = .Machine$double.eps^0.5)$value - X/S } # Find Root Value: uniroot(func, lower = lower, upper = upper, S = S, X = X, r = r, sigma = sigma)$root } g.star = gamma.star(S, X, r, sigma) # Function to be integrated: f = function(x, g.star, roh, sigma) { time = x alpha = roh - sigma*sigma/2 arg = (-g.star + sigma*time*(1-time/2))*sqrt(3) f = exp( (alpha+sigma^2/2)*time ) * pnorm(arg) f } # Integrate: value = integrate(f, lower=0, upper=1, g.star=g.star, roh=r, sigma=sigma, subdivisions=1000, rel.tol=.Machine$double.eps^0.5, abs.tol=.Machine$double.eps^0.5)$value # Call Price: RogerShiThompson = exp(-r*Time) * ( S*value - X*pnorm(-g.star*sqrt(3)) ) # Put Price: if (TypeFlag == "p") { Parity = (1/(r*Time))*(1-exp(-r*Time))*S - exp(-r*Time)*X RogerShiThompson = RogerShiThompson - Parity } # Return Value: option = list( price = RogerShiThompson, call = match.call() ) class(option) = "option" option } # ------------------------------------------------------------------------------ ThompsonAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Description: # Calculates "upper bound" for Asian Call Option from # Thompson's formula. # Note: # Rescale sigma: # Note the formula of Thompson work for Time=1 only! # Thus the easiest way to cover times to maturity different # from unity can be achieved by scale the volatility and # interest rate! - Just do it # FUNCTION: # Settings: TypeFlag = TypeFlag[1] sigma = sigma*sqrt(Time) r = r*Time Time = 1 # Internal Functions: sqrtvt = function(x, S, X, alpha, sigma) { t = x ct = S*exp(alpha*t)*sigma - X*sigma vt = ct^2*t + 2*(X*sigma)*ct*t*(1-t/2) + (X*sigma)^2/3 sqrt(vt) } fmu = function(t, S, X, r, sigma) { alpha = r -sigma^2/2 gint = integrate(sqrtvt, lower=0, upper=1, S=S, X=X, alpha=alpha, sigma=sigma, subdivisions=1000, rel.tol=.Machine$double.eps^0.5, abs.tol=.Machine$double.eps^0.5)$value gamma = (X - S * (exp(alpha)-1) / alpha ) / gint mu = (S*exp(alpha*t) + gamma*sqrtvt(x=t, S=S, X=X, alpha=alpha, sigma=sigma) ) / X mu } fatx = function(t, x, S, X, r, sigma) { alpha = r - sigma^2/2 mu = fmu(t=t, S=S, X=X, r=r, sigma=sigma) atx = S*exp(sigma*x+alpha*t) - X*(mu + sigma*x) + X*sigma*(1-t/2)*x atx } fbtx = function(t, x, S, X, r, sigma) { alpha = r - sigma^2/2 btx = X*sigma*sqrt(1/3 -t*(1-t/2)^2) btx } fw = function(x, v, S2, X2, r2, sigma2) { w = x atx = fatx(t=v^2, x=w*v, S=S2, X=X2, r=r2, sigma=sigma2) btx = fbtx(t=v^2, x=w*v, S=S2, X=X2, r=r2, sigma=sigma2) 2 * v * dnorm(w) * (atx*pnorm(atx/btx) + btx*dnorm(atx/btx)) } fv = function(x, S1, X1, r1, sigma1) { fv = rep(0, length=length(x)) for (i in 1:length(x)) fv[i] = integrate(fw, lower=-20, upper=20, v=x[i], S2=S1, X2=X1, r2=r1, sigma2=sigma1, subdivisions=1000, rel.tol=.Machine$double.eps^0.5, abs.tol=.Machine$double.eps^0.5)$value exp(-r)*fv } # Integrate - Call Price: Thompson = integrate(fv, lower=0, upper=1, S1=S, X1=X, r1=r, sigma1=sigma, subdivisions=1000, rel.tol=.Machine$double.eps^0.5, abs.tol=.Machine$double.eps^0.5)$value # Put Price: if (TypeFlag == "p") { Parity = (1/(r*Time))*(1-exp(-r*Time))*S - exp(-r*Time)*X Thompson = Thompson - Parity } # Return Value: option = list( price = Thompson, call = match.call() ) class(option) = "option" option } # ------------------------------------------------------------------------------ TolmatzAsianOption = function(TypeFlag = c("c", "p"), S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.30) { # A function implemented by Diethelm Wuertz # Description: # Calculates "lower bound" for Asian Call Option from # the asymptotic behavior derived by Tolmatz # FUNCTION: TypeFlag = TypeFlag[1] Tolmatz = NA # Put Price: if (TypeFlag == "p") { Parity = (1/(r*Time))*(1-exp(-r*Time))*S - exp(-r*Time)*X Tolmatz = Tolmatz - Parity } # Return Value: option = list( price = Tolmatz, call = match.call() ) class(option) = "option" option } ################################################################################ # SYMMETRY AND EQUIVALENCE RELATIONS: CallPutParityAsianOption = function(TypeFlag = "p", Price = 8.828759, S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.3, table = NA) { # A function implemented by Diethelm Wuertz # Test for Table: if (is.data.frame(table)) { S = table[,1] X = table[,2] Time = table[,3] r = table[,4] sigma = table[,5] } # Call from Put: if (TypeFlag == "c") { # print(Price) Parity = S*(1-exp(-r*Time))/(r*Time) - X*exp(-r*Time) # print(Parity) result = Price + Parity } # Put from Call: if (TypeFlag == "p") { Parity = S*(1-exp(-r*Time))/(r*Time) - X*exp(-r*Time) result = Price - Parity } # Return Value: result } # ------------------------------------------------------------------------------ WithDividendsAsianOption = function(TypeFlag = "c", Dividends = 0.45, S = 100, X = 100, Time = 1, r = 0.09, sigma = 0.3, calculator = MomentMatchedAsianOption, method = "LN") { # A function implemented by Diethelm Wuertz # Add Dividends: q = Dividends = 0.05 r.q = r - q X.q = X * exp(-q*Time) S.q<- S * exp(-q*Time) # Call Price: if (TypeFlag == "c") Price = calculator(TypeFlag = TypeFlag, S = S.q, X = X.q, Time = Time, r = r.q, sigma = sigma, method = method)$price # Put Price: if (TypeFlag == "p" ) Price = NA # Return Value: option = list( price = Price, call = match.call() ) class(option) = "option" option } ################################################################################ # TABULATED RESULTS: FuMadanWangTable = function() { # A function implemented by Diethelm Wuertz # Description: # Display Fu-Madan-Wang's results from Table 1 # Source: # Settings: X = rep(c(90,95,100,105,110), times = 6) S = 100*rep(1, times = length(X)) sigma = rep(0.20, length = length(X)) r = rep(0.09, length = length(X)) # Call Prices: CallEulerFMW = c( 11.5293, 7.2131, 3.8087, 1.6465, 0.5761, 11.9247, 7.7249, 4.3696, 2.1175, 0.8734, 13.8372, 9.9998, 6.7801, 4.2982, 2.5473, 17.1212, 13.6763, 10.6319, 8.0436, 5.9267, 19.8398, 16.6740, 13.7974, 11.2447, 9.0316, 24.0861, 21.3774, 18.8399, 16.4917, 14.3442) CPUEulerFMW = c( 53,44,42,45,38, 34,33,33,32,32, 26,26,26,25,25, 24,23,23,23,22, 21,21,21,20,20, 19,22,19,21,21) CallPostWidderFMW = c( 11.5176, 7.1981, 3.8196, 1.6623, 0.5728, 11.9241, 7.7185, 4.3759, 2.1290, 0.8753, 13.8439, 10.0029, 6.7823, 4.3010, 2.5450, 17.1297, 13.6830, 10.6370, 8.0474, 5.9295, 19.8495, 16.6822, 13.8042, 11.2502, 9.0360, 24.0861, 21.3774, 18.8399, 16.4917, 14.3442) CPUPostWidderFMW = c( 640,631,628,623,625, 613,591,601,585,595, 518,513,514,503,503, 475,473,473,469,474, 468,467,467,462,465, 453,442,449,441,453) CallZhang = c( NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 13.8314996, 9.99566567, 6.7773481, 4.2964626, 2.5462209, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA) # Return Value: data.frame(cbind( S, X, r, sigma, CallEulerFMW, CPUEulerFMW, CallPostWidderFMW, CPUPostWidderFMW, CallZhang)) } # ------------------------------------------------------------------------------ FusaiTaglianiTable = function() { # A function implemented by Diethelm Wuertz # Description: # Display Fusai and Tagliani's results from Table 6a - 6c # Source: # G. Fusai and A. Tagliani [2002] # An Accurate Valuation of Asian Options Using Moments # Settings: S = 100*rep(1, times = 45) X = rep(rep(c(90, 95, 100, 105, 110), times = 3), times = 3) Time = rep(1, times = 45) r = rep(sort(rep(c(0.05, 0.09, 0.15), times = 5)), times = 3) sigma = rep(0.10, times = 15); sigma = c(sigma, 3*sigma, 5*sigma) # Moment Matched Call Prices: CallLNa = c( 11.95333, 7.41517, 3.64748, 1.30684, 0.32399, 13.38629, 8.91721, 4.92310, 2.07045, 0.62338, 15.39906, 11.12196, 7.03485, 3.61869, 1.41080) CallLNb = c( 14.03812, 10.74879, 7.99251, 5.77417, 4.05724, 15.06704, 11.73287, 8.88576, 6.54628, 4.69511, 16.59082, 13.22661, 10.27814, 7.78408, 5.74800) CallLNc = c( 17.67918, 14.91574, 12.48954, 10.38535, 8.58075, 18.43698, 15.66486, 13.21198, 11.06751, 9.21323, 19.55391, 16.78229, 14.30234, 12.10904, 10.18997) CallFTLN = c(CallLNa, CallLNb, CallLNc) # Gram-Charlier Call Prices: CallFTa = c( 11.95127, 7.40754, 3.64091, 1.31097, 0.33156, 13.38535, 8.91185, 4.91459, 2.07002, 0.63072, 15.39885, 11.11966, 7.02746, 3.61216, 1.41384) CallFTb = c( 13.89562, 10.63393, 7.92948, 5.76852, 4.09909, 14.92543, 11.60605, 8.80190, 6.51749, 4.71737, 16.45856, 13.09056, 10.16897, 7.72184, 5.73774) CallFTc = c( 17.00382, 14.46257, 12.25646, 10.34604, 8.69620, 17.69986, 15.13557, 12.89937, 10.95396, 9.26553, 18.73925, 16.14761, 13.87252, 11.88030, 10.13926) CallFTLNGC = c(CallFTa, CallFTb, CallFTc) # Return Value: data.frame(S, X, Time, r, sigma, CallFTLN, CallFTLNGC) } # ------------------------------------------------------------------------------ GemanTable = function() { # A function implemented by Diethelm Wuertz # Description: # Display Geman's Table # Source: # H. Geman [], # Functionals of Brownian Motion in Path Dependent # Option Valuation # Settings: S = c(1.9, 2.0, 2.1, 2.0, 2.0, 2.0) X = rep(2, times = 6) Time = c(1, 1, 1, 1, 2, 2) r = c(5, 5, 5, 2, 1.25, 5)/100 sigma = c(5, 5, 5, 1, 2.5, 5)/10 # Call Prices: CallGY = c( 0.195, 0.248, 0.308, 0.058, 0.1772, 0.352) CallMC = c( 0.191, 0.248, 0.306, 0.056, 0.1771, 0.347) # Return Value: data.frame(cbind(S, X, Time, r, sigma, CallGY, CallMC)) } # ------------------------------------------------------------------------------ LinetzkyTable = function() { # A function implemented by Diethelm Wuertz # Description: # Display Linetzky's Table 3 # Source: # V. Linetzky [2002] # Spectral Expansions for Asian (Average Price) Options # Settings: S = c(2.00, 2.00, 2.00, 1.90, 2.00, 2.10, 2.00) X = c(2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00) Time = c(1.00, 1.00, 2.00, 1.00, 1.00, 1.00, 2.00) r = c(0.02, 0.18, 0.0125, 0.05, 0.05, 0.05, 0.05) sigma = c(10.0, 30.0, 25.0, 50.0, 50.0, 50.0, 50.0) / 100 # Call Prices: CallEE = c( 0.0559860415, 0.2183875466, 0.1722687410, 0.1931737903, 0.2464156905, 0.3062203648, 0.3500952190) CallSLT = c( 0.055986, 0.218388, 0.172269, 0.193174, 0.246416, 0.306220, 0.350095) CallMC = c( 0.05602, 0.2185, 0.1725, 0.1933, 0.2465, 0.3064, 0.3503) CallTLB = c( 0.055985, 0.218366, 0.172226, 0.193060, 0.246298, 0.306094, 0.349779) CallTUB = c( 0.055989, 0.218473, 0.172451, 0.193799, 0.247054, 0.306904, 0.352556) # Return Value: data.frame(S, X, Time, r, sigma, CallEE, CallSLT, CallMC, CallTLB, CallTUB) } # ------------------------------------------------------------------------------ ZhangTable = function() { # A function implemented by Diethelm Wuertz # Description: # Display Zhangs's results from Table 1 # Source: # J.E. Zhang [2002], # A semi-analytical method for pricing and hedging # continuously sampled arithmetic average rate options # Settings: S = 100*rep(1, times = 36) X = c(rep(c(95, 100, 105), times = 3), rep(c(90, 100, 110), times = 9)) Time = rep(1, times = 36) r = rep(c(5, 5, 5, 9, 9, 9, 15, 15, 15)/100, times = 4) sigma = sort(rep(c(0.05, 0.10, 0.20, 0.30), times = 9)) # Call Prices: CallZ = c( 7.1777275, 2.7161745, 0.3372614, 8.8088302, 4.3082350, 0.9583841, 11.0940944, 6.7943550, 2.7444531, 11.9510927, 3.6413864, 0.3312030, 13.3851974, 4.9151167, 0.6302713, 15.3987687, 7.0277081, 1.4136149, 12.5959916, 5.7630881, 1.9898945, 13.8314996, 6.7773481, 2.5462209, 15.6417575, 8.4088330, 3.5556100, 13.9538233, 7.9456288, 4.0717942, 14.9839595, 8.8287588, 4.6967089, 16.5129113, 10.2098305, 5.7301225) # Return Value: data.frame(cbind(S, X, Time, r, sigma, CallZ)) } # ------------------------------------------------------------------------------ ZhangShortTable = function() { # A function implemented by Diethelm Wuertz # Description: # Display Zhangs's short-tenor (ST) results from Table 7 # Source: # J.E. Zhang [2002], # A semi-analytical method for pricing and hedging # continuously sampled arithmetic average rate options # Settings: S = 100*rep(1, times = 18) X = c(rep(c(95,100,105), times = 6)) Time = rep(0.08, times = 18) r = rep(0.09, times = 18) sigma = sort(rep(c(0.05, 0.10, 0.20, 0.30, 0.40, 0.50), times = 3)) # Call Prices: CallPM = c( 5.3224059, 0.5343219, 0.0000000, 5.3225549, 0.8431357, 0.0014921, 5.3816262, 1.4835707, 0.1292560, 5.6304554, 2.1291126, 0.4880727, 6.0222502, 2.7758194, 0.9753549, 6.4947818, 3.4228569, 1.5274729) CallCT = c( 5.3224059, 0.5343040, 0.0000000, 5.3225550, 0.8431302, 0.0014924, 5.3816340, 1.4835272, 0.1292529, 5.6304480, 2.1289662, 0.4879999, 6.0221516, 2.7754740, 0.9750983, 6.4944850, 3.4221863, 1.5268836) # Return Value: data.frame(cbind(S, X, Time, r, sigma, CallPM, CallCT)) } # ------------------------------------------------------------------------------ ZhangLongTable = function() { # A function implemented by Diethelm Wuertz # Description: # Display Zhangs's long-tenor (LT) results from Table 7 # Source: # J.E. Zhang [2002], # A semi-analytical method for pricing and hedging # continuously sampled arithmetic average rate options # Settings: S = 100*rep(1, times = 18) X = c(rep(c(95,100,105), times = 6)) Time = rep(3, times = 18) r = rep(0.09, times = 18) sigma = sort(rep(c(0.05, 0.10, 0.20, 0.30, 0.40, 0.50), times = 3)) # Call Prices: CallPM = c( 15.11626, 11.30359, 7.55327, 15.21331, 11.63716, 8.39113, 16.63363, 13.76592, 11.22170, 19.01304, 16.58331, 14.39723, 21.70848, 19.57038, 17.62156, 24.47434, 22.55837, 20.79507) CallCT = c( 15.11626, 11.30361, 7.55328, 15.21376, 11.63752, 8.39084, 16.63611, 13.76547, 11.21783, 19.01856, 16.58101, 14.38708, 21.72991, 19.57593, 17.61228, 24.54788, 22.60645, 20.81811) # Return Value: data.frame(cbind(S, X, Time, r, sigma, CallPM, CallCT)) } ################################################################################ fAsianOptions/R/BesselFunctions.R0000644000176200001440000003345711370220760016473 0ustar liggesusers # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received a copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2004, Diethelm Wuertz, GPL # Diethelm Wuertz # info@rmetrics.org # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # BesselI Modified Bessel Function of first kind # BesselK Modified Bessel Function of third kind # BesselDI Derivative of BesselI # BesselDK Derivative of BesselK # INTERNAL FUNCTION: DESCRIPTION: # .BesselN For internal use only # .Bessel01 ... # .Bessel.MSTA1 ... # .Bessel.MSTA2 ... # .Bessel.ENVJ ... ################################################################################ BesselI = function(x, nu, expon.scaled = FALSE) { # A function implemented by Diethelm Wuertz # Symmetry Relation: nu = abs(nu) # Test: if (nu - floor(nu) != 0) stop("nu must be an integer") # Compute: bessel = NULL for (X in x) { bessel = c(bessel, .BesselN(X, nu)[1]) } # Scaling: if (expon.scaled) bessel = exp(-x)*bessel # Return Value: as.vector(bessel) } # ------------------------------------------------------------------------------ BesselK = function(x, nu, expon.scaled = FALSE) { # A function implemented by Diethelm Wuertz # Symmetry Relation: nu = abs(nu) # Test: if (nu - floor(nu) != 0) stop("nu must be an integer") # Compute: bessel = NULL for (X in x) { bessel = c(bessel, .BesselN(X, nu)[2]) } # Scaling: if (expon.scaled) bessel = exp(x)*bessel # Return Value: as.vector(bessel) } # ------------------------------------------------------------------------------ BesselDI = function(x, nu) { # A function implemented by Diethelm Wuertz # Symmetry Relation: nu = abs(nu) # Test: if (nu - floor(nu) != 0) stop("nu must be an integer") # Compute: bessel = NULL for (X in x) { bessel = c(bessel, .BesselN(X, nu)[3]) } # Return Value: bessel } # ------------------------------------------------------------------------------ BesselDK = function(x, nu) { # A function implemented by Diethelm Wuertz # Symmetry Relation: nu = abs(nu) # Test: if (nu - floor(nu) != 0) stop("nu must be an integer") # Compute: bessel = NULL for (X in x) { bessel = c(bessel, .BesselN(X, nu)[4]) } # Return Value: bessel } ################################################################################ .BesselN = function(X, N) { # A function implemented by Diethelm Wuertz # Description: # Compute modified Bessel functions In(x) and # Kn(x), and their derivatives # Arguments: # x - argument of In(x) and Kn(x) # n - order of In(x) and Kn(x) # Value: # BI(n) --- In(x) # DI(n) --- In'(x) # BK(n) --- Kn(x) # DK(n) --- Kn'(x) # NM --- Highest order computed # FUNCTION: # Settings: F = 0 NM = N # Very small arguments: if (X == 0) { if (N == 0) { return(c(BI = 1, BK = Inf, DI = 0, DK = -Inf)) } if (N >= 1) { return(c(BI = 0, BK = Inf, DI = 0, DK = -Inf)) } } # Start values: BI = BK = DI = DK = rep(NA, times = max(N+1, 2)) Bessel = .Bessel01(X) BI0 = BI[1] = Bessel["BI0"] BI1 = BI[2] = Bessel["BI1"] BK0 = BK[1] = Bessel["BK0"] BK1 = BK[2] = Bessel["BK1"] DI0 = DI[1] = Bessel["DI0"] DI1 = DI[2] = Bessel["DI1"] DK0 = DK[1] = Bessel["DK0"] DK1 = DK[2] = Bessel["DK1"] # Return for N=0: if (N == 0) return(c(BI = BI0, BK = BK0, DI = DI0, DK = DK0)) # Return for N=1: if (N == 1) return(c(BI = BI1, BK = BK1, DI = DI1, DK = DK1)) # Compute BI for N>1: if (X > 40 & N < floor(0.25*X)) { H0 = BI0 H1 = BI1 for (K in 2:N) { H = -2 * (K-1) / X*H1 + H0 BI[K+1] = H H0 = H1 H1 = H } } else { M = .Bessel.MSTA1(X, 200) if (M < N) { NM = M } else { M = .Bessel.MSTA2(X, N, 15) } F0 = 0 F1 = 1.0e-100 for (I in 0:M) { # (K = M, 0, -1) K = M - I F = 2 * (K+1) * F1/X + F0 if (K <= NM) BI[K+1] = F F0 = F1 F1 = F } S0 = BI0/F for (K in 0:NM) BI[K+1] = S0 * BI[K+1] } for (K in 2:NM) { DI[K+1] = BI[K-1+1] - K/X * BI[K+1] } # Compute BK for N>1: G0 = BK0 G1 = BK1 for (K in 2:NM) { G = 2 * (K-1) / X*G1 + G0 BK[K+1] = G G0 = G1 G1 = G } for (K in 2:NM) { DK[K+1] = -BK[K-1+1] - K/X * BK[K+1] } # Result: ans = c(BI = BI[N+1], BK = BK[N+1], DI = DI[N+1], DK = DK[N+1]) names(ans) = NULL # Return Value: ans } # ------------------------------------------------------------------------------ .Bessel01 = function(X) { # A function implemented by Diethelm Wuertz # Description: # Compute modified Bessel functions I0(x), I1(1), # K0(x) and K1(x), and their derivatives # Arguments: # x - argument # Values: # BI0 --- I0(x) # DI0 --- I0'(x) # BI1 --- I1(x) # DI1 --- I1'(x) # BK0 --- K0(x) # DK0 --- K0'(x) # BK1 --- K1(x) # DK1 --- K1'(x) # FUNCTION: # Compute BI and BK: if (X == 0) { BI0 = 1 BI1 = 0 BK0 = Inf BK1 = Inf DI0 = 0 DI1 = 0.5 DK0 = -Inf DK1 = -Inf return(c( BI0 = BI0, BI1 = BI1, BK0 = BK0, BK1 = BK1, DI0 = DI0, DI1 = DI1, DK0 = DK0, DK1 = DK1)) } # Compute BI: if (X <= 18) { bi0.fun = function(X) { X2 = X * X BI0 = 1 R = 1 for (K in 1:50) { R = 0.25 * R * X2 / (K*K) BI0 = BI0 + R if (abs(R/BI0) < 1.0e-15) return(BI0) } BI0 } BI0 = bi0.fun(X) bi1.fun = function(X) { X2 = X * X BI1 = 1 R = 1 for (K in 1:50) { R = 0.25 * R * X2 /(K*(K+1)) BI1 = BI1 + R if (abs(R/BI1) < 1.0e-15) return(0.5 * X * BI1) } 0.5 * X * BI1 } BI1 = bi1.fun(X) } else { A = c( 0.125,7.03125e-2, 7.32421875e-2, 1.1215209960938e-1, 2.2710800170898e-1, 5.7250142097473e-1, 1.7277275025845, 6.0740420012735, 24.380529699556, 110.01714026925, 551.33589612202, 3.0380905109224e03 ) B = c( -0.375, -1.171875e-1, -1.025390625e-1, -1.4419555664063e-1, -2.7757644653320e-1, -6.7659258842468e-1, -1.9935317337513, -6.8839142681099e0, -2.7248827311269e01, -121.59789187654, -6.0384407670507e02, -3.3022722944809e03 ) K0 = 12 if (X >= 35) K0 = 9 if (X >= 50) K0 = 7 CA = exp(X) / sqrt(2 * pi * X) BI0 = 1 XR = 1/X for (K in 1:K0) BI0 = BI0 + A[K] * XR^K BI0 = CA * BI0 BI1 = 1 for (K in 1:K0) BI1 = BI1 + B[K] * XR^K BI1 = CA * BI1 } # Compute BK: if (X <= 9) { bk0.fun = function(X) { X2 = X * X EL = 0.5772156649015329 CT = -(log(X/2) + EL) BK0 = 0 WW = BK0 W0 = 0 R = 1 for (K in 1:50) { W0 = W0 + 1/K R = 0.25 * R / (K*K) * X2 BK0 = BK0 + R * (W0 + CT) if (abs(BK0-WW)/abs(BK0) < 1.0e-15 & abs(BK0) > 0) return(BK0 + CT) WW = BK0 } BK0 + CT } BK0 = bk0.fun(X) } else { A1 = c( 0.125, 0.2109375, 1.0986328125, 11.775970458984, 214.61706161499, 5.9511522710323e03, 2.3347645606175e05, 1.2312234987631e07 ) CB = 0.5 / X XR2 = 1 / (X*X) BK0 = 1 for (K in 1:8) BK0 = BK0 + A1[K] * XR2^K BK0 = CB * BK0/BI0 } BK1 = (1/X - BI1*BK0)/BI0 # Derivatives: DI0 = BI1 DI1 = BI0 - BI1/X DK0 = -BK1 DK1 = -BK0 - BK1/X # Return Value: c( BI0 = BI0, BI1 = BI1, BK0 = BK0, BK1 = BK1, DI0 = DI0, DI1 = DI1, DK0 = DK0, DK1 = DK1) } # ------------------------------------------------------------------------------ .Bessel.MSTA1 = function(X, MP) { # A function implemented by Diethelm Wuertz # Description: # Determine the starting point for backward recurrence such # that the magnitude of Jn(x) at that point is about 10^(-MP) # Arguments: # x - argument of Jn(x) # MP - Value of Magnitude # Value: # MSTA1 - Starting point # FUNCTION: # Settings: A0 = abs(X) N0 = floor(1.1 * A0) + 1 F0 = .Bessel.ENVJ(N0, A0) - MP N1 = N0 + 5 F1 = .Bessel.ENVJ(N1, A0) - MP # Compute: for (IT in 1:20) { NN = N1 - floor( (N1-N0) / (1 - F0/F1) ) F = .Bessel.ENVJ(NN, A0) - MP if (abs(NN-N1) < 1) return(NN) N0 = N1 F0 = F1 N1 = NN F1 = F } # Return Value: NN } # ------------------------------------------------------------------------------ .Bessel.MSTA2 = function(X, N, MP) { # A function implemented by Diethelm Wuertz # Description: # Determine the starting point for backward recurrence such # that all Jn(x) has MP significant digits # Arguments: # x - argument of Jn(x) # n - Order of Jn(x) # MP - Significant digit # Value: # MSTA2 - Starting point # FUNCTION: # Settings: A0 = abs(X) HMP = 0.5 * MP EJN = .Bessel.ENVJ(N, A0) if (EJN <= HMP) { OBJ = MP N0 = max(floor(1.1 * A0), 1) } else { OBJ = HMP + EJN N0 = N } # Compute: F0 = .Bessel.ENVJ(N0, A0) - OBJ N1 = N0 + 5 F1 = .Bessel.ENVJ(N1, A0) - OBJ for (IT in 1:20) { NN = N1 - floor( (N1-N0) / (1 - F0/F1) ) # print(c(N0=N0, A0=A0)) # print(c(F0=F0, F1=F1)) # print(c(N=N, NN=NN, N1=N1)) F = .Bessel.ENVJ(NN, A0) - OBJ if (abs(NN-N1) < 1) return(NN + 10) N0 = N1 F0 = F1 N1 = NN F1 = F } # Return Value: NN + 10 } # ------------------------------------------------------------------------------ .Bessel.ENVJ = function(N, X) { # A function implemented by Diethelm Wuertz # Return Value: 0.5 * log10(6.28*N) - N * log10(1.36*X/N) } ################################################################################ fAsianOptions/NAMESPACE0000644000176200001440000000455111734074114014255 0ustar liggesusers ################################################ ## import name space ################################################ import("timeDate") import("timeSeries") import("fBasics") import("fOptions") ################################################ ## useDynLib ################################################ useDynLib("fAsianOptions") ################################################ ## S4 classes ################################################ ################################################ ## S3 classes ################################################ ################################################ ## functions ################################################ export( ".AbrahamsonAsianOptionMoments", ".Bessel.ENVJ", ".Bessel.MSTA1", ".Bessel.MSTA2", ".Bessel01", ".BesselN", ".DufresneAsianOptionMoments", ".DufresneMoments", ".GramCharlierAsianDensity", ".LevyTurnbullWakemanAsianDensity", ".LevyTurnbullWakemanAsianOption", ".MilevskyPosnerAsianDensity", ".MilevskyPosnerAsianOption", ".PosnerMilevskyAsianDensity", ".PosnerMilevskyAsianOption", ".TolmatzAsianOptionMoments", ".TurnbullWakemanAsianOptionMoments", ".gxtEBM", ".gxtuEBM", ".gxuEBM", ".psiEBM", ".thetaEBM", "AsianOptionMoments", "BesselDI", "BesselDK", "BesselI", "BesselK", "BoundsOnAsianOption", "CallPutParityAsianOption", "CurranThompsonAsianOption", "FuMadanWangTable", "FusaiTaglianiTable", "GemanTable", "GemanYorAsianOption", "GramCharlierAsianOption", "LinetzkyAsianOption", "LinetzkyTable", "MomentMatchedAsianDensity", "MomentMatchedAsianOption", "Pochhammer", "Psi", "RogerShiThompsonAsianOption", "ThompsonAsianOption", "TolmatzAsianOption", "VecerAsianOption", "WithDividendsAsianOption", "ZhangApproximateAsianOption", "ZhangAsianOption", "ZhangLongTable", "ZhangShortTable", "ZhangTable", "cgamma", "d2EBM", "dEBM", "dasymEBM", "derivative", "dgam", "djohnson", "dlognorm", "drgam", "erf", "gGemanYor", "gLinetzky", "hermiteH", "igamma", "kummerM", "kummerU", "masian", "mjohnson", "mlognorm", "mnorm", "mrgam", "pEBM", "pgam", "pjohnson", "plognorm", "prgam", "whittakerM", "whittakerW" ) fAsianOptions/DESCRIPTION0000644000176200001440000000141412161705167014543 0ustar liggesusersPackage: fAsianOptions Version: 3010.79 Revision: 5522 Date: 2013-06-23 Title: EBM and Asian Option Valuation Author: Diethelm Wuertz and many others, see the SOURCE file Depends: R (>= 2.4.0), timeDate, timeSeries, fBasics, fOptions Suggests: RUnit Maintainer: Yohan Chalabi Description: Environment for teaching "Financial Engineering and Computational Finance" Note: Several parts are still preliminary and may be changed in the future. this typically includes function and argument names, as well as defaults for arguments and return values. LazyData: yes License: GPL (>= 2) URL: http://www.rmetrics.org Packaged: 2013-06-23 18:22:14 UTC; yohan NeedsCompilation: yes Repository: CRAN Date/Publication: 2013-06-24 01:53:27 fAsianOptions/ChangeLog0000644000176200001440000000252612161636321014607 0ustar liggesusers2013-06-23 chalabi * DESCRIPTION, src/Makevars: updated Fortran flags and version number 2013-03-18 chalabi * ChangeLog, DESCRIPTION: updated ChangeLog and DSC files 2013-02-07 chalabi * R/zzz.R: Removed deprecated .First.lib() * R/GammaFunctions.R: Changed deprecated is.real() by is.double() * DESCRIPTION: Updated maintainer field 2012-03-21 chalabi * ChangeLog, DESCRIPTION: updated DESCRIPTION and ChangeLog * src/EBMAsianOptions.f: replaced 'write' calls by R Fortran print API 2012-03-20 chalabi * src/EBMAsianOptions.f: fixed gfortran warnings in Fortran routines * DESCRIPTION: updated DESC file 2012-03-19 chalabi * R/EBMAsianOptions.R, R/GammaFunctions.R, R/HypergeometricFunctions.R: removed partial argument names * src/EBMAsianOptions.f: removed part of the WRITE() statements in Fortran code * NAMESPACE: added NAMESPACE 2011-09-23 mmaechler * DESCRIPTION: remove deprecated "LazyLoad" entry 2010-07-23 chalabi * inst/DocCopying.pdf: removed DocCopying.pdf license is already specified in DESCRIPTION file 2009-10-01 chalabi * DESCRIPTION: updated version number 2009-09-29 chalabi * ChangeLog, DESCRIPTION: updated DESC and ChangeLog 2009-04-02 chalabi * DESCRIPTION: more explicit depends and suggests field in DESC file. 2009-04-01 chalabi * DESCRIPTION: updated DESC file