'+===============================================================================+ '| | '| An additional set of mathematical functions for Visual Basic 6 | '| | '| Êðèâîóñ Àíàòîëèé Àíàòîëüåâè÷ (The trick) | '| | '+===============================================================================+ Private Declare Function GetMem2 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (arr() As Any) As Long Public Type Complex R As Double I As Double End Type Public Type Matrix Col As Long ' Number of columns Row As Long ' Number of rows D() As Double End Type Public Const PI = 3.14159265358979 Public Const E = 2.71828182845905 Private Const PI2 = PI / 2 '+=============================================================================+ '| Real numbers | '+=============================================================================+ ' // From degree to radians Public Function Deg(ByVal Value As Double) As Double Deg = 1.74532925199433E-02 * Value End Function ' // The logarithm to the base of a real number X Public Function LogX(ByVal Value As Double, ByVal Base As Double) As Double LogX = Log(Value) / Log(Base) End Function ' // The decimal logarithm of a real number Public Function Log10(ByVal Value As Double) As Double Log10 = Log(Value) / 2.30258509299405 End Function ' // The binary logarithm of a real number Public Function Log2(ByVal Value As Double) As Double Log2 = Log(Value) / 0.693147180559945 End Function ' // Rounding up Public Function Ceil(ByVal Value As Double) As Double Ceil = -Int(-Value) End Function ' // Rounding down (Int) Public Function Floor(ByVal Value As Double) As Double Floor = Int(Value) End Function ' // Secant of a real number Public Function Sec(ByVal Value As Double) As Double Sec = 1 / Cos(Value) End Function ' // Cosecant of a real number Public Function Csc(ByVal Value As Double) As Double Csc = 1 / Sin(Value) End Function ' // Cotangent of a real number Public Function Ctg(ByVal Value As Double) As Double Ctg = 1 / Tan(Value) End Function ' // Arcsine of a real number Public Function Asin(ByVal Value As Double) As Double If Value = -1 Then Asin = -PI2: Exit Function If Value = 1 Then Asin = PI2: Exit Function Asin = Atn(Value / Sqr(-Value * Value + 1)) End Function ' // Arccosine of a real number Public Function Acos(ByVal Value As Double) As Double If CSng(Value) = -1# Then Acos = PI: Exit Function If CSng(Value) = 1# Then Acos = 0: Exit Function Acos = Atn(-Value / Sqr(-Value * Value + 1)) + 2 * Atn(1) End Function ' // Arcsecant of a real number Public Function Asec(ByVal Value As Double) As Double Asec = 1.5707963267949 - Atn(Sgn(Value) / Sqr(Value * Value - 1)) End Function ' // Arccosecant of a real number Public Function Acsc(ByVal Value As Double) As Double Acsc = Atn(Sgn(Value) / Sqr(Value * Value - 1)) End Function ' // Returns the angle whose tangent is the ratio of the two numbers Public Function Atan2(ByVal Y As Double, ByVal X As Double) As Double If Y > 0 Then If X >= Y Then Atan2 = Atn(Y / X) ElseIf X <= -Y Then Atan2 = Atn(Y / X) + PI Else Atan2 = PI / 2 - Atn(X / Y) End If Else If X >= -Y Then Atan2 = Atn(Y / X) ElseIf X <= Y Then Atan2 = Atn(Y / X) - PI Else Atan2 = -Atn(X / Y) - PI / 2 End If End If End Function ' // Arccotangent of a real number Public Function Actg(ByVal Value As Double) As Double Actg = 1.5707963267949 - Atn(Value) End Function ' // Hyperbolic sine of a real number Public Function Sinh(ByVal Value As Double) As Double Sinh = (Exp(Value) - Exp(-Value)) / 2 End Function ' // Hyperbolic cosine of a real number Public Function Cosh(ByVal Value As Double) As Double Cosh = (Exp(Value) + Exp(-Value)) / 2 End Function ' // Hyperbolic tangent of a real number Public Function Tanh(ByVal Value As Double) As Double Tanh = (Exp(2 * Value) - 1) / (Exp(2 * Value) + 1) End Function ' // Hyperbolic cotangent of a real number Public Function Ctgh(ByVal Value As Double) As Double Ctgh = 1 / (Exp(2 * Value) + 1) / (Exp(2 * Value) - 1) End Function ' // Hyperbolic secant of a real number Public Function Sech(ByVal Value As Double) As Double Sech = 2 / (Exp(Value) + Exp(-Value)) End Function ' // Hyperbolic cosecant of a real number Public Function Csch(ByVal Value As Double) As Double Csch = 2 / (Exp(Value) - Exp(-Value)) End Function ' // Hyperbolic arcsine of a real number Public Function Asinh(ByVal Value As Double) As Double Asinh = Log(Value + Sqr(Value * Value + 1)) End Function ' // Hyperbolic arcosine of a real number Public Function Acosh(ByVal Value As Double) As Double Acosh = Log(Value + Sqr(Value * Value - 1)) End Function ' // Hyperbolic arctangent of a real number Public Function Atanh(ByVal Value As Double) As Double Atanh = Log((1 + Value) / (1 - Value)) / 2 End Function ' // Hyperbolic arccotangent of a real number Public Function Actan(ByVal Value As Double) As Double Actan = Log((Value + 1) / (Value - 1)) / 2 End Function ' // Hyperbolic arcsecant of a real number Public Function Asech(ByVal Value As Double) As Double Asech = Log((Sqr(-Value * Value + 1) + 1) / Value) End Function ' // Hyperbolic arccosecant of a real number Public Function Acsch(ByVal Value As Double) As Double Acsch = Log((Sgn(Value) * Sqr(Value * Value + 1) + 1) / Value) End Function ' // Return maximum of two numbers Public Function Max(ByVal Op1 As Double, ByVal Op2 As Double) As Double Max = IIf(Op1 > Op2, Op1, Op2) End Function ' // Return maximum of three numbers Public Function Max3(ByVal Op1 As Double, ByVal Op2 As Double, ByVal Op3 As Double) As Double Max3 = IIf(Op1 > Op2, IIf(Op1 > Op3, Op1, Op3), IIf(Op2 > Op3, Op2, Op3)) End Function ' // Return maximum of four numbers Public Function Max4(ByVal Op1 As Double, ByVal Op2 As Double, ByVal Op3 As Double, ByVal Op4 As Double) As Double Max4 = Max(Max3(Op1, Op2, Op3), Op4) End Function ' // Return minimum of two numbers Public Function Min(ByVal Op1 As Double, ByVal Op2 As Double) As Double Min = IIf(Op1 < Op2, Op1, Op2) End Function ' // Return minimum of three numbers Public Function Min3(ByVal Op1 As Double, ByVal Op2 As Double, ByVal Op3 As Double) As Double Min3 = IIf(Op1 < Op2, IIf(Op1 < Op3, Op1, Op3), IIf(Op2 < Op3, Op2, Op3)) End Function ' // Return minimum of four numbers Public Function Min4(ByVal Op1 As Double, ByVal Op2 As Double, ByVal Op3 As Double, ByVal Op4 As Double) As Double Min4 = Min(Min3(Op1, Op2, Op3), Op4) End Function ' // Returns the remainder of dividing one specified number by another specified number. Public Function IEEERemainder(ByVal Op1 As Double, ByVal Op2 As Double) As Double IEEERemainder = Op1 - (Op2 * Round(Op1 / Op2)) End Function ' // Returns the remainder of dividing one specified number by another specified number. Public Function rMod(ByVal Op1 As Double, ByVal Op2 As Double) As Double rMod = (Abs(Op1) - (Abs(Op2) * (Int(Abs(Op1) / Abs(Op2))))) * Sgn(Op1) End Function '+==============================================================================+ '| Complex numbers | '+==============================================================================+ ' // R = 1, I = 0 Public Function cxOne() As Complex cxOne.R = 1 End Function ' // R = 0, I = 1 Public Function cxImgOne() As Complex cxOne.I = 1 End Function ' // R = 0, I = 0 Public Function cxZero() As Complex End Function ' // Creating a new complex number Public Function cxNew(ByVal Real As Double, ByVal Imaginary As Double) As Complex cxNew.R = Real: cxNew.I = Imaginary End Function ' // Creating a new complex number by polar coordinates Public Function cxPolar(ByVal Magnitude As Double, ByVal Phase As Double) As Complex cxPolar.R = Magnitude * Cos(Phase): cxPolar.I = Magnitude * Sin(Phase) End Function ' // Return the additive inverse of a specified complex number Public Function cxNeg(Op As Complex) As Complex cxNeg.R = -Op.R: cxNeg.I = -Op.I End Function ' // Return the inverse value of a complex number Public Function cxInv(Op As Complex) As Complex Dim Ab2 As Double Ab2 = Op.R * Op.R + Op.I * Op.I cxInv.R = Op.R / Ab2: cxInv.I = -Op.I / Ab2 End Function ' // Addition of two complex numbers Public Function cxAdd(Op1 As Complex, Op2 As Complex) As Complex cxAdd.R = Op1.R + Op2.R cxAdd.I = Op1.I + Op2.I End Function ' // Subtraction of two complex numbers Public Function cxSub(Op1 As Complex, Op2 As Complex) As Complex cxSub.R = Op1.R - Op2.R cxSub.I = Op1.I - Op2.I End Function ' // Multiplication of two complex numbers Public Function cxMul(Op1 As Complex, Op2 As Complex) As Complex cxMul.R = Op1.R * Op2.R - Op1.I * Op2.I cxMul.I = Op1.R * Op2.I + Op1.I * Op2.R End Function ' // Division of two complex numbers Public Function cxDiv(Op1 As Complex, Op2 As Complex) As Complex Dim R2 As Double, i2 As Double R2 = Op2.R * Op2.R: i2 = Op2.I * Op2.I cxDiv.R = (Op1.R * Op2.R + Op1.I * Op2.I) / (R2 + i2) cxDiv.I = (Op1.I * Op2.R - Op1.R * Op2.I) / (R2 + i2) End Function ' // Exponentiation of a complex number Public Function cxDgr(Op As Complex, ByVal Degree As Long) As Complex Dim Md As Double, Ar As Double Md = cxMod(Op): Ar = cxArg(Op): Md = Md ^ Degree: Ar = Ar * Degree cxDgr.R = Md * Cos(Ar): cxDgr.I = Md * Sin(Ar) End Function ' // The square root of a complex number Public Function cxSqr(Op As Complex) As Complex Dim M As Double, A As Double M = Sqr(cxMod(Op)): A = cxArg(Op) / 2 cxSqr.R = M * Cos(A): cxSqr.I = M * Sin(A) End Function ' // Module of a complex number Public Function cxMod(Op As Complex) As Double Dim R2 As Double, i2 As Double R2 = Op.R * Op.R: i2 = Op.I * Op.I cxMod = Sqr(R2 + i2) End Function ' // Phase of a complex number Public Function cxPhase(Op As Complex) As Double cxPhase = Atan2(Op.I, Op.R) End Function ' // Argument of a complex number (equal phase) Public Function cxArg(Op As Complex) As Double If Op.I = 0 Then If Op.R >= 0 Then cxArg = 0 Else cxArg = PI ElseIf Op.R = 0 Then If Op.I >= 0 Then cxArg = PI2 Else cxArg = -PI2 Else If Op.R > 0 Then cxArg = Atn(Op.I / Op.R) ElseIf Op.R < 0 And Op.I > 0 Then cxArg = PI + Atn(Op.I / Op.R) ElseIf Op.R < 0 And Op.I < 0 Then cxArg = -PI + Atn(Op.I / Op.R) End If End If End Function ' // Returns the number e, raised to power by complex number Public Function cxExp(Op As Complex) As Complex cxExp.R = Exp(Op.R) * Cos(Op.I): cxExp.I = Exp(Op.R) * Sin(Op.I) End Function ' // Addition real number and complex number Public Function cxAddReal(Op1 As Complex, ByVal Op2 As Double) As Complex cxAddReal.R = Op1.R + Op2 cxAddReal.I = Op1.I End Function ' // Subtraction from complex number a real number Public Function cxSubReal(Op1 As Complex, ByVal Op2 As Double) As Complex cxSubReal.R = Op1.R - Op2 cxSubReal.I = Op1.I End Function ' // Subtraction from real number a complex number Public Function cxRealSub(ByVal Op1 As Double, Op2 As Complex) As Complex cxRealSub.R = Op1 - Op2.R cxRealSub.I = -Op2.I End Function ' // Multiplication complex number on a real number Public Function cxMulReal(Op1 As Complex, ByVal Op2 As Double) As Complex cxMulReal.R = Op1.R * Op2 cxMulReal.I = Op1.I * Op2 End Function ' // Division a complex number on a real number Public Function cxDivReal(Op1 As Complex, ByVal Op2 As Double) As Complex Dim R2 As Double R2 = Op2 * Op2 cxDivReal.R = (Op1.R * Op2) / R2 cxDivReal.I = (Op1.I * Op2) / R2 End Function ' // Division a real number on a complex number Public Function cxRealDiv(ByVal Op1 As Double, Op2 As Complex) As Complex Dim R2 As Double, i2 As Double R2 = Op2.R * Op2.R: i2 = Op2.I * Op2.I cxRealDiv.R = (Op1 * Op2.R) / (R2 + i2) cxRealDiv.I = (-Op1 * Op2.I) / (R2 + i2) End Function ' // Addition of a complex number and imaginary part Public Function cxAddImg(Op1 As Complex, ByVal Op2 As Double) As Complex cxAddImg.R = Op1.R cxAddImg.I = Op1.I + Op2 End Function ' // Subtraction from a complex number a imaginary part Public Function cxSubImg(ByVal Op1 As Complex, Op2 As Double) As Complex cxSubImg.R = Op1.R cxSubImg.I = Op1.I - Op2 End Function ' // Subtraction from imaginary part a complex number Public Function cxImgSub(ByVal Op1 As Double, Op2 As Complex) As Complex cxImgSub.R = -Op2.R cxImgSub.I = Op1 - Op2.I End Function ' // Multiplication complex number on a imaginary part Public Function cxMulImg(Op1 As Complex, ByVal Op2 As Double) As Complex cxMulImg.R = -Op1.I * Op2 cxMulImg.I = Op1.R * Op2 End Function ' // Division a complex number on a imaginary part Public Function cxDivImg(Op1 As Complex, ByVal Op2 As Double) As Complex Dim i2 As Double i2 = Op2 * Op2 cxDivImg.R = (Op1.I * Op2) / i2 cxDivImg.I = (-Op1.R * Op2) / i2 End Function ' // Division imaginary part on a complex number Public Function cxImgDiv(ByVal Op1 As Double, Op2 As Complex) As Complex Dim R2 As Double, i2 As Double R2 = Op2.R * Op2.R: i2 = Op2.I * Op2.I cxImgDiv.R = (Op1 * Op2.I) / (R2 + i2) cxImgDiv.I = (Op1 * Op2.R) / (R2 + i2) End Function ' // Return true if complex number is equal Public Function cxEq(Op1 As Complex, Op2 As Complex, _ Optional NumDigitsAfterDecimal As Long = -1) As Boolean If NumDigitsAfterDecimal = -1 Then If Op1.R = Op2.R And Op1.I = Op2.I Then cxEq = True Else If Round(Op1.R, NumDigitsAfterDecimal) = Round(Op2.R, NumDigitsAfterDecimal) And _ Round(Op1.I, NumDigitsAfterDecimal) = Round(Op2.I, NumDigitsAfterDecimal) Then cxEq = True End If End Function ' // Return absolute value of a complex number Public Function cxAbs(Op As Complex) As Double If Op.I = 0 Then cxAbs = 0 ElseIf Op.R > Op.I Then cxAbs = Sqr(1 + (Op.I * Op.I) / (Op.R * Op.R)) ElseIf Op.R <= Op.I Then cxAbs = Sqr(1 + (Op.R * Op.R) / (Op.I * Op.I)) End If End Function ' // Return complex conjugate of complex number Public Function cxConj(Op As Complex) As Complex cxConj.R = Op.R cxConj.I = -Op.I End Function ' // The natural logarithm of a complex number Public Function cxLog(Op As Complex) As Complex Dim M As Double, A As Double M = cxMod(Op): A = cxArg(Op) cxLog.R = Log(M): cxLog.I = A End Function ' // The logarithm of a complex number by base X Public Function cxLogX(Op As Complex, ByVal Base As Double) As Complex Dim M As Double, A As Double, Nc As Complex M = cxMod(Op): A = cxArg(Op): Nc.R = Log(Base) cxLogX.R = Log(M): cxLogX.I = A cxLogX = cxDiv(cxLogX, Nc) End Function ' // Sine of a complex number Public Function cxSin(Op As Complex) As Complex cxSin.R = Sin(Op.R) * Cosh(Op.I): cxSin.I = Cos(Op.R) * Sinh(Op.I) End Function ' // Cosine of a complex number Public Function cxCos(Op As Complex) As Complex cxCos.R = Cos(Op.R) * Cosh(Op.I): cxCos.I = -Sin(Op.R) * Sinh(Op.I) End Function ' // Tangent of a complex number Public Function cxTan(Op As Complex) As Complex Dim C2 As Double, S2 As Double C2 = Cos(Op.R): C2 = C2 * C2: S2 = Sinh(Op.I): S2 = S2 * S2 cxTan.R = (Sin(Op.R) * Cos(Op.R)) / (C2 + S2) cxTan.I = (Sinh(Op.I) * Cosh(Op.I)) / (C2 + S2) End Function ' // Cotangent of a complex number Public Function cxCtg(Op As Complex) As Complex Dim C2 As Double, S2 As Double C2 = Sin(Op.R): C2 = C2 * C2: S2 = Sinh(Op.I): S2 = S2 * S2 cxCtg.R = (Sin(Op.R) * Cos(Op.R)) / (C2 + S2) cxCtg.I = -(Sinh(Op.I) * Cosh(Op.I)) / (C2 + S2) End Function ' // Secant of a complex number Public Function cxSec(Op As Complex) As Complex Dim C2 As Double, S2 As Double C2 = Cos(Op.R): C2 = C2 * C2: S2 = Sinh(Op.I): S2 = S2 * S2 cxSec.R = (Cos(Op.R) * Cosh(Op.I)) / (C2 + S2) cxSec.I = -(Sin(Op.R) * Sinh(Op.I)) / (C2 + S2) End Function ' // Cosecant of a complex number Public Function cxCsc(Op As Complex) As Complex Dim C2 As Double, S2 As Double C2 = Sin(Op.R): C2 = C2 * C2: S2 = Sinh(Op.I): S2 = S2 * S2 cxCsc.R = (Sin(Op.R) * Cosh(Op.I)) / (C2 + S2) cxCsc.I = (Cos(Op.R) * Sinh(Op.I)) / (C2 + S2) End Function ' // Arcsine of a complex number Public Function cxAsin(Op As Complex) As Complex cxAsin = cxMulImg(cxLog(cxAdd(cxMulImg(Op, 1), cxSqr(cxRealSub(1, cxMul(Op, Op))))), -1) End Function ' // Arccosine of a complex number Public Function cxAcos(Op As Complex) As Complex cxAcos = cxAddReal(cxMulImg(cxLog(cxAdd(cxMulImg(Op, 1), cxSqr(cxRealSub(1, cxMul(Op, Op))))), 1), PI2) End Function ' // Arctangent of a complex number Public Function cxAtan(Op As Complex) As Complex Dim Iz As Complex Iz = cxMulImg(Op, 1) cxAtan = cxMulImg(cxSub(cxLog(cxRealSub(1, Iz)), cxLog(cxAddReal(Iz, 1))), 0.5) End Function ' // Arccotangent of a complex number Public Function cxActg(Op As Complex) As Complex cxActg = cxMulImg(cxSub(cxLog(cxDiv(cxSubImg(Op, 1), Op)), cxLog(cxDiv(cxAddImg(Op, 1), Op))), 0.5) End Function ' // Arcsecant of a complex number Public Function cxAsec(Op As Complex) As Complex cxAsec = cxAcos(cxDgr(Op, -1)) End Function ' // Arccosecant of a complex number Public Function cxAcsc(Op As Complex) As Complex cxAcsc = cxAsin(cxDgr(Op, -1)) End Function ' // Hyperbolic sine of a complex number Public Function cxSinh(Op As Complex) As Complex cxSinh = cxMulImg(cxSin(cxMulImg(Op, 1)), -1) End Function ' // Hyperbolic cosine of a complex number Public Function cxCosh(Op As Complex) As Complex cxCosh = cxCos(cxMulImg(Op, 1)) End Function ' // Hyperbolic tangent of a complex number Public Function cxTanh(Op As Complex) As Complex cxTanh = cxMulImg(cxTan(cxMulImg(Op, 1)), -1) End Function ' // Hyperbolic cotangent of a complex number Public Function cxCtgh(Op As Complex) As Complex cxCtgh = cxRealDiv(1, cxTanh(Op)) End Function ' // Hyperbolic secant of a complex number Public Function cxSech(Op As Complex) As Complex cxSech = cxRealDiv(1, cxCosh(Op)) End Function ' // Hyperbolic cosecant of a complex number Public Function cxCsch(Op As Complex) As Complex cxCsch = cxRealDiv(1, cxSinh(Op)) End Function ' // Hyperbolic arcsine of a complex number Public Function cxAsinh(Op As Complex) As Complex cxAsinh = cxLog(cxAdd(Op, cxSqr(cxAddReal(cxMul(Op, Op), 1)))) End Function ' // Hyperbolic arccosine of a complex number Public Function cxAcosh(Op As Complex) As Complex cxAcosh = cxLog(cxAdd(Op, cxMul(cxSqr(cxAddReal(Op, 1)), cxSqr(cxSubReal(Op, 1))))) End Function ' // Hyperbolic arctangent of a complex number Public Function cxAtanh(Op As Complex) As Complex cxAtanh = cxMulReal(cxLog(cxDiv(cxAddReal(Op, 1), cxRealSub(1, Op))), 0.5) End Function ' // Hyperbolic arccotangent of a complex number Public Function cxActgh(Op As Complex) As Complex cxActgh = cxMulReal(cxLog(cxDiv(cxAddReal(Op, 1), cxSubReal(Op, 1))), 0.5) End Function ' // Hyperbolic arcsecant of a complex number Public Function cxAsech(Op As Complex) As Complex Dim Z As Complex Z = cxRealDiv(1, Op) cxAsech = cxLog(cxAdd(Z, cxSqr(cxAddReal(cxMul(Z, Z), 1)))) End Function ' // Hyperbolic arccosecant of a complex number Public Function cxAcsch(Op As Complex) As Complex Dim Z As Complex Z = cxRealDiv(1, Op) cxAcsch = cxLog(cxAdd(Z, cxMul(cxSqr(cxAddReal(Z, 1)), cxSqr(cxSubReal(Z, 1))))) End Function ' // Print matrix to immediate window Public Function PrintMtrx(Op As Matrix) Dim Ts As String, I As Long, j As Long Debug.Print vbNewLine Debug.Print "Col= " & Op.Col & " ; Row= " & Op.Row For I = 0 To Op.Row - 1: For j = 0 To Op.Col - 1 Ts = Space(10) LSet Ts = Str(Round(Op.D(I * Op.Col + j), 3)) Debug.Print Ts; Next: Debug.Print vbNewLine;: Next End Function ' // Creating a matrix Public Function mxCreate(ByVal Row As Long, ByVal Col As Long, ParamArray Y()) As Matrix Dim P As Variant, C As Long If Row <= 0 Or Col <= 0 Then Exit Function If Row * Col < UBound(Y) + 1 Then Exit Function mxCreate.Row = Row: mxCreate.Col = Col ReDim mxCreate.D(Row * Col - 1): C = 0 For Each P In Y mxCreate.D(C) = P: C = C + 1 Next End Function ' // Creating the null-matrix Public Function mxNull(ByVal Row As Long, ByVal Col As Long) As Matrix If Row <= 0 Or Col <= 0 Then Exit Function ReDim mxNull.D(Row * Col - 1): mxNull.Col = Col: mxNull.Row = Row End Function ' // Creating the identity matrix Public Function mxIdt(ByVal Size As Long) As Matrix Dim ij As Long If Size <= 0 Then Exit Function ReDim mxIdt.D(Size * Size - 1): mxIdt.Col = Size: mxIdt.Row = Size For ij = 0 To Size - 1: mxIdt.D(ij + (ij * Size)) = 1: Next End Function ' // Transpose matrix Public Function mxTrans(Op As Matrix) As Matrix Dim I As Long, j As Long, P As Long GetMem4 ByVal ArrPtr(Op.D), P: If P = 0 Then Exit Function mxTrans.Row = Op.Col: mxTrans.Col = Op.Row: ReDim mxTrans.D(UBound(Op.D)) For j = 0 To mxTrans.Col - 1: For I = 0 To mxTrans.Row - 1 mxTrans.D(I + j * mxTrans.Row) = Op.D(j + I * Op.Row) Next: Next End Function ' // Multiplication matrix on a real number Public Function mxMulReal(Op As Matrix, Op2 As Double) As Matrix Dim P As Long, ij As Long GetMem4 ByVal ArrPtr(Op.D), P: If P = 0 Then Exit Function ReDim mxMulReal.D(UBound(Op.D)): mxMulReal.Col = Op.Col: mxMulReal.Row = Op.Row For ij = 0 To UBound(Op.D): mxMulReal.D(ij) = Op.D(ij) * Op2: Next End Function ' // Addition of a two matrix Public Function mxAdd(Op1 As Matrix, Op2 As Matrix) As Matrix Dim P As Long, ij As Long GetMem4 ByVal ArrPtr(Op1.D), P: If P = 0 Then Exit Function GetMem4 ByVal ArrPtr(Op2.D), P: If P = 0 Then Exit Function If Op1.Col <> Op2.Col Or Op1.Row <> Op2.Row Then Exit Function ReDim mxAdd.D(UBound(Op1.D)): mxAdd.Col = Op1.Col: mxAdd.Row = Op1.Row For ij = 0 To UBound(Op1.D): mxAdd.D(ij) = Op1.D(ij) + Op2.D(ij): Next End Function ' // Subtaction of a two matrix Public Function mxSub(Op1 As Matrix, Op2 As Matrix) As Matrix Dim P As Long, ij As Long GetMem4 ByVal ArrPtr(Op1.D), P: If P = 0 Then Exit Function GetMem4 ByVal ArrPtr(Op2.D), P: If P = 0 Then Exit Function If Op1.Col <> Op2.Col Or Op1.Row <> Op2.Row Then Exit Function ReDim mxSub.D(UBound(Op1.D)): mxSub.Col = Op1.Col: mxSub.Row = Op1.Row For ij = 0 To UBound(Op1.D): mxSub.D(ij) = Op1.D(ij) - Op2.D(ij): Next End Function ' // Multiplication of a two matrix Public Function mxMul(Op1 As Matrix, Op2 As Matrix) As Matrix Dim P As Long, I As Long, j As Long, k As Long, iM As Long, i1 As Long, i2 As Long GetMem4 ByVal ArrPtr(Op1.D), P: If P = 0 Then Exit Function GetMem4 ByVal ArrPtr(Op2.D), P: If P = 0 Then Exit Function If Op1.Col <> Op2.Row Then Exit Function ReDim mxMul.D(Op1.Row * Op2.Col - 1): mxMul.Col = Op2.Col: mxMul.Row = Op1.Row ' For i = 0 To Op1.Row - 1: For j = 0 To Op2.Col - 1: mxMul.D(i * Op2.Col + j) = 0 ' For k = 0 To Op1.Col - 1 ' mxMul.D(i * mxMul.Col + j) = mxMul.D(i * mxMul.Col + j) + Op1.D(i * Op1.Col + k) * Op2.D(k * Op2.Col + j) ' Next ' Next: Next For I = 0 To Op1.Row - 1 For j = 0 To Op2.Col - 1 i2 = j For k = 0 To Op1.Col - 1 mxMul.D(iM) = mxMul.D(iM) + Op1.D(i1 + k) * Op2.D(i2) i2 = i2 + Op2.Col Next iM = iM + 1 Next i1 = i1 + Op1.Col Next End Function ' // Determinant of a square matrix Public Function mxDtm(Op As Matrix) As Double Dim P1 As Long, P2 As Long, ij1 As Long, ij2 As Long, Ct As Long, L As Long, T1 As Double, T2 As Double GetMem4 ByVal ArrPtr(Op.D), P1: If P1 = 0 Then Exit Function If Op.Col <> Op.Row Then Exit Function P2 = Op.Col - 1: ij1 = 0: ij2 = P2: Ct = Op.Col * Op.Row: P1 = Op.Col + 1 For k = 0 To Op.Col - 1 T1 = Op.D(ij1): T2 = Op.D(ij2) For L = 1 To Op.Col - 1 ij1 = (ij1 + P1) Mod Ct: ij2 = (ij2 + P2) Mod Ct T1 = T1 * Op.D(ij1): T2 = T2 * Op.D(ij2) Next mxDtm = mxDtm + T1 - T2: ij1 = (ij1 + P1) Mod Ct: ij2 = (ij2 + P2) Mod Ct Next End Function
Source:
http://www.vbforums.com/showthread.php?789035-VB6-Module-with-advanced-mathematical-functions-for-real-and-complex-numbers
No comments:
Post a Comment