Private Sub Command2_Click()
Command2.Caption = "Ждите, считаю. Не кликать."
Comsavepic.Caption = ""
Picture1.Cls
Dim EL(100000) As Double, Ep(100000) As Double, X, x1, Y, y1, NofCoats As Long, MSun As Double, RSun As Double, LSun, Lobj, Eshell As Double, truth As Long, tpru As Integer, Nmin As Double, Pmin As Double, Tmin As Double, Nmax As Double, iNmax As Long, Pmax As Double, iPmax As Long, Gmax As Double, h As Double, U(100000) As Double
Dim kmin As Double, kmax As Double, k As Double, dr As Double, ddr As Double, mp, mn, mM, mg, mT, GN As Double, pi As Double, c As Double, sigma As Double, kB As Double, mat As Double, pm(100000) As Double, pR(100000) As Double, dm(100000) As Double, M(100000) As Double, p(100000) As Double
Dim Dens As Double, GrdT As Integer, GrdT0 As Integer, Sym As Integer, Sh As Integer, Ash As Integer, Gam As Integer, Up As Integer, Bet As Integer, J As Integer, Q As Integer, Sch As Single, TG As Double, n(100000) As Double, T(100000) As Double, R(100000) As Double, g(100000) As Double, i As Long
Dim Tmax As Double, Nscl As Double, cor As Double, plqd As Double, Tlqd As Double, kp As Double, kT As Double, LqdEnd As Long, Lqd0 As Long, Lqd As Integer, Ep1(100000) As Double, Ek1 As Double, Er1 As Double, Ho As Double, Uo As Double
Picture1.DrawWidth = 1: Picture1.ScaleHeight = 110: Picture1.ScaleWidth = 210
Picture1.AutoRedraw = True
pi = 4# * Atn(1):
'Вводим массу частицы, гравитационную константу, скорость света, постоянную Больцмана, Стефана-Больцмана постоянную.
mat = Textmat * 1.66053873E-27: GN = 6.67259E-11: c = 299792458#: kB = 1.3806503E-23: sigma = 0.000000056704
'Масса, радиус, светимость Солнца.
MSun = 1.9891E+30: RSun = 696100000# ': LSun = 3.846E+26
'Масса, радиус, светимость объекта.
M(0) = TextM * MSun:  'Lobj = TextL * 1000000#
TG = TextTG * 1000000
Dens = TextDense: kp = Textkp: kT = TextkT
Sch = Schvarts ': Lqd0 = 0: LqdEnd = 0
NofCoats = TextN 'количество слоев
L0: ' от Dens n.
truth = 0:
tpru = 0:
For i = 0 To NofCoats
g(i) = 0: pm(i) = 0: dm(i) = 0: pR(i) = 0: p(i) = 0: n(i) = 0: T(i) = 0
Next
R(0) = TextR * RSun
dr = R(0) / NofCoats 'толщина слоя
ddr = dr / 2  'половинка толщины слоя
R(1) = R(0) - ddr
g(0) = M(0) * GN / R(0) ^ 2 'ускорение g на поверхности объекта
If Optstandart.Value = True Or Optstandartasym = True Then
Bet = 0#
Else
Bet = 2#
End If
If Optasym.Value = True Or Optsym.Value = True Or Optshellasym = True Or Optstandartasym = True Then
  Gam = 3#
  If Optsym.Value = True Then
    Sym = 1#
    Else
    Sym = 0#
    End If
  Else
  Gam = 0#
End If
If Optshell = True Or Optshellasym = True Then
Sh = 1#: Ash = 0#
Else
Sh = 0#: Ash = 1#
End If
If dTdr0.Value = True Then
GrdT = 0: GrdT0 = 1
Else
GrdT = 1: GrdT0 = 0
End If
If dTdr0.Value = True Or Optshell = True Or Optshellasym = True Then
T(0) = TG: T(1) = TG + GrdT * (2# / Sch) * g(0) * mat * ddr / kB
Else
T(0) = 0: T(1) = (2# / Sch) * g(0) * mat * ddr / kB
End If
Up = 0: k = 100000000000#: kmax = 1E+24: kmin = 1 / 10000000#
L1:
If Up = 1 Then
kmin = k
k = Sqr(kmin * kmax)
End If
If Up = -1 Then
kmax = k
k = Sqr(kmin * kmax)
End If
If (kmax - k) < k / 1E+15 Then
tpru = 1#: GoTo L1pic
End If
Lqd = 0: cor = (1 + kp) * (1 - GrdT * kT)
If dTdr0.Value = True Or Optshell = True Or Optshellasym = True Then
pm(0) = k: pR(0) = Gam / 3 * 4 * sigma * T(0) ^ 4 / c / 3: p(0) = pR(0) + pm(0): n(0) = pm(0) / kB / T(0)
Ho = 10 / 3 * pi * R(0) ^ 3 * p(0): Uo = 2 * pi * R(0) ^ 3 * p(0):
p(1) = p(0) - (-mat * (n(0)) * g(0) - Gam * pR(0) / c ^ 2 * g(0) + (Bet * (pm(0)) + Bet * Sym * pR(0) - 2 * Sh * p(0)) / R(0)) * ddr
Else
p(1) = k
End If
pR(1) = Gam / 3 * (4 * sigma * T(1) ^ 4 / c / 3)
pm(1) = p(1) - pR(1): n(1) = pm(1) / kB / T(1)
dm(1) = 2 * pi * R(1) * R(0) * ((n(0) + n(1)) * mat + Gam * (pR(0) + pR(1)) / c ^ 2) * ddr
M(1) = M(0) - dm(1): g(1) = GN * M(1) / R(1) ^ 2
U(1) = (pm(1) + pm(0)) * 3# * pi * R(1) * R(0) * ddr: Ep(1) = -GN * M(1) * dm(1) / R(1): EL(1) = (pR(1) + pR(0)) * 6 * pi * R(1) * R(0) * ddr
Ep1(1) = mat * g(1) * ddr: Er1 = (pR(1) - pR(0)) / n(1)
       For i = 2 To NofCoats
       R(i) = R(i - 1) - dr: dm(i) = dm(i - 1) + 4 * pi * R(i) * R(i - 1) * ((2 * n(i - 1) - n(i - 2)) * mat + Gam * (2 * pR(i - 1) - pR(i - 2)) / c ^ 2) * dr: M(i) = M(0) - dm(i): g(i) = GN * M(i) / R(i) ^ 2
       T(i) = T(i - 1) + GrdT * mat * g(i) / kB * (2 / Sch) * dr
       pR(i) = Gam / 3 * (4 * sigma * T(i) ^ 4 / c / 3)
       p(i) = p(i - 1) - (-mat * (2 * n(i - 1) - n(i - 2)) * g(i) - Gam * pR(i) / c ^ 2 * g(i) + (Bet * (2 * pm(i - 1) - pm(i - 2)) + Bet * Sym * pR(i) - 2 * Sh * p(1)) / R(i)) * dr
       pm(i) = p(i) - pR(i)
       n(i) = pm(i) / kB / T(i)
       If mat * n(i) > Dens * cor Then
         If Lqd = 0 Then
           plqd = p(i): Tlqd = T(i): Lqd0 = i
           n(i) = Dens / mat * cor: Lqd = 1
           Else
           cor = (1 + kp * p(i) / plqd) * (1 - GrdT * kT * T(i) / Tlqd)
           n(i) = Dens / mat * cor
           LqdEnd = i
         End If
       End If
       EL(i) = EL(i - 1) + (pR(i) + pR(i - 1)) * 6 * pi * R(i) * R(i - 1) * dr
       Ep(i) = Ep(i - 1) - GN * M(i) * (dm(i) - dm(i - 1)) / R(i)
       U(i) = U(i - 1) + (pm(i) + pm(i - 1)) * 3# * pi * R(i) * R(i - 1) * dr:
       Ep1(i) = Ep1(i - 1) + mat * g(i) * dr: Er1 = Er1 + (pR(i) - pR(i - 1)) / n(i)
 If (g(i) > (1 + 12 / NofCoats) * g(i - 1) Or g(i) > 1E+20) And tpru = 0 Then
       truth = i: Up = 1
            If CheckShaw.Value = 1 Then
            GoTo L1pic
            Else
            GoTo L1
            End If
       End If
       If tpru = 0 And g(i) < 0 Then
       truth = i: Up = -1:
            If CheckShaw.Value = 1 Then
            GoTo L1pic
            Else
            GoTo L1
            End If
       End If
Next
If n(1) * mat > Dens * cor Then
TextDense.BackColor = &HFF&
TextDense = n(1) * mat
Dens = TextDense
TextDense.BackColor = &H80000005
GoTo L0
End If
L1pic:
Nscl = 1 - Lqd * (LqdEnd - Lqd0) / NofCoats
'Находим минимальные и максимальные значения величин.
Nmax = n(0): Pmax = p(0): Gmax = g(0)
Nmin = 0: Pmin = 0: Gmax = g(0):
Tmax = T(0): Tmin = 0
For i = 1 To truth
    If p(i) > Pmax Then
    Pmax = p(i): iPmax = i
    End If
    If p(i) < Pmin Then
    Pmin = p(i)
    End If
    If n(i) > Nmax Then
    Nmax = n(i): iNmax = i
    End If
    If n(i) < Nmin Then
    Nmin = n(i)
    End If
    If g(i) > Gmax Then
    Gmax = g(i)
    End If
    If T(i) > Tmax Then
    Tmax = T(i)
    End If
    If T(i) < Tmin Then
    Tmin = T(i)
    End If
Next
'Вводим нормирующие множители для графиков: mg к ускорению, mM к массе,..
mM = 100 / M(0): mT = 100 / (Tmax - Tmin): mp = 100 / (Pmax - Pmin): mn = Nscl * 100 / (Nmax - Nmin)
mg = 100 / Gmax
For Q = 5 To 205 Step 10
Picture1.Line (Q, 5)-(Q, 105), RGB(100, 100, 100)
Next
For Q = 5 To 105 Step 10
Picture1.Line (5, Q)-(205, Q), RGB(100, 100, 100)
Next
For i = 1 To truth  'Строим графики
X = 205 - 100 / NofCoats * (i - 1): x1 = X - 100 / NofCoats
Y = 105 - pR(i - 1) * mp: y1 = 105 - pR(i) * mp: Picture1.Line (X, Y)-(x1, y1), RGB(250, 250, 0) 'давление излучения в i-том слое
Y = 105 + (Pmin - p(i - 1)) * mp: y1 = 105 + (Pmin - p(i)) * mp: Picture1.Line (X, Y)-(x1, y1), RGB(250, 120, 0) 'давление в i-том слое
Y = 105 - pm(i - 1) * mp: y1 = 105 - pm(i) * mp: Picture1.Line (X, Y)-(x1, y1), RGB(255, 0, 0) 'давление вещества в i-том слое
Y = 105 + (Nmin - n(i - 1)) * mn: y1 = 105 + (Nmin - n(i)) * mn: Picture1.Line (X, Y)-(x1, y1), RGB(0, 255, 0) 'концентрация в i-том слое
Y = 104 + (Tmin - T(i - 1)) * mT: y1 = 104 + (Tmin - T(i)) * mT: Picture1.Line (X, Y)-(x1, y1), RGB(250, 250, 250) 'температура в i-том слое
Y = 105 - g(i - 1) * mg: y1 = 105 - g(i) * mg: Picture1.Line (X, Y)-(x1, y1), RGB(0, 250, 250) 'ускорение g в i-том слое
X = 5 + 100 / NofCoats * (i - 1): x1 = X + 100 / NofCoats
Y = 105 - pR(i - 1) * mp: y1 = 105 - pR(i) * mp: Picture1.Line (X, Y)-(x1, y1), RGB(250, 250, 0)
Y = 105 + (Pmin - p(i - 1)) * mp: y1 = 105 + (Pmin - p(i)) * mp: Picture1.Line (X, Y)-(x1, y1), RGB(250, 120, 0)
Y = 105 + (Nmin - n(i - 1)) * mn: y1 = 105 + (Nmin - n(i)) * mn: Picture1.Line (X, Y)-(x1, y1), RGB(0, 255, 0)
Y = 105 - pm(i - 1) * mp: y1 = 105 - pm(i) * mp: Picture1.Line (X, Y)-(x1, y1), RGB(255, 0, 0)
Y = 104 + (Tmin - T(i - 1)) * mT: y1 = 104 + (Tmin - T(i)) * mT: Picture1.Line (X, Y)-(x1, y1), RGB(250, 250, 250)
Y = 105 - g(i - 1) * mg: y1 = 105 - g(i) * mg: Picture1.Line (X, Y)-(x1, y1), RGB(0, 250, 250)
Next
            If CheckShaw.Value = 1 Then
            If tpru = 0 Then
            PauseTime = 0.04
            Start = Timer   ' Set start time.
            Do While Timer < Start + PauseTime
            DoEvents    ' Yield to other processes.
            Loop
            Finish = Timer  ' Set end time.
            Picture1.Cls
            GoTo L1
            End If
            End If
h = 5 / 3 * U(truth) 'энтальпия
If truth < Int(9 / 10 * NofCoats) And NofCoats > 20 And dTdr0.Value = True Then
Text1 = " Масса объекта выработана слишком далеко от центра. Попытайтесь поднять температуру объекта, либо уменьшить плотность конденсации, либо..."
TextTG.BackColor = &HFF&
TextDense.BackColor = &HFF&
GoTo L13
End If
If truth < Int(99 / 100 * NofCoats) And Optsym.Value = True Then
Text1 = " Масса объекта выработана слишком далеко от центра, поскольку выбрано симметричное уравнение: d(p+p')/dr=-(rho+rho')*g+2(p+p')/r. Устранить центральную пропасть можно только сменой уравнения гидростатического равновесия, либо добавить уравнение dT/dr=0, либо..."
Optsym.BackColor = &HFF&
GoTo L13
End If
Text1 = " Классический вириал: -P/(2U)=" & CSng(-Ep(truth) / (2 * U(truth)))
If Optstandart.Value = True And dTdr0.Value = True Then
Text1 = Text1 & " Одно из новых вириальных отношений: -P/(2U-2Uo)=" & CSng(-Ep(truth) / (2 * U(truth) - 2 * Uo))
End If
If Optmatter.Value = True Then
If dTdr0.Value = True Then
Text1 = Text1 & " Одно из новых вириальных отношений: -P/(2H-2Uo)=" & CSng((-Ep(truth)) / (2 * h - 2 * Uo))
Else
Text1 = Text1 & " Одно из новых вириальных отношений: (-P)/(2H)=" & CSng(((-Ep(truth)) / (2 * h)))
End If
End If
If Optasym.Value = True Then
If dTdr0.Value = True Then
Text1 = Text1 & " Одно из новых вириальных отношений: (-P-L)/(2H-2Uo)=" & CSng((-Ep(truth) - EL(truth)) / (2 * h - 2 * Uo))
Else
Text1 = Text1 & " Одно из новых вириальных отношений: (-P-L)/(2H)=" & CSng((-Ep(truth) - EL(truth)) / (2 * h))
End If
End If
If Optshell.Value = True Then
Text1 = Text1 & " Одно из новых вириальных отношений: =-P/(2H-2Ho)=" & CSng(-Ep(truth) / (2 * h - 2 * Ho))
End If
If Optshellasym.Value = True Then
Text1 = Text1 & " Одно из новых вириальных отношений: (-P-L)/(2H-2Ho)=" & CSng((-Ep(truth) - EL(truth)) / (2 * h - 2 * Ho))
End If
If Optstandartasym.Value = True Then
If dTdr0.Value = True Then
Text1 = Text1 & " Одно из новых вириальных отношений: (-P-L)/(2U-2Uo)=" & CSng((-Ep(truth) - EL(truth)) / (2 * U(truth) - 2 * Uo))
Else
Text1 = Text1 & " Одно из новых вириальных отношений: (-P-L)/(2U)=" & CSng((-Ep(truth) - EL(truth)) / (2 * U(truth)))
End If
End If
Text1 = Text1 & " Температура на глубине R/" & 2 * TextN & " равна " & CSng(T(1) / 1000#) & " тыс.К. " & " Температура в центре, T_max=" & T(truth) / 1000000# & " млн К.  "
Text1 = Text1 & " " & dm(truth) / M(0) * 100 & "% массы объекта выработано в слое под №" & truth & " из " & TextN & " заданных."
If k / 100000# < 3.4E+38 And Pmax / 100000# < 3.4E+38 Then
Text1 = Text1 & " Максимальное давление газа " & CSng(Pmax / 101000) & "атм при r=" & CSng((truth - iPmax) / truth) & "R." & " Максимальная плотность m*n=" & CSng(mat * Nmax) & "кг/м^3 при r=" & CSng((truth - iNmax) / truth) & "R."
End If
If Lqd = 1 Then
Text1 = Text1 & " Жидкая фаза простирается от r1=" & CSng((truth - Lqd0) / truth) & "R. до r2=" & CSng((truth - LqdEnd) / truth) & "R."
End If
Text1 = Text1 & " Кин. энергия всех частиц объекта: K=" & U(truth) & "Дж. " & " Грав. потенц. энергия всех частиц: P=" & Ep(truth) & "Дж. "
If Gam = 3 Then
Text1 = Text1 & " Энерг.излучения,внутри_объекта: L=" & EL(truth) & "Дж. "
End If
If Sh = 1 Then
Text1 = Text1 & " Энтальпия объекта, созданная оболочкой Ho=Uo+Po*V=" & Ho & "Дж. " & " Внутренняя энергия объекта, созданная давлением оболочки: Uo=(3/2)*Po*V=" & Uo & "Дж. "
End If
Text1 = Text1 & " Потенциальная энергия частицы на поверхности объекта:" & GN * M(0) * mat / R(0) & "Дж. Работа грав-поля по перемещению частицы с поверхности объекта к центру:" & Ep1(truth) & "Дж. Работа градиента давления излучения по перемещению частицы из центра к поверхности объекта" & Er1 & "Дж. Кинетическая энергия частицы в центре: " & 3 / 2 * kB * T(truth) & "Дж."
Comsavepic.Visible = True: Comsavepic.Caption = "Сохранить рисунок"
Command2.Caption = "Введите другие данные и попробуйте еще раз."
TextDense.BackColor = &H80000005
TextN.BackColor = &H80000005
TextTG.BackColor = &H80000005
Optsym.BackColor = &H80FF80
L13:
End Sub

Private Sub Command2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If TextDense < (TextM * 1.9891E+30) / ((4 / 3) * 3.1415927 * (TextR * 696100000#) ^ 3) Then
Text1 = "Плотность конденсации была задана слишком маленькая! При данных массе и радиусе объекта её минимальное значение равно " & CSng((TextM * 1.9891E+30) / ((4 / 3) * 3.1415927 * (TextR * 696100000#) ^ 3)) & " кг/м^3. Во избежание ошибок мы введем значение в полтора раза больше минимального. Вы можете попробовать еще раз плавно уменьшить её значение и пронаблюдать за горизонтальным участком зелёного графика (конденсация газа в жидкость)."
TextDense.BackColor = &HFF&
TextDense = CSng(1.5 * (TextM * 1.9891E+30) / ((4 / 3) * 3.1415927 * (TextR * 696100000#) ^ 3))
End If
If CheckShaw.Value = 1 Then
If TextN > 801 Then
TextN = 200
TextN.BackColor = &HFF&
Text1 = " Количество слоев было задано слишком высокое. Мы его понизили с целью ускорения работы компьютера."
End If
End If
End Sub

Private Sub Comsavepic_Click()
SavePicture Picture1.Image, "arc.bmp"
Comsavepic.Caption = "Рисунок arc.bmp сохранён в папке этой программы"
End Sub
Private Sub Optmatter_GotFocus()
Text1 = " Это новое уравнение гидростатического равновесия для идеального газового объекта без излучения. В нём учитывается Эффект Арки."
End Sub

Private Sub Optshell_GotFocus()
Text1 = " Это новое уравнение гидростатического равновесия для идеального газового объекта без излучения, сжатого оболочкой с давлением p0. В уравнении учитывается Эффект Арки."
End Sub

Private Sub Optsym_GotFocus()
Text1 = " Это новое уравнение гидростатического равновесия для идеального газового объекта, наполненного излучением. Это уравнение симметрично по отношению к веществу и излучению. Однако оно не интегрируется, - масса объекта вырабатывается не доходя до центра объекта. Вероятно, излучение не подчиняется Эффекту Арки, так как фотоны не взаимодействуют между собой непосредственно."
End Sub

Private Sub Optasym_GotFocus()
Text1 = " Это новое уравнение гидростатического равновесия для идеального газового объекта, наполненного излучением. Это уравнение НЕ симметрично по отношению к веществу и излучению. В последнем слагаемом нет давления излучения, p'. Уравнение хорошо интегрируется."
End Sub

Private Sub Optshellasym_GotFocus()
Text1 = " Это новое уравнение гидростатического равновесия для идеального газового объекта, наполненного излучением, и сжатого оболочкой с давлением p0. Это уравнение НЕ симметрично по отношению к веществу и излучению. В последнем слагаемом нет давления излучения, p'. В реальных объектах давление оболочки может создавать испущенный свет. Ясно, что его температура исчисляется тысячами градусов, а не миллионами, которые мы включили по умолчанию для наглядности влияния оболочки на объект."
End Sub

Private Sub Optstandart_GotFocus()
Text1 = " Это классическое уравнение гидростатического равновесия для идеального газового объекта. По мнению автора этой программы оно ошибочно, т.к. не учитывает Эффект Арки. Тем не менее, работая с ним, мы замечаем, что настоящая программа работает правильно и выдает результаты, согласующиеся с результатами, описанными в литературе."
End Sub

Private Sub Optstandartasym_GotFocus()
Text1 = " Это классическое уравнение гидростатического равновесия для идеального газового объекта, наполненного излучением. По мнению автора этой программы оно ошибочно, т.к. не учитывает Эффект Арки. Тем не менее, работая с ним, мы замечаем, что настоящая программа работает правильно и выдает результаты, согласующиеся с результатами, описанными в литературе."
End Sub

Private Sub dTdr_GotFocus()
Text1 = " Это уравнение градиента температуры для идеального газового объекта. По моему мнению, градиент температуры будет существовать даже при отсутствии источников энергии в центре объекта. К сожалению, мне пока (07.03.2007) не удалось выяснить, чему же равен коэффициент. Наиболее вероятно он равен (2/5). Теплопроводность при этом будет равно нулю. Это чисто гравитационный градиент температуры. Если же учитывать источники энергии, то коэффициент градиента надо увеличить, а в уравнении теплопроводности надо учитывать не весь градиент температуры, а лишь его избыток над гравитационным градиентом температуры."
End Sub

Private Sub dTdr0_GotFocus()
Text1 = "Это уравнение нулевого градиента температуры. По моему мнению, оно ошибочно т.к. не учитывает гравитационный градиент температуры. При dT/dr=0, уравнения dp/dr не интегрируются, если мы не включим конденсацию газа в жидкость. Если же мы включим оба ошибочных уравнения, то на графике давления увидим параболу на жидкой фазе и экспоненту на газообразной фазе. Это соответствует результатам, описанным в литературе, и свидетельствует в пользу того, что эта программа работает правильно."
End Sub