Статистика, картография и ГИС!

Об авторе сайта Статистика, картография и ГИС!

Комментарии

Программа
*Процедура Norma для программы ГЕОКЛАСС. Предназначена для нормировки
*цифровой информации распределенной по нормальному закону. В связи с этим
*в исходных данных могут присутствовать ноли (0) и отриц числа.
*Создаются два дополнительных файла - нормированных чисел с заменой последних
*двух букв в названии на ng и параметров нормировки на np в случае нормировки
*основного файла vibor = 0,и один на ng в случае нормировки файла эталонов
* по параметрам нормировки по файлу с np vibor # 0.
*Автор алгоритмов и программы В.Д.Брусницын
PROCEDURE Norma
PARAMETERS vibor
formglav.release
SET TALK OFF
CLEAR
IF ALLTRIM(DBF(1))==""
DEFINE POPUP obj_fil PROMPT FILES LIKE *.DBF;
   MESSAGE "ВЫБРАТЬ ФАЙЛ ДЛЯ НОРМИРОВКИ";
   TITLE "ВЫБРАТЬ ФАЙЛ ДЛЯ НОРМИРОВКИ"
ON SELECTION POPUP obj_fil DEACTIVATE POPUP obj_fil
ACTIVATE POPUP obj_fil
SELECT 1
USE PROMPT() NOUPDATE
ENDIF
SELECT 1
vorname = DBF(1)
vorname = SUBSTR(vorname,1,LEN(vorname)-6)
imia = "ng"
nach_el = f_fiel()
viv_file = vorname + ALLTRIM(imia) + '.dbf'
IF vibor = 0
   imia1 = "np"
   viv_fil1 = vorname + ALLTRIM(imia1) + '.dbf'
   COPY TO &viv_file AS 1251
   COPY STRUCTURE TO &viv_fil1
   USE &viv_file
   contf = FCOUNT()
   konec = FCOUNT()
   COUNT TO nom
   nom1 = 1/nom/(nom - 1)
   DIME srst(2, konec-nach_el + 1)
   FOR ii2 = nach_el TO konec
      pii = FIELD(ii2)
      SUM(&pii) TO sumx
      srst(1,ii2-nach_el+1) = sumx/nom
      kvsumx = sumx^2
      SUM(&pii^2) TO sumxkv
      nsumxkv = nom* sumxkv
      srst(2,ii2-nach_el+1) = SQRT(nom1*(nsumxkv-kvsumx))
   ENDFOR
   SELECT 2
   USE &viv_fil1
   APPEND BLANK
   APPEND BLANK
   FOR ii3 = nach_el TO konec
      pii = FIELD(ii3)
      GO BOTTOM
      REPL &pii WITH srst(2,ii3-nach_el+1)
      SKIP -1
      REPL &pii WITH srst(1,ii3-nach_el+1)
   ENDFOR
   p1 = FIELD(1)
   ALTER TABLE &viv_fil1 ALTER COLUMN &p1 C(8)
   ALTER TABLE &viv_fil1 RENAME COLUMN &p1 TO "Pokaz"
   GO TOP
   REPL Pokaz WITH "СРЕДНЕЕ"
   SKIP
   REPL Pokaz WITH "СТАНДАРТ"
   ii4 = 2
   DO WHILE ii4<nach_el
      pii = UPPER(FIELD(2))
      ALTER TABLE &viv_fil1 DROP COLUMN &pii
      ii4 = ii4 + 1
   ENDDO
   BROW TITLE ;
      "ВНЕСТИ ИЗМЕНЕНИЯ В СРЕДНЕЕ И СТАНДАРТ (Esc - для продолжения счета)"
ELSE
   CLEAR
   IF ALLTRIM(DBF(2))==""
DEFINE POPUP obj_fil PROMPT FILES LIKE *.DBF;
   MESSAGE "ВЫБРАТЬ ФАЙЛ ПОКАЗАТЕЛЕЙ ДЛЯ НОРМИРОВКИ";
   TITLE "ВЫБРАТЬ ФАЙЛ ПОКАЗАТЕЛЕЙ ДЛЯ НОРМИРОВКИ"
ON SELECTION POPUP obj_fil DEACTIVATE POPUP obj_fil
ACTIVATE POPUP obj_fil
SELECT 2
USE PROMPT() NOUPDATE
ENDIF
SELECT 2
COPY STRUCTURE TO &viv_file
SELE 3
USE &viv_file
p1 = FIELD(1)
ALTER TABLE &viv_file ALTER COLUMN &p1 N(3)
p2 = "klasse"
ALTER TABLE &viv_file RENAME COLUMN &p1 TO &p2
APPEND FROM DBF(1)
USE
SELE 1
USE &viv_file
SELE 2
nach_el = 2
konec = FCOUNT()
ENDIF
FOR ii5 = 2 TO FCOUNT()
   SELECT 2
   pii = FIELD(ii5)
   GO BOTTOM
   standart = &pii
   SKIP -1
   srednee = &pii
   SELECT 1
   REPL ALL &pii WITH (EVAL(pii)-(srednee))/standart
ENDFOR
SELECT 1
FOR ii1 = nach_el TO konec
   pii = FIELD(ii1)
   pii1 = pii+"_k"
   ALTER TABLE &viv_file RENAME COLUMN &pii TO &pii1
ENDFOR
ALTER TABLE &viv_file ADD COLUMN "KA_PLU" N(10,2)
ALTER TABLE &viv_file ADD COLUMN "KA_MIN" N(10,2)
ALTER TABLE &viv_file ADD COLUMN "KA_SUM" N(10,2)
beg = fst_el(UPPER('_K'))
elts = n_el(UPPER('_K'))
last_el = beg + elts - 1
DIMENSION a(elts)
GO TOP
DO WHILE ! EOF()
   FOR jj=1 TO elts
      a(jj)=EVAL(FIELD(beg-1+jj))
   ENDFOR
   =ASORT(a, 1, elts, 1)
   ka = 0
   SUM = 0
   ii = 1
   SUM = a(ii)
   ka1 = SUM / SQRT(ii)
   DO WHILE ii <=elts
      IF ka < ka1
         ka = ka1
         ii = ii + 1
         IF ii = elts+1
            EXIT
         ENDIF
         SUM = SUM + a(ii)
         ka1 = SUM / SQRT(ii)
      ELSE
         ii = elts+1
      ENDIF
   ENDDO
   REPLACE ka_plu WITH ka
   ka = 0
   SUM = 0
   ii = elts
   IF a(ii)<0
      SUM = a(ii)
      ka1 = SUM / SQRT(elts - ii + 1)
   ELSE
      SUM = 0
      ka1 = 0
   ENDIF
   DO WHILE ii>= beg
      IF ka > ka1 AND a(ii)<0
         ka = ka1
         ii = ii - 1
         SUM = SUM + a(ii)
         ka1 = SUM / SQRT(elts -ii+1)
         IF ii = beg-1 AND ka > ka1
            ka = ka1
            EXIT
         ENDIF
      ELSE
         ii = beg-1
      ENDIF
   ENDDO
   REPLACE ka_min WITH ka
   SKIP
ENDDO
REPLACE ALL ka_sum WITH (ka_plu + ABS(ka_min))/SQRT(2)
DO FORM formglav
CLOSE ALL
На главную страницу

Сайт управляется системой uCoz