Subroutine GetParam iUGOL расчёт коэфф зависимости угла от приведённог

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
Subroutine GetParam(iUGOL) ! расчёт к коэфф. зависимости угла от приведённого времени.
Use FiParam
Integer iUGOL
Real(8),Parameter:: pi=3.141592653589793D0
Real(8) fiMax, fiKoeff
Real(8) tm, ym, tN, yN
fiMax = pi/180* iUGOL ! !fiMax=acos(1-h)
fiKoeff = 0.825D0 ! ГОДИТЬСЯ для РАБОТЫ
If(iUGOL > 170) fiKoeff = FiKoeff +0.125D0/9*(iUGOL-170)
Call GetXm(fiKoeff*FImax, FImax, tm) ! К вычислению средей точки !!! 0.825 --> 170 0.95 --> 179
ym = fiKoeff*fiMax;
p1 = sqrt(1D0-cos(fiMax))
tN = pi/sqrt(2D0)*wOTfiMax(abs(iUGOL)/5)
tauMax = tN; HalfPeriod=2*tauMax; Period = 4*tauMax
yN = fiMax
DD = ((tN - tm)*tm*tN)**2
AA =( (ym - p1*tm)*tN**4 +(3*p1*tN**2 - 2*(p1*tm + 2*yN)*tN + 3*yN*tm)*tm**3 ) / DD
DD = DD*tN
BB = ( 2*(p1*tm - ym)*tN**4 + tm**2*(tN**2*(4*yN - 3*p1*tN) + tm**2*(p1*tN - 2*yN)) ) / DD
CC = ( tN**3*(ym - p1*tm) + tm**2*(tN*(2*p1*tN - 3*yN) + tm*(2*yN - p1*tN)) ) / DD
End Subroutine GetParam
Subroutine GetXm(FIm, FImax, S) ! Вычислить угол время для промежуточной точки
Real(8) FIm, FImax, S
Integer N
Call SIMPS2_DP( F, 0D0 ,FIm, 0.000001D0, N, S )
Contains
Real(8) Function F(fi) ! подынтегральная функция безразмерного интеграла
Real(8) fi;
F = 1D0/sqrt(cos(fi) - cos(FImax))
End Function F
End Subroutine
Function FIotTAU( tau) ! функция для расчёта угла от приведённого времени
Use FiParam
Real(8) FIotTAU, tau, u, P, t
Integer K, L
P(t) = t*(p1 + t*(AA + t*(BB + t*CC)))
u = Mod(tau, Period)
K = int(u / HalfPeriod); u = Mod(tau, HalfPeriod)
L = int(u / tauMax); u = Mod(tau, tauMax)
If( K == 0 ) Then ! зоны I, II
If( L == 0 ) Then ! зона I
FIotTAU = -P(tauMax - u)
Else ! зона II
FIotTAU = P(u)
EndIf
Else ! зоны III, IV
If( L == 0 ) Then ! зона III
FIotTAU = P(tauMax - u)
Else ! зона IV
FIotTAU = -P(u)
EndIf
EndIf
End Function FIotTAU
Subroutine GraINI(X, Y, Z)
Use GraPARAM
Use IFQWin
Type (xyCoord) iPOld ! для хранения предыдущ. нач. координат
Real(8) X, Y, Z
Integer(2) i2
H_R8 = 6.3D0; W_R8 = 5D0 ! математ. размеры
H_i2 = 160; W_i2 = 640 ! физич. размеры в пикселах
iXprev0 = IIDNNT( Mod(X, W_R8) /W_R8*W_i2) ! ближайшее Integer(2)
iYprev0 = IIDNNT( (H_R8/2-Y)/H_R8*H_i2 )
iZprev0 = IIDNNT( (H_R8/2-Z)/H_R8*H_i2 )
iXprev1 = iXprev0; iYprev1 = iYprev0; iZprev1 = iZprev0
!i2 = SetColor(11) ! Начальная
!Call MoveTo(0,0,iPOld); i2 = LineTo(0, H_i2) ! отрисовка
!Call MoveTo(0,int2(H_i2/2),iPOld); i2 = LineTo(W_i2, int2(H_i2/2)) ! осей
End Subroutine GraINI
Subroutine GraDraw(X, Y, Z)
Use GraPARAM
Use IFQWin
Type (xyCoord) iPOld ! для хранения предыдущ. нач. координат
Real(8) X, Y, Z, xReL
Integer(2) i2, i2X, i2Y, i2Z
Integer,Save:: KodClear=0
xReL = Mod(X, W_R8) ! остаток
i2X = IIDNNT(xReL/W_R8*W_i2) ! ближайшее Integer(2)
If( i2X < iXprev0 ) Then
KodClear=2
iXprev0 = iXprev0 - W_i2
iXprev1 = iXprev1 - W_i2
EndIf
Call SetViewOrg(int2(8), int2 (8), iPOld) ! Установить положение физ. системы координат для области графика
If(KodClear >0 ) Then
i4res = SetColorRGB(#303030) ! Надо очищать два окна!!!
i2 = Rectangle($GFillInterior, 0, 0, W_i2, H_i2)
i2 = SetColor(12)
!Call MoveTo(0,0,iPOld); i2 = LineTo(0, H_i2)
Call MoveTo(0, int2(H_i2/2), iPOld); i2 = LineTo(W_i2, int2(H_i2/2))
i2 = SetColor(0)
i2 = Rectangle($GBorder, 0, 0, W_i2, H_i2)
KodClear = KodClear - 1
EndIf
i2 = SetColor(10)
i2Y = IIDNNT( (H_R8/2-Y)/H_R8*H_i2 )
Call MoveTo(iXprev1, iYprev1, iPOld); i2 = LineTo(iXprev0, iYprev0); i2 = LineTo(i2X, i2Y )
!i2 = Ellipse($GFillInterior,int2(i2X-1), int2(i2Y-1), int2(i2X+1), int2(i2Y+1))
i2 = SetColor(14)
i2Z = IIDNNT( (H_R8/2-Z)/H_R8*H_i2 )
Call MoveTo(iXprev1, iZprev1, iPOld); i2 = LineTo(iXprev0, iZprev0); i2 = LineTo(i2X, i2Z )
i2 = Ellipse($GFillInterior,int2(i2X-1), int2(i2Z-1), int2(i2X+1), int2(i2Z+1))
iXprev1 = iXprev0; iYprev1 = iYprev0; iZprev1 = iZprev0
iXprev0 = i2X; iYprev0 = i2Y; iZprev0= i2Z
Call SetViewOrg(int2(0), int2 (0), iPOld) ! Вернуться к прежней физической системе координат
End Subroutine GraDraw
Subroutine Stativ(i4Color) ! Процедура рисует штатив RGB-цветом i4Color
Use IFQWin
Type(WxyCoord)::P(10)=[WxyCoord(-6D0,-14.2D0), WxyCoord(-6D0,-4.2D0), WxyCoord(0D0,-0.25D0), WxyCoord(6D0,-4.2D0),WxyCoord(6D0,-14.2D0), &
WxyCoord(6.4D0,-14.2D0),WxyCoord(6.4D0,-4D0),WxyCoord(0D0,0.25D0),WxyCoord(-6.4D0,-4D0),WxyCoord(-6.4D0,-14.2D0)]
Integer(4) i4Color, i4
Integer(2) i2
!i4 = SetColorRGB(i4Color)
i2 = SetColorRGB(#00A700)
i2 = Rectangle_W($GFillInterior, -10D0,-15D0, 10D0, -14.2D0)
i4 = SetColor(0)
i2 = Rectangle_W($GFillInterior, -10D0,-15.3D0, -7D0, -15D0)
i2 = Rectangle_W($GFillInterior, 10D0,-15.3D0, 7D0, -15D0)
i2 = SetColorRGB(#00A700)
i2=Polygon_W($GFillInterior,P,10)
End Subroutine Stativ