'=========================================================================
Public Function impVol(OptPrice As Double, S As Double, T As Double, x As Double, r As Double, Tol As Double) As Double
'=========================================================================
vol0 = impPutVol(0, S, T, x, r)
vol1 = impPutVol(OptPrice, S, T, x, r)
f0 = CrankN(vol0) - OptPrice
f1 = CrankN(vol1) - OptPrice
vol2 = vol1 - f1 * ((vol1 - vol0) / (f1 - f0))
f2 = CrankN(vol2) - OptPrice
Do While (f2 > Tol)
If f0 * f2 >= 0 Then
vol0 = vol2
f0 = CrankN(vol0) - OptPrice
Else
vol1 = vol2
f1 = CrankN(vol1) - OptPrice
End If
vol2 = vol1 - f1 * ((vol1 - vol0) / (f1 - f0))
f2 = CrankN(vol2) - OptPrice
Loop
impVol = vol2
End Function
'==============================
Function CrankN(v)
Dim m As Integer, n As Integer
Dim S As Double, k As Double, r As Double, T As Double
Dim dt As Double, ds As Double
Dim sMax As Double
Dim i As Single, j As Single
Dim pik As Variant
n = Range("NTimeSteps").Cells(1, 1)
m = Range("NPriceSteps").Cells(1, 1)
S = Range("Price").Cells(1, 1)
k = Range("Strike").Cells(1, 1)
r = Range("RFRate").Cells(1, 1)
T = Range("TMat").Cells(1, 1)
dt = T / n
sMax = Range("MaxUPrice").Cells(1, 1)
ds = sMax / m
ReDim f(m + 1)
ReDim sVec(m + 1)
ReDim exeP(m - 1)
ReDim fold(m + 1)
ReDim a(m - 1)
ReDim b(m - 1)
ReDim c(m - 1)
ReDim d(m - 1)
ReDim fVec(m - 1)
ReDim Mat(1 To m - 1, 1 To m - 1)
For i = 1 To UBound(f)
f(i) = 0
Next i
For i = 0 To m
f(i + 1) = Application.max(k - i * ds, 0)
sVec(i + 1) = i * ds
Next i
For i = 1 To m - 1
exeP(i) = f(i + 1)
Next i
fold = f
For j = 1 To m - 1
a(j) = 0.5 * r * j * dt - 0.5 * v ^ 2 * j ^ 2 * dt
b(j) = 1 + v ^ 2 * j ^ 2 * dt + r * dt
c(j) = -0.5 * r * j * dt - 0.5 * v ^ 2 * j ^ 2 * dt
d(j) = k - j * ds
Next j
f(1) = Range("MaxUPrice").Cells(1, 1)
f(m + 1) = Range("MinUPrice").Cells(1, 1)
Mat(1, 1) = b(1)
Mat(1, 2) = c(1)
Mat(m - 1, m - 2) = a(m - 1)
Mat(m - 1, m - 1) = b(m - 1)
For j = 2 To m - 2
Mat(j, j - 1) = a(j)
Mat(j, j) = b(j)
Mat(j, j + 1) = c(j)
Next j
For i = 1 To n
fVec(1) = fold(2) - a(1) * f(1)
fVec(m - 1) = fold(m) - c(m - 1) * f(m + 1)
For j = 2 To m - 2
fVec(j) = fold(j + 1)
Next j
pik = MartixTri(Mat, fVec)
For j = 2 To m
fold(j) = Application.max(pik(j - 1), d(j - 1))
Next j
fold(1) = f(1)
fold(m + 1) = f(m + 1)
Next i
CrankN = Itp(sVec, fold, S)
End Function
'=====================================================
Function MartixTri(row As Variant, col As Variant)
Dim n As Single, lb As Single, ub As Single
Dim i As Single, j As Single
Dim k As Single, m As Double
u = UBound(row, 1)
l = LBound(row, 1)
n = u - l + 1
ReDim a(n)
ReDim b(n)
ReDim c(n)
ReDim d(n)
ReDim p1(n)
ReDim p2(n)
ReDim x(n)
a(1) = 0
c(n) = 0
For i = 2 To n
a(i) = row(l + i - 1, l + i - 2)
Next i
For i = 1 To n
b(i) = row(l + i - 1, l + i - 1)
Next i
For i = 1 To n - 1
c(i) = row(l + i - 1, l + i)
Next i
d = col
p1(1) = b(1)
p2(1) = d(1)
For k = 2 To n
m = a(k) / p1(k - 1)
p1(k) = b(k) - m * c(k - 1)
p2(k) = d(k) - m * p2(k - 1)
Next k
x(n) = p2(n) / p1(n)
For k = n - 1 To 1 Step -1
x(k) = (p2(k) - c(k) * x(k + 1)) / p1(k)
Next k
MartixTri = x
End Function
'===================
Function Itp(Array1 As Variant, Array2 As Variant, x As Double)
Dim i As Single
If Array1(LBound(Array1)) = x Then
Itp = Array2(LBound(Array2))
Exit Function
End If
For i = LBound(Array1) To UBound(Array1)
If Array1(i) >= x Then
Itp = Array2(i - 1) + (x - Array1(i - 1)) / (Array1(i) - Array1(i - 1)) * (Array2(i) - Array2(i - 1))
Exit Function
End If
Next i
End Function
'=============================================================================================================
Function bsput(S As Double, sigma As Double, T As Double, x As Double, r As Double, Optional Div As Double, _
Optional ExDate As Date = #1/1/2000#) As Double
'=============================================================================================================
Dim D1 As Double
Dim D2 As Double
D1 = (Log(S / x) + (r + sigma * sigma / 2) * T) / (sigma * T ^ 0.5)
D2 = D1 - sigma * T ^ 0.5
bsput = (-S * Application.NormSDist(-D1) + x * Exp(-r * T) * Application.NormSDist(-D2))
'=============================================================================================================
End Function
'=============================================================================================================
Function impPutVol(MktPrice As Double, S As Double, T As Double, x As Double, r As Double, _
Optional Div As Double, Optional ExDate As Date = #1/1/2000#) As Double
'=============================================================================================================
Niter = 100
If ExDate = #1/1/2000# Then
impPutVol = (2 * Abs(Log(S / x) + (r - Div) * T) / T) ^ 0.5
Else
TDiv = (ExDate - Application.WorksheetFunction.today()) / 256
End If
For iter = 1 To Niter
impPutVol = impPutVol - (bsput(S, impPutVol, T, x, r, Div, ExDate) - _
MktPrice) / BSPutVega(S, impPutVol, T, x, r, Div, ExDate)
Next iter
'=============================================================================================================
End Function
'=============================================================================================================
Function BSPutVega(S As Double, sigma As Double, T As Double, x As Double, r As Double, _
Optional Div As Double, Optional ExDate As Date = #1/1/2000#) As Double
'=============================================================================================================
Dim D1 As Double
If ExDate = #1/1/2000# Then
D1 = (Log(S / x) + (r - Div + sigma * sigma / 2) * T) / (sigma * T ^ 0.5)
BSPutVega = S * T ^ 0.5 * Exp(-D1 * D1 / 2) / (2 * Application.Pi()) ^ 0.5
Else
End If
'=============================================================================================================
End Function
'=============================================================================================================