Модуль с расширенными математическими функциями

Здесь можно найти готовые «кирпичики» — части кода, пригодные для построения более крупных проектов, а также решения различных типовых и не очень задач на VB.

Модератор: Brickgroup

The trick
Постоялец
Постоялец
 
Сообщения: 781
Зарегистрирован: 26.06.2010 (Сб) 23:08

Модуль с расширенными математическими функциями

Сообщение The trick » 11.03.2014 (Вт) 11:54

Код: Выделить всё
'+=====================================================================================================================================+
'+=====================================================================================================================================+
'|                                                                                                                                     |
'|                                   Дополнительный набор математических функций для 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
Public 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                 ' количество колонок
     Row As Long                 ' количество строк
     D() As Double
End Type
Public Const PI = 3.14159265358979
Public Const E = 2.71828182845905
Private Const PI2 = PI / 2

'+=====================================================================================================================================+
'|                                                        Вещественные числа                                                           |
'+=====================================================================================================================================+
Public Function Deg(ByVal Value As Double) As Double ' Из градусов в радианы
     Deg = 1.74532925199433E-02 * Value
End Function
Public Function LogX(ByVal Value As Double, ByVal Base As Double) As Double ' Логарифм вещественного числа по основанию Х
     LogX = Log(Value) / Log(Base)
End Function
Public Function Log10(ByVal Value As Double) As Double ' Десятичный логарифм вещественного числа
     Log10 = Log(Value) / 2.30258509299405
End Function
Public Function Log2(ByVal Value As Double) As Double ' Двоичный логарифм вещественного числа
     Log2 = Log(Value) / 0.693147180559945
End Function
Public Function Ceil(ByVal Value As Double) As Double ' Округление в большую сторону
     Ceil = -Int(-Value)
End Function
Public Function Floor(ByVal Value As Double) As Double ' Округление в меньшую сторону (Int)
     Floor = Int(Value)
End Function
Public Function Sec(ByVal Value As Double) As Double ' Секанс вещественного числа
     Sec = 1 / Cos(Value)
End Function
Public Function Csc(ByVal Value As Double) As Double ' Косеканс вещественного числа
     Csc = 1 / Sin(Value)
End Function
Public Function Ctg(ByVal Value As Double) As Double ' Котангенс вещественного числа
     Ctg = 1 / Tan(Value)
End Function
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
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
Public Function Asec(ByVal Value As Double) As Double ' Арксеканс вещественного числа
     Asec = 1.5707963267949 - Atn(Sgn(Value) / Sqr(Value * Value - 1))
End Function
Public Function Acsc(ByVal Value As Double) As Double ' Арккосеканс вещественного числа
     Acsc = Atn(Sgn(Value) / Sqr(Value * Value - 1))
End Function
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
Public Function Actg(ByVal Value As Double) As Double ' Арккотангенс вещественного числа
     Actg = 1.5707963267949 - Atn(Value)
End Function
Public Function Sinh(ByVal Value As Double) As Double ' Гиперболический синус вещественного числа
     Sinh = (Exp(Value) - Exp(-Value)) / 2
End Function
Public Function Cosh(ByVal Value As Double) As Double ' Гиперболический косинус вещественного числа
     Cosh = (Exp(Value) + Exp(-Value)) / 2
End Function
Public Function Tanh(ByVal Value As Double) As Double ' Гиперболический тангенс вещественного числа
     Tanh = (Exp(2 * Value) - 1) / (Exp(2 * Value) + 1)
End Function
Public Function Ctgh(ByVal Value As Double) As Double ' Гиперболический котангенс вещественного числа
     Ctgh = 1 / (Exp(2 * Value) + 1) / (Exp(2 * Value) - 1)
End Function
Public Function Sech(ByVal Value As Double) As Double ' Гиперболический секанс вещественного числа
     Sech = 2 / (Exp(Value) + Exp(-Value))
End Function
Public Function Csch(ByVal Value As Double) As Double ' Гиперболический косеканс вещественного числа
     Csch = 2 / (Exp(Value) - Exp(-Value))
End Function
Public Function Asinh(ByVal Value As Double) As Double ' Гиперболический ареасинус вещественного числа
     Asinh = Log(Value + Sqr(Value * Value + 1))
End Function
Public Function Acosh(ByVal Value As Double) As Double ' Гиперболический ареакосинус вещественного числа
     Acosh = Log(Value + Sqr(Value * Value - 1))
End Function
Public Function Atanh(ByVal Value As Double) As Double ' Гиперболический ареатангенс вещественного числа
     Atanh = Log((1 + Value) / (1 - Value)) / 2
End Function
Public Function Actan(ByVal Value As Double) As Double ' Гиперболический ареакотангенс вещественного числа
     Actan = Log((Value + 1) / (Value - 1)) / 2
End Function
Public Function Asech(ByVal Value As Double) As Double ' Гиперболический ареасеканс вещественного числа
     Asech = Log((Sqr(-Value * Value + 1) + 1) / Value)
End Function
Public Function Acsch(ByVal Value As Double) As Double ' Гиперболический ареакосеканс вещественного числа
     Acsch = Log((Sgn(Value) * Sqr(Value * Value + 1) + 1) / Value)
End Function
Public Function Max(ByVal Op1 As Double, ByVal Op2 As Double) As Double ' Возвращает максимальное из двух чисел
     Max = IIf(Op1 > Op2, Op1, Op2)
End Function
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
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
Public Function Min(ByVal Op1 As Double, ByVal Op2 As Double) As Double ' Возвращает минимальное из двух чисел
     Min = IIf(Op1 < Op2, Op1, Op2)
End Function
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
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
Public Function IEEERemainder(ByVal Op1 As Double, ByVal Op2 As Double) As Double ' Возвращает остаток от деления одного указанного числа на другое указанное число.
     IEEERemainder = Op1 - (Op2 * Round(Op1 / Op2))
End Function
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

'+=====================================================================================================================================+
'|                                                         Комплексные числа                                                           |
'+=====================================================================================================================================+
Public Function cxOne() As Complex ' R=1,I=0
     cxOne.R = 1
End Function
Public Function cxImgOne() As Complex ' R=0,I=1
     cxOne.I = 1
End Function
Public Function cxZero() As Complex ' R=0,I=0
End Function
Public Function cxNew(ByVal Real As Double, ByVal Imaginary As Double) As Complex ' Создание нового комплексного числа
     cxNew.R = Real: cxNew.I = Imaginary
End Function
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
Public Function cxNeg(Op As Complex) As Complex ' Возвращает аддитивную инверсию указанного комплексного числа
     cxNeg.R = -Op.R: cxNeg.I = -Op.I
End Function
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
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
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
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
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
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
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
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
Public Function cxPhase(Op As Complex) As Double ' Фаза комплексного числа
     cxPhase = Atan2(Op.I, Op.R)
End Function
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
Public Function cxExp(Op As Complex) As Complex ' Возвращает число e, возведенное в степень, определяемую комплексным числом
     cxExp.R = Exp(Op.R) * Cos(Op.I): cxExp.I = Exp(Op.R) * Sin(Op.I)
End Function
Public Function cxAddReal(Op1 As Complex, ByVal Op2 As Double) As Complex ' Сложение вещественного и комплексного числа
     cxAddReal.R = Op1.R + Op2
     cxAddReal.I = Op1.I
End Function
Public Function cxSubReal(Op1 As Complex, ByVal Op2 As Double) As Complex ' Вычитание из комплексного числа вещественного
     cxSubReal.R = Op1.R - Op2
     cxSubReal.I = Op1.I
End Function
Public Function cxRealSub(ByVal Op1 As Double, Op2 As Complex) As Complex ' Вычитание из действительного числа комплексного
     cxRealSub.R = Op1 - Op2.R
     cxRealSub.I = -Op2.I
End Function
Public Function cxMulReal(Op1 As Complex, ByVal Op2 As Double) As Complex ' Умножение комплексного числа на вещественное
     cxMulReal.R = Op1.R * Op2
     cxMulReal.I = Op1.I * Op2
End Function
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
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
Public Function cxAddImg(Op1 As Complex, ByVal Op2 As Double) As Complex ' Сложение комплексного числа и мнимого коэффициента
     cxAddImg.R = Op1.R
     cxAddImg.I = Op1.I + Op2
End Function
Public Function cxSubImg(ByVal Op1 As Complex, Op2 As Double) As Complex ' Вычитание из комплексного числа мнимого коэффициента
     cxSubImg.R = Op1.R
     cxSubImg.I = Op1.I - Op2
End Function
Public Function cxImgSub(ByVal Op1 As Double, Op2 As Complex) As Complex ' Вычитание из мнимого коэффициента комплексного
     cxImgSub.R = -Op2.R
     cxImgSub.I = Op1 - Op2.I
End Function
Public Function cxMulImg(Op1 As Complex, ByVal Op2 As Double) As Complex ' Умножение комплексного числа на мнимый коэффициент
     cxMulImg.R = -Op1.I * Op2
     cxMulImg.I = Op1.R * Op2
End Function
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
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
Public Function cxEq(Op1 As Complex, Op2 As Complex, _
                 Optional NumDigitsAfterDecimal As Long = -1) As Boolean ' True - если комплексные числа равны
     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
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
Public Function cxConj(Op As Complex) As Complex ' Сопряжение комплексного числа
     cxConj.R = Op.R
     cxConj.I = -Op.I
End Function
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
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
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
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
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
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
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
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
Public Function cxAsin(Op As Complex) As Complex ' Арксинус комплексного числа
     cxAsin = cxMulImg(cxLog(cxAdd(cxMulImg(Op, 1), cxSqr(cxRealSub(1, cxMul(Op, Op))))), -1)
End Function
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
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
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
Public Function cxAsec(Op As Complex) As Complex ' Арксеканс комплексного числа
     cxAsec = cxAcos(cxDgr(Op, -1))
End Function
Public Function cxAcsc(Op As Complex) As Complex ' Арккосеканс комплексного числа
     cxAcsc = cxAsin(cxDgr(Op, -1))
End Function
Public Function cxSinh(Op As Complex) As Complex ' Гиперболический синус комплексного числа
     cxSinh = cxMulImg(cxSin(cxMulImg(Op, 1)), -1)
End Function
Public Function cxCosh(Op As Complex) As Complex ' Гиперболический косинус комплексного числа
     cxCosh = cxCos(cxMulImg(Op, 1))
End Function
Public Function cxTanh(Op As Complex) As Complex ' Гиперболический тангенс комплексного числа
     cxTanh = cxMulImg(cxTan(cxMulImg(Op, 1)), -1)
End Function
Public Function cxCtgh(Op As Complex) As Complex ' Гиперболический котангенс комплексного числа
     cxCtgh = cxRealDiv(1, cxTanh(Op))
End Function
Public Function cxSech(Op As Complex) As Complex ' Гиперболический секанс комплексного числа
     cxSech = cxRealDiv(1, cxCosh(Op))
End Function
Public Function cxCsch(Op As Complex) As Complex ' Гиперболический косеканс комплексного числа
     cxCsch = cxRealDiv(1, cxSinh(Op))
End Function
Public Function cxAsinh(Op As Complex) As Complex ' Гиперболический ареасинус комплексного числа
     cxAsinh = cxLog(cxAdd(Op, cxSqr(cxAddReal(cxMul(Op, Op), 1))))
End Function
Public Function cxAcosh(Op As Complex) As Complex ' Гиперболический ареакосинус комплексного числа
     cxAcosh = cxLog(cxAdd(Op, cxMul(cxSqr(cxAddReal(Op, 1)), cxSqr(cxSubReal(Op, 1)))))
End Function
Public Function cxAtanh(Op As Complex) As Complex ' Гиперболический ареатангенс комплексного числа
     cxAtanh = cxMulReal(cxLog(cxDiv(cxAddReal(Op, 1), cxRealSub(1, Op))), 0.5)
End Function
Public Function cxActgh(Op As Complex) As Complex ' Гиперболический ареакотангенс комплексного числа
     cxActgh = cxMulReal(cxLog(cxDiv(cxAddReal(Op, 1), cxSubReal(Op, 1))), 0.5)
End Function
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
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
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
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
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
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
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
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
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
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
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
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
UA6527P

Вернуться в Кирпичный завод

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 7

    TopList