Секция contains с определением внутренних подпрограмм

!******************************************************************

subroutine axis() ! Рисуем оси координат

type(xycoord) xy

status = setcolor( 2_2) ! цвет осей координат

call moveto(int2(XE/4 - 10), int2(YE/2), xy)

status = lineto(3_2*XE/4_2 + 10_2, YE/2_2) ! Ось х

call moveto(int2(XE/2), int2(YE/4 - 10), xy)

status = lineto(XE/2_2, 3_2*YE/4_2 + 10_2) ! Ось y

end subroutine axis

!******************************************************************

subroutine curve() ! График функции у =fx(x)

real(8) xt, yt !

real(8) X1,X2,Y1,Y2 ! координаты углов маркера узла

integer(2):: color=1_2

Integer mm

Integer I,j

TYPE (wxycoord) xy

status = setcolor(color) ! График функции цветом color

! формирование и рисование маркеров узлов

do i=0,n-1

X1=X(i)-0.05; X2=X(i)+0.05

Y1=Y(i)-0.05; Y2=Y(i)+0.05

status = RECTANGLE_w ($GFILLINTERIOR , X1, Y1, X2, Y2)

enddo

! рисование точками графика полинома

color=4_2

HX=(X(n-1)-X(0))/NT ! шаг изменения Х графика

! открыть файл результатов

open(unit=fpw,file='DZ2_V1.out')

! построение полинома степени m

do mm=1,2

call Gram(N-1,mm,X,Y,A); ! расчет расширенной матрицы к-тов

call GA(mm,A,c); ! решение системы уравнений методом Гаусса

! формирование данных полинома

do i=0,NT

xt=X(0)+i*HX ! абсцисса графика

yt=func(mm,c,xt) ! ордината графика

if(mm==1) then

! Вывод точки графика

status=setpixel_w(xt, yt)

else

if(i==0) then

! переход на точку графика

call moveto_w(xt, yt,xy)

else

! рисование линии до точки графика

status=lineto_w(xt, yt)

endif

endif

enddo

enddo

close(fpw)

end subroutine curve

!***********************************************************

!----- значение аппрокс.полинома в точке x1 ----------------

real(8) function func(m,c,x1)

integer m

real(8) c(0:m) ! массив коэффициентов аппрокс.полинома Pm(x)

real(8) x1

real(8) p

integer i

!-----------------------------------------------------------

p=c(m) ! аппроксимирующaя функция

do i=m-1,0,-1

p=c(i)+x1*p ! полиномы Лежандра

enddo

func=p

end function func

!***********************************************************

!----- построение матрицы Грама A(m,m+1) -------------------

subroutine Gram(N,m,X,Y,A)

integer N,m

real(8) X(0:n),Y(0:n) ! таблица данных X(N),Y(N)

real(8) A(0:m+1,0:m+1) ! матрица коэффициентов системы

! уравнений

integer i,j

real(8) p,q,r,s

!-----------------------------------------------------------

do j=0,m ! проход по строкам матрицы коэф-тов системы ур-ний

s=0.0

r=0.0

q=0.0

do i=0,N

p=X(i)**j

s=s+p

r=r+p*Y(i)

q=q+p*X(i)**m

enddo

A(0,j)=s ! диагональный элемент матрицы

A(j,m+1)=r ! свободный член

A(j,m)=q

enddo

do i=1,m

do j=0,m-1

A(i,j)=A(i-1,j+1)

enddo

enddo

end subroutine Gram

!***********************************************************

!----- метод Гаусса для СЛАУ -------------------------------

subroutine GA(m,A,C)