| Комментарии Главная Кларки НормаИБаллы |
Программа *Процедура altpdrnk для программы ГЕОКЛАСС. Предназначена для расчета *рангов по записям, в полях которых имеются какие-либо коэффициенты. *у полей коэффициентов окончания названий "_K" *Создается дополнительный файл c дополнением полей имеющих *окончания названий "_R" и поля "T_tau" *с заменой последних двух букв в названии файла на Rn. *KLARKY - передается в подпрограммы RAC_RN4k и rac_rn3k для *ранжирования с округлением соседних коэффициентов, typus = 0 Ранги по КК *typus # 0 Ранги по нормировке и баллам *Автор алгоритмов и программы В.Д.Брусницын PROCEDURE altpdrnk PARAMETER KLARKY, typus 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 = "Rn" viv_file =vorname+ALLTRIM(imia)+'.dbf' COPY TO &viv_file AS 1251 USE &viv_file BEG = FST_EL("_K") N_EL = N_EL("_K") konec = BEG+N_EL-1 FOR i = BEG TO konec pii = FIELD(i) pii1 = STRTRAN(UPPER(pii),"_K","_R") ALTER TABLE &viv_file ADD COLUMN &pii1 N(6,2) ENDFOR ALTER TABLE &viv_file ADD COLUMN "T_tau" N(10,2) IF typus = 0 =RAC_RN4k(KLARKY) ELSE =rac_rn3k(KLARKY) ENDIF CLOSE ALL *Процедура rac_rn3k для программы ГЕОКЛАСС. Предназначена для расчета *рангов по записям для расчета коэффициента Кендала и Спирмена. *Ранги по нормировке и баллам, в полях которых имеются *коэффициенты у полей коэффициентов окончания названий "_K" *KLARKY - передается из подпрограммы altpdrnk для *ранжирования с округлением соседних коэффициентов *Автор алгоритмов и программы В.Д.Брусницын PROCEDURE rac_rn3k PARAMETER klarkys SET TALK OFF SET ECHO OFF beg = fst_el("_K") nn_el = n_el("_K") n1 = ((nn_el^3 - nn_el)/6) DIMENSION aa(nn_el, 2) DIMENSION bb(nn_el, 1) GO TOP DO WHILE ! EOF() FOR j=1 TO nn_el aa(j,1)=EVAL(FIELD(beg+j-1)) aa(j,2)=FIELD(beg+j-1) ENDFOR =ASORT(aa, 1, nn_el, 1) T = 0 FOR ii = 1 TO nn_el - 1 IF aa(ii,1)-aa(ii+1,1) > klarkys bb(ii,1) = ii ELSE jj=ii kk=ii FIRST = aa(ii,1) DO WHILE (FIRST-aa(ii+1,1)<= klarkys ) AND ii < nn_el - 1 kk = kk + 1 ii = ii + 1 ENDDO ll = ( jj + kk )/2 FOR one = jj TO kk bb(one,1) = ll ENDFOR t1 = ((kk-jj+1)*(kk-jj)) T = T + t1 ENDIF ENDFOR IF aa(nn_el - 1, 1) - aa(nn_el,1) > klarkys bb(nn_el,1) = nn_el ELSE kk = kk + 1 T = T - t1 t1 = ((kk-jj+1)*(kk-jj)) ll = ( jj + kk )/2 T = T + t1 FOR one = jj TO kk bb(one,1) = ll ENDFOR ENDIF FOR one = 1 TO nn_el bukvas = STRTRAN(aa(one, 2),"_K",UPPER("_R")) REPLACE &bukvas WITH bb(one, 1) ENDFOR REPLACE T_tau WITH T/2 SKIP ENDDO CLOSE ALL *Процедура rac_rn4k для программы ГЕОКЛАСС. Предназначена для расчета *рангов по записям для расчета коэффициента Кендала и Спирмена. *Ранги по кларкам концентраций, в полях которых имеются *коэффициенты у полей коэффициентов окончания названий "_K" *KLARKY - передается из подпрограммы altpdrnk для *ранжирования с округлением соседних коэффициентов по логарифмам *Автор алгоритмов и программы В.Д.Брусницын PROCEDURE rac_rn4k PARAMETER klarkys SET TALK OFF SET ECHO OFF beg = fst_el("_K") nn_el = n_el("_K") n1 = ((nn_el^3 - nn_el)/6) DIMENSION aa(nn_el, 2) DIMENSION bb(nn_el, 1) GO TOP DO WHILE ! EOF() FOR j=1 TO nn_el aa(j,1)=EVAL(FIELD(beg+j-1)) aa(j,2)=FIELD(beg+j-1) ENDFOR =ASORT(aa, 1, nn_el, 1) mm=0 FOR ii = 1 TO nn_el IF aa(ii,1)=0 mm = ii EXIT ENDIF ENDFOR DO CASE CASE mm = 0 T = 0 FOR ii = 1 TO nn_el - 1 IF LOG10(aa(ii,1))-LOG10(aa(ii+1,1)) > klarkys bb(ii,1) = ii ELSE jj=ii kk=ii FIRST = LOG10(aa(ii,1)) DO WHILE (FIRST-LOG10(aa(ii+1,1))<= klarkys ) AND ii < nn_el - 1 kk = kk + 1 ii = ii + 1 ENDDO ll = ( jj + kk )/2 FOR one = jj TO kk bb(one,1) = ll ENDFOR t1 = (kk-jj+1)*(kk-jj) T = T + t1 ENDIF ENDFOR IF LOG10(aa(nn_el - 1, 1)) - LOG10(aa(nn_el,1)) > klarkys bb(nn_el,1) = nn_el ELSE kk = kk + 1 T = T - t1 t1 = (kk-jj+1)*(kk-jj) ll = ( jj + kk )/2 T = T + t1 FOR one = jj TO kk bb(one,1) = ll ENDFOR ENDIF CASE mm=1 ll = (1 + nn_el)/2 FOR one = 1 TO nn_el bb(one,1) = ll ENDFOR T =nn_el*(nn_el-1) CASE mm=2 bb(1,1) = 1 T=0 ll = (2 + nn_el)/2 FOR one = 1 TO nn_el bb(one,1) = ll ENDFOR T = (nn_el-1)*(nn_el-2) CASE mm>=3 T = 0 FOR ii = 1 TO mm - 2 IF LOG10(aa(ii,1))-LOG10(aa(ii+1,1)) > klarkys bb(ii,1) = ii ELSE jj=ii kk=ii FIRST = LOG10(aa(ii,1)) DO WHILE (FIRST-LOG10(aa(ii+1,1))<= klarkys ) AND ii < mm - 2 kk = kk + 1 ii = ii + 1 ENDDO ll = ( jj + kk )/2 FOR one = jj TO kk bb(one,1) = ll ENDFOR t1 = (kk-jj+1)*(kk-jj) T = T + t1 ENDIF ENDFOR IF LOG10(aa(mm-2,1)) - LOG10(aa(mm - 1, 1)) > klarkys bb(mm-1,1) = mm-1 ELSE kk = kk + 1 T = T - t1 t1 = (kk-jj+1)*(kk-jj) ll = ( jj + kk )/2 T = T + t1 FOR one = jj TO kk bb(one,1) = ll ENDFOR ENDIF ll = ( mm + nn_el )/2 FOR one = mm TO nn_el bb(one,1) = ll ENDFOR t1 = (nn_el-mm+1)*(nn_el-mm) T = T + t1 ENDCASE FOR one = 1 TO nn_el bukvas = STRTRAN(aa(one, 2),"_K",UPPER("_R")) REPLACE &bukvas WITH bb(one, 1) ENDFOR REPLACE T_tau WITH T/2 SKIP ENDDO CLOSE ALL На главную страницу |
| brusmann@mail.ru AbacusComp@yandex.ru © Василий Брусницын. Ивдель-Екатеринбург, 2010 г. Св. обл. Мотив +79045490809 | |
