2 C Program to cluster united-residue MCM results.
9 integer IERROR,ERRCODE,STATUS(MPI_STATUS_SIZE)
12 include 'COMMON.TIME1'
13 include 'COMMON.INTERACT'
14 include 'COMMON.NAMES'
16 include 'COMMON.HEADER'
17 include 'COMMON.CONTROL'
18 include 'COMMON.CHAIN'
20 include 'COMMON.CLUSTER'
21 include 'COMMON.IOUNITS'
23 logical printang(max_cut)
24 integer printpdb(max_cut)
25 integer printmol2(max_cut)
27 REAL CRIT(maxconf),MEMBR(maxconf)
28 REAL CRITVAL(maxconf-1)
29 INTEGER IA(maxconf),IB(maxconf)
30 INTEGER ICLASS(maxconf,maxconf-1),HVALS(maxconf-1)
31 INTEGER IORDER(maxconf-1),HEIGHT(maxconf-1)
32 integer nn,ndis,scount_buf
33 real*4 DISNN, diss_buf(maxdist)
34 DIMENSION NN(maxconf),DISNN(maxconf)
36 integer i,j,k,l,m,n,len,lev,idum,ii,ind,ioffset,jj,icut,ncon,
37 & it,ncon_work,ind1,kkk, ijk, is,ie
38 double precision t1,t2,tcpu,difconf
40 double precision varia(maxvar)
41 double precision hrtime,mintime,sectime
46 call MPI_Init( IERROR )
47 call MPI_Comm_rank( MPI_COMM_WORLD, me, IERROR )
48 call MPI_Comm_size( MPI_COMM_WORLD, nprocs, IERROR )
51 write(iout,*) "SEVERE ERROR - Can't initialize MPI."
52 call mpi_finalize(ierror)
55 if (nprocs.gt.MaxProcs+1) then
56 write (2,*) "Error - too many processors",
58 write (2,*) "Increase MaxProcs and recompile"
59 call MPI_Finalize(IERROR)
70 c write (iout,*) "Main: refstr ",refstr
71 if (refstr) call read_ref_structure(*30)
88 IF (RCUTOFF(I).LT.0.0) THEN
89 RCUTOFF(I)=ABS(RCUTOFF(I))
97 write (iout,*) 'Number of cutoffs:',NCUT
98 write (iout,*) 'Cutoff values:'
100 WRITE(IOUT,'(8HRCUTOFF(,I2,2H)=,F8.1,2i2)')ICUT,RCUTOFF(ICUT),
101 & printpdb(icut),printmol2(icut)
103 else if (nclust.gt.0) then
104 write (iout,'("Number of clusters requested",i5)') nclust
107 & write (iout,*) "ERROR: Either nclust or ncut must be >0"
116 call read_coords(ncon,*20)
117 write (iout,*) 'from read_coords: ncon',ncon
119 write (iout,*) "nT",nT
121 write (iout,*) "Temperature",1.0d0/(beta_h(iT)*1.987D-3)
123 call work_partition(.true.,ncon)
125 call probabl(iT,ncon_work,ncon,*20)
127 if (ncon_work.lt.2) then
128 write (iout,*) "Too few conformations; clustering skipped"
132 ndis=ncon_work*(ncon_work-1)/2
133 call work_partition(.true.,ndis)
138 WRITE (iout,'(A80)') TITEL
141 C CALCULATE DISTANCES
143 call daread_ccoords(1,ncon_work)
146 c if (mod(i,100).eq.0) print *,'Calculating RMS i=',i
148 IND=IOFFSET(NCON_work,I,J)
150 if (ind.ge.indstart(me) .and. ind.le.indend(me)) then
153 DISS(IND1)=DIFCONF(I,J)
154 c write (iout,'(2i4,i10,f10.5)') i,j,ind,DISS(IND)
161 WRITE (iout,'(/a,1pe14.5,a/)')
162 & 'Time for distance calculation:',T2-T1,' sec.'
164 c PRINT '(a)','End of distance computation'
166 scount_buf=scount(me)
169 diss_buf(ijk)=diss(ijk)
174 WRITE (iout,*) "Wchodze do call MPI_Gatherv"
175 call MPI_Gatherv(diss_buf(1),scount_buf,MPI_REAL,diss(1),
176 & scount(0),idispl(0),MPI_REAL,Master,MPI_COMM_WORLD, IERROR)
177 if (me.eq.master) then
179 open(80,file=scratchdir(:ilen(scratchdir))//'/distance',
180 & form='unformatted')
187 IND=IOFFSET(NCON,I,J)
188 write (jrms,'(2i5,2f10.5)') i,j,diss(IND),
189 & energy(j)-energy(i)
194 C Print out the RMS deviation matrix.
196 if (print_dist) CALL DISTOUT(NCON_work)
198 C call hierarchical clustering HC from F. Murtagh
202 write(iout,*) "-------------------------------------------"
203 write(iout,*) "HIERARCHICAL CLUSTERING using"
205 write(iout,*) "WARD'S MINIMUM VARIANCE METHOD"
206 elseif (iopt.eq.2) then
207 write(iout,*) "SINGLE LINK METHOD"
208 elseif (iopt.eq.3) then
209 write(iout,*) "COMPLETE LINK METHOD"
210 elseif (iopt.eq.4) then
211 write(iout,*) "AVERAGE LINK (OR GROUP AVERAGE) METHOD"
212 elseif (iopt.eq.5) then
213 write(iout,*) "MCQUITTY'S METHOD"
214 elseif (iopt.eq.6) then
215 write(iout,*) "MEDIAN (GOWER'S) METHOD"
216 elseif (iopt.eq.7) then
217 write(iout,*) "CENTROID METHOD"
219 write(iout,*) "IOPT=",iopt," IS INVALID, use 1-7"
220 write(*,*) "IOPT=",iopt," IS INVALID, use 1-7"
224 write(iout,*) "hc.f by F. Murtagh, ESA/ESO/STECF, Garching"
225 write(iout,*) "February 1986"
226 write(iout,*) "References:"
227 write(iout,*) "1. Multidimensional clustering algorithms"
228 write(iout,*) " Fionn Murtagh"
229 write(iout,*) " Vienna : Physica-Verlag, 1985."
230 write(iout,*) "2. Multivariate data analysis"
231 write(iout,*) " Fionn Murtagh and Andre Heck"
232 write(iout,*) " Kluwer Academic Publishers, 1987"
233 write(iout,*) "-------------------------------------------"
237 write (iout,*) "The TOTFREE array"
239 write (iout,'(2i5,f10.5)') i,list_conf(i),totfree(i)
243 CALL HC(N,M,LEN,IOPT,IA,IB,CRIT,MEMBR,NN,DISNN,FLAG,DISS)
245 write (iout,*) "n",n," ncon_work",ncon_work," lev",lev
247 write (iout,*) "Too few conformations to cluster."
250 CALL HCASS(N,IA,IB,CRIT,LEV,ICLASS,HVALS,IORDER,CRITVAL,HEIGHT)
251 c CALL HCDEN(LEV,IORDER,HEIGHT,CRITVAL)
252 c 3/3/16 AL: added explicit number of cluters
253 if (nclust.gt.0) then
268 licz(iclass(j,i))=licz(iclass(j,i))+1
269 nconf(iclass(j,i),licz(iclass(j,i)))=j
270 c write (iout,*) i,j,iclass(j,i),licz(iclass(j,i)),
271 c & nconf(iclass(j,i),licz(iclass(j,i)))
277 IF (HEIGHT(L).EQ.IDUM) GOTO 190
280 write(IOUT,*) "i+1",i+1," idum",idum," critval",CRITVAL(IDUM),
281 & " icut",icut," cutoff",rcutoff(icut)
282 IF (nclust.gt.0.or.CRITVAL(IDUM).LT. RCUTOFF(ICUT)) THEN
284 & WRITE (iout,'(/a,f10.5)') 'AT CUTOFF:',rcutoff(icut)
285 write (iout,'(a,f8.2)') 'Maximum distance found:',
287 CALL SRTCLUST(ICUT,ncon_work,iT)
289 CALL WRTCLUST(ncon_work,ICUT,PRINTANG,PRINTPDB,PRINTMOL2,iT)
291 if (icut.gt.ncut) goto 191
298 licz(iclass(j,i))=licz(iclass(j,i))+1
299 nconf(iclass(j,i),licz(iclass(j,i)))=j
300 c write (iout,*) i,j,iclass(j,i),licz(iclass(j,i)),
301 c & nconf(iclass(j,i),licz(iclass(j,i)))
302 cd print *,j,iclass(j,i),
303 cd & licz(iclass(j,i)),nconf(iclass(j,i),licz(iclass(j,i)))
314 WRITE (iout,'(/a,1pe14.5,a/)')
315 & 'Total time for clustering:',T2-T1,' sec.'
323 close(icbase,status="delete")
325 call MPI_Finalize(IERROR)
327 stop '********** Program terminated normally.'
328 20 write (iout,*) "Error reading coordinates"
330 call MPI_Finalize(IERROR)
333 30 write (iout,*) "Error reading reference structure"
335 call MPI_Finalize(IERROR)
339 c---------------------------------------------------------------------------
340 double precision function difconf(icon,jcon)
343 include 'sizesclu.dat'
344 include 'COMMON.CONTROL'
345 include 'COMMON.CLUSTER'
346 include 'COMMON.CHAIN'
347 include 'COMMON.INTERACT'
349 include 'COMMON.IOUNITS'
351 double precision przes(3),obrot(3,3)
352 double precision rmscalc
353 integer icon,jcon,k,l
354 c write (iout,*) "DIFCONF: ICON",icon," JCON",jcon
357 cref(l,k)=allcart(l,k,icon)
358 c(l,k)=allcart(l,k,jcon)
361 difconf=rmscalc(c(1,1),cref(1,1),przes,obrot,ipermmin)
364 C------------------------------------------------------------------------------
365 subroutine distout(ncon)
368 include 'sizesclu.dat'
371 include 'COMMON.IOUNITS'
372 include 'COMMON.CLUSTER'
373 integer i,j,k,jlim,jlim1,nlim,ind,ioffset
376 write (iout,'(a)') 'The distance matrix'
378 nlim=min0(i+ncol-1,ncon)
379 write (iout,1000) (k,k=i,nlim)
380 write (iout,'(8h--------,10a)') ('-------',k=i,nlim)
381 1000 format (/8x,10(i4,3x))
382 1020 format (/1x,80(1h-)/)
393 IND=IOFFSET(NCON,j,k)
395 IND=IOFFSET(NCON,k,j)
398 write (iout,1010) j,(b(k),k=1,jlim-i+1)
401 1010 format (i5,3x,10(f6.2,1x))