Пирамидальная сортировка массива

@Lady A · Регистрация: 31.05.2014

Author24 — интернет-сервис помощи студентам

Перевела код из Pascal в Fortran

Pascal

Program Floid;
Const n = 7; 
Type  Vector = array[1..n] of Integer;
 
 
procedure Surface( var a: Vector; i,k: integer);
var j,m,copy :Integer;
begin
    copy:=a[i];
    m:=2*i;
    while m<=k do 
      begin
          if m=k then j:=m else if a[m]>a[m+1] then j:=m else j:=m+1;
          if a[j]>copy then
            begin
                a[i]:=a[j];
                i:=j;
                m:=2*i;
            end
          else break; 
      end;
  a[i]:=copy;
end;
 
 
procedure Sort( var a: Vector; n: integer);
var
  i,k,w, y :Integer;
begin
 
    for i:=n div 2 downto 2 do Surface(a,i,n);
 
   for k:=n downto 2 do 
    begin
         Surface(a,1,k);
         w:=a[k]; a[k]:=a[1]; a[1]:=w;
    end
end;
Var {Main}
    a : Vector; 
     i : Integer;
begin; 
      a[1]:=18;
      a[2]:=65;
      a[3]:=66;
      a[4]:=4;
      a[5]:=37;
      a[6]:=63;
      a[7]:=56;
      Sort(a,n);
      for i:=1 to n do WriteLn('s[',i:1,']=',a[i]:3);
end.

Fortran выдает ошибку
Помогите найти ошибку

Fortran

      PROGRAM MASSIV
      INTEGER A, I
      DIMENSION A(7)
      A(1)=18
      A(2)=65
      A(3)=66
      A(4)=4
      A(5)=37
      A(6)=63
      A(7)=56
      PRINT  *, (A(I), I=1,7)
      PRINT  *, 'RESULT:'
      CALL SORT(A, 7)
      PRINT  *, (A(I), I=1,7)
       READ *
      END PROGRAM
      
      SUBROUTINE SORT(A, N)
      INTEGER N
      INTEGER I, K, W, Y , N1
      INTEGER A
      DIMENSION A(7)
      N1=N/2
      DO I=N1, 1, -1
         PRINT *, I
         CALL SURFACE(A, I, N)
      ENDDO
      
      DO K=7, 2, -1
         CALL SURFACE(A, 1, K)
         W=A(K)
         A(K)=A(1)
         A(1)=W
      ENDDO
 
      RETURN
      END
      
      SUBROUTINE SURFACE(A, I, K)
      INTEGER I, K
      INTEGER J, M, COPY
      INTEGER A
      DIMENSION A(7)
      
      COPY=A(I)
      PRINT *, COPY
      M=2*I
      DO WHILE (M .LE. K)
          !1
          IF (M .EQ. K) THEN
             J=M
          ELSE  IF (A(M) .GT. A(M+1)) THEN
                J=M
            ELSE
            J=M+1
         ENDIF
         
         !2
         IF (A(J) .GT. COPY) THEN
          A(I)=A(J)
          I=J
          M=2*I
          ELSE
          EXIT
          ENDIF
          
 
      ENDDO
      A(I)=COPY
      RETURN
      END

@Catstail · 31.05.2014, 19:46

Сообщение от Lady A

Fortran выдает ошибку
Помогите найти ошибку

- приведите сообщение об ошибке

@Lady A · 31.05.2014, 20:22 **[ТС]**

DO K=7, 2, -1
CALL SURFACE(A, 1, K)
W=A(K)
A(K)=A(1)
A(1)=W
ENDDO

@Krasme · 31.05.2014, 22:39

Lady A, небольшие поправочки, но привожу весь текст..

Кликните здесь для просмотра всего текста

Fortran

PROGRAM MASSIV
      INTEGER A, I
      DIMENSION A(7)
      A(1)=18
      A(2)=65
      A(3)=66
      A(4)=4
      A(5)=37
      A(6)=63
      A(7)=56
      write (*, '(7i5)') A
      PRINT  *, 'RESULT:'
      CALL SORT(A, 7)
       write (*, '(7i5)') A
       pause
      END PROGRAM
      
      SUBROUTINE SORT(A, N)
      INTEGER N
      INTEGER I, K, W, Y , N1
      INTEGER A
      DIMENSION A(7)
      N1=N/2
      DO I=N1, 1, -1
         !PRINT *, I
         CALL SURFACE(A, I, N)
      ENDDO
      
      DO K=7, 2, -1
         CALL SURFACE(A, 1, K)
         W=A(K)
         A(K)=A(1)
         A(1)=W
      ENDDO
 
      RETURN
      END
      
      SUBROUTINE SURFACE(A, II, K)
      INTEGER I,II, K
      INTEGER J, M, COPY
      INTEGER A
      DIMENSION A(7)
      I=II
      COPY=A(I)
      !PRINT *, COPY
      M=2*I
      DO WHILE (M .LE. K)
          !1
          IF (M .EQ. K) THEN
             J=M
          ELSE  IF (A(M) .GT. A(M+1)) THEN
                J=M
            ELSE
            J=M+1
         ENDIF
         
         !2
         IF (A(J) .GT. COPY) THEN
          A(I)=A(J)
          I=J
          M=2*I
          ELSE
          EXIT
          ENDIF
          
 
      ENDDO
      A(I)=COPY
      RETURN
      END

@Krasme · 31.05.2014, 23:01

Lady A, на заметку.. вместо семи строк присваивания элементам массива чисел можно использовать всего одну...

Fortran

1 2	data a/18,65,66,4,37,63,56/

@Lady A · 01.06.2014, 15:28 **[ТС]**

Спасибо Большое!!!

Добавлено через 7 минут
Krasme, Спасибо БОЛЬШОЕ!!!

Новые блоги и статьи
Как написать микросервис на Go/Golang InfoMaster 14.01.2025 Определение микросервиса, преимущества использования Go/ Golang Микросервис – это архитектурный подход к разработке программного обеспечения, при котором приложение состоит из небольших, независимо. . .	Как написать микросервис с нуля на C# InfoMaster 14.01.2025 В современном мире разработки программного обеспечения микросервисная архитектура стала стандартом де-факто для создания масштабируемых и гибких приложений. Этот архитектурный подход предполагает. . .	Как создать интернет-магазин на PHP и JavaScript InfoMaster 14.01.2025 В современном мире электронная коммерция стала неотъемлемой частью бизнеса. Создание собственного интернет-магазина открывает широкие возможности для предпринимателей, позволяя достичь большей. . .	Как написать Тетрис на Ассемблере InfoMaster 14.01.2025 Тетрис – одна из самых узнаваемых и популярных компьютерных игр, созданная в 1984 году советским программистом Алексеем Пажитновым. За прошедшие десятилетия она завоевала симпатии миллионы людей по. . .	Как создать игру "Танчики" на Unity3d и C# InfoMaster 14.01.2025 Разработка игр – это увлекательный процесс, сочетающий в себе творчество и технические навыки. В этой статье мы рассмотрим создание классической игры "Танчики" с использованием Unity3D и языка. . .	Организую платный онлайн микро-курс по доработке Android-клиента Telegram _Ivana 14.01.2025 Официальная версия и распространенные форки не полностью устраивают? Сделай свою кастомную версию клиента! 4 занятия по 2 часа (2 недели пн, ср 19:00-21:00 по Москве). Первое вводное занятие. . .
Как создать приложение для фитнеса для iOS/iPhone на Kotlin InfoMaster 14.01.2025 Создание собственного фитнес-приложения — это не только захватывающий, но и полезный процесс, ведь оно может стать вашим верным помощником на пути к здоровому и активному образу жизни. В современных. . .	Как создать приложение магазина для iOS/iPhone на Swift InfoMaster 14.01.2025 Введение в разработку iOS-приложений Разработка приложений для iPhone и других устройств на базе iOS открывает огромные возможности для создания инновационных мобильных решений. В данной статье мы. . .	Это работает. Скорость асинхронной логики велика. Вопрос видимо останется в стабильности. Плата - огонь! Hrethgir 13.01.2025 По прошлому проекту в Logisim Evolution https:/ / www. cyberforum. ru/ blogs/ 223907/ blog8781. html прилагаю файл архива проекта в Gowin Eda. Восьмибитный счётчик из сумматора+ генератор сигнала. . .	UserScript для подсветки кнопок языков программирования в зависимости от текущего раздела volvo 13.01.2025 В результате работы этого скрипта подсвечиваются нужные кнопки не только в форме быстрого ответа, но и при редактировании сообщения: / / ==UserScript== / / @name CF_DefaultLangSelect / / . . .	Введение в модели и алгоритмы машинного обучения InfoMaster 12.01.2025 Машинное обучение представляет собой одну из наиболее динамично развивающихся областей искусственного интеллекта, которая фокусируется на разработке алгоритмов и методов, позволяющих компьютерам. . .	Как на Python создать нейросеть для решения задач InfoMaster 12.01.2025 В контексте стремительного развития современных технологий особое внимание уделяется таким инструментам, как нейросети. Эти структуры, вдохновленные биологическими нейронными сетями, используются для. . .

Пирамидальная сортировка массива

Решение

Решение

@Catstail Модератор 37431 / 20803 / 4280 Регистрация: 12.02.2012 Сообщений: 34,217 Записей в блоге: 14
	31.05.2014, 19:46	2
	Сообщение от Lady A Fortran выдает ошибку Помогите найти ошибку - приведите сообщение об ошибке 0

@Lady A 0 / 0 / 0 Регистрация: 31.05.2014 Сообщений: 10
	31.05.2014, 20:22 [ТС]	3
	DO K=7, 2, -1 CALL SURFACE(A, 1, K) W=A(K) A(K)=A(1) A(1)=W ENDDO 0

@Lady A 0 / 0 / 0 Регистрация: 31.05.2014 Сообщений: 10
	01.06.2014, 15:28 [ТС]	6
	Спасибо Большое!!! Добавлено через 7 минут Krasme, Спасибо БОЛЬШОЕ!!! 0