subroutine mona(nn,pp, x,jerr, nban,ner,kwan,lava, jlack) cc cc MONothetic Analysis cc cc Program for divisive hierarchical clustering of binary data, cc using association analysis. cc cc list of functions and subroutines: cc function kab c Args integer nn, pp, jerr c nn = number of objects c pp = number of variables c jerr : error return code in {1,2,3,4} integer x(nn,pp), jlack(pp), nban(nn),ner(nn),kwan(nn),lava(nn) c x[i,j]: binary (0/1/NA) data (obs. i, var.j) c where "NA", missing values, are all values > 1 c Function called: integer kab c VARs logical syn integer j, ja, jb, jnat, jma, jtel, jtelz, jtel2, jres integer j0,j1, jptwe integer a, b, c, d, k, ka, kb, kal, kalf, km integer l, lbb, laa, lcc, ldd, lee, lack,lama, lams integer nel, nelbb, nzf, nhalf, npass, nclu, myst, mysca nhalf=(nn+1)/2 jptwe=(pp+4)/5 myst=0 do 70 l=1,nn mysca=0 do 60 j=1,pp if(x(l,j) .gt. 1) mysca=mysca+1 60 continue if(mysca .eq. pp) then c all variables missing for this object jerr=1 return endif myst=myst+mysca 70 continue if(myst.eq.0)go to 290 lack=0 do 100 j=1,pp j0=0 j1=0 do 80 l=1,nn if(x(l,j).eq.0) j0=j0+1 if(x(l,j).eq.1) j1=j1+1 80 continue jlack(j)=nn-j0-j1 if(jlack(j).ne.0) lack=lack+1 if(jlack(j).ge.nhalf) then c at least 50% of the objects have missing values for this variable jerr=2 return endif if(j0.eq.0 .or. j1.eq.0) then c all non missing values are identical for this variable jerr=3 return endif 100 continue if(lack .eq. pp) then c all variables have missing values jerr=4 return endif cc cc filling in missing values cc do 260 j=1,pp if(jlack(j) .ne. 0) then lama=-1 syn=.true. do 240 ja=1,pp if(jlack(ja) .eq. 0) then c no missing in x[, ja] a=0 b=0 c=0 d=0 do 230 k=1,nn if(x(k,j).eq.1)go to 220 if(x(k,ja).eq.0)a=a+1 if(x(k,ja).eq.1)b=b+1 go to 230 220 if(x(k,ja).eq.0)c=c+1 if(x(k,ja).eq.1)d=d+1 230 continue kal=a*d - b*c kalf=kab(kal) if(kalf.ge.lama)then lama=kalf jma=ja if(kal.lt.0) syn=.false. endif endif 240 continue do 250 l=1,nn if(x(l,j).gt. 1) then c missing if(syn) then x(l,j)=x(l,jma) else if(x(l,jma).eq.1) x(l,j)=0 if(x(l,jma).eq.0) x(l,j)=1 endif endif 250 continue endif 260 continue c--- end of treating missing values ---- cc cc initialization cc 290 do 300 k=1,nn kwan(k)=0 ner(k)=k lava(k)=0 300 continue npass=1 kwan(1)=nn cc cc algorithm cc nclu=1 ka=1 C --- Loop --- 310 kb=ka+kwan(ka)-1 lama=-1 jnat=pp do 370 j=1,pp if(nclu.eq.1)go to 330 j0=0 j1=0 do 325 l=ka,kb nel=ner(l) if(x(nel,j).eq.0) j0=j0+1 if(x(nel,j).eq.1) j1=j1+1 325 continue if(j1.eq.0)go to 370 if(j0.eq.0)go to 370 330 jnat=jnat-1 lams=0 do 360 jb=1,pp if(jb .ne. j) then a=0 b=0 c=0 d=0 do 350 l=ka,kb nel=ner(l) if(x(nel,j).eq. 0) then if(x(nel,jb).eq.0) a=a+1 if(x(nel,jb).eq.1) b=b+1 else if(x(nel,jb).eq.0) c=c+1 if(x(nel,jb).eq.1) d=d+1 endif 350 continue lams=lams+kab(a*d - b*c) endif 360 continue if(lama .lt. lams) then lama=lams jtel =c+d jtelz=a+b jma=j endif 370 continue if(jnat.lt.pp)go to 375 kwan(ka)=-kwan(ka) go to 400 cc cc splitting cc 375 nel=ner(ka) if(x(nel,jma).eq.1)then nzf=0 jtel2=jtel else nzf=1 jtel2=jtelz endif jres=kb-ka+1-jtel2 km=ka+jtel2 l=ka c -- inner loop -- 378 nel=ner(l) if(x(nel,jma).eq.nzf)go to 380 l=l+1 if(l.lt.km)go to 378 go to 390 380 do 381 lbb=l,kb nelbb=ner(lbb) if(x(nelbb,jma) .ne. nzf) then lcc=lbb-1 go to 382 endif 381 continue 382 do 383 laa=l,lcc ldd=lcc+l-laa lee=ldd+1 ner(lee)=ner(ldd) 383 continue ner(l)=nelbb go to 378 390 nclu=nclu+1 nban(km)=npass kwan(ka)=jtel2 kwan(km)=jres lava(km)=jma ka=ka+kwan(ka) 400 if(kb.eq.nn)go to 500 410 ka=ka+kab(kwan(ka)) if(ka.gt.nn)go to 500 if(kwan(ka).lt.2)go to 410 go to 310 500 npass=npass+1 do 510 ka=1,nn if(kwan(ka).ge.2) go to 310 510 continue end cc cc kab(j) = |j| cc integer function kab(j) integer j kab=j if(j.lt.0) kab=-j return end