- added UNRES Multichain examples
[unres.git] / source / unres / src_MD-M / together.F
1       Subroutine together
2 c  feeds tasks for parallel processing
3       implicit real*8 (a-h,o-z)
4       include 'DIMENSIONS'
5       include 'mpif.h'
6       real ran1,ran2
7       include 'COMMON.CSA'
8       include 'COMMON.BANK'
9       include 'COMMON.IOUNITS'
10       include 'COMMON.CHAIN'
11       include 'COMMON.TIME1'
12       include 'COMMON.SETUP'
13       include 'COMMON.VAR'
14       include 'COMMON.GEO'
15       include 'COMMON.CONTROL'
16       include 'COMMON.SBRIDGE'
17       real tcpu
18       double precision time_start,time_start_c,time0f,time0i
19       logical ovrtim,sync_iter,timeout,flag,timeout1
20       dimension muster(mpi_status_size)
21       dimension t100(0:100),indx(mxio)
22       dimension xout(maxvar),eout(mxch*(mxch+1)/2+1),ind(9)
23       dimension cout(2)
24       parameter (rad=1.745329252d-2)
25
26 cccccccccccccccccccccccccccccccccccccccccccccccc
27       IF (ME.EQ.KING) THEN
28
29        time0f=MPI_WTIME()
30        ilastnstep=1
31        sync_iter=.false.
32        numch=1
33        nrmsdb=0
34        nrmsdb1=0
35        rmsdbc1c=rmsdbc1
36        nstep=0
37        call csa_read
38        call make_array
39
40        if(iref.ne.0) call from_int(1,0,idum)
41
42 c To minimize input conformation (bank conformation)
43 c Output to $mol.reminimized
44        if (irestart.lt.0) then
45         call read_bank(0,nft,cutdifr)
46         if (irestart.lt.-10) then
47          p_cut=nres*4.d0
48          call prune_bank(p_cut)
49          return
50         endif
51         call reminimize(jlee)
52         return
53        endif
54
55        if (irestart.eq.0) then
56         call initial_write
57         nbank=nconf
58         ntbank=nconf
59         if (ntbankm.eq.0) ntbank=0
60         nstep=0
61         nft=0
62         do i=1,mxio
63          ibank(i)=0
64          jbank(i)=0
65         enddo
66        else
67         call restart_write
68 c!bankt        call read_bankt(jlee,nft,cutdifr)
69         call read_bank(jlee,nft,cutdifr)
70         call read_rbank(jlee,adif)
71         if(iref.ne.0) call from_int(1,0,idum)
72        endif
73
74        nstmax=nstmax+nstep
75        ntrial=n1+n2+n3+n4+n5+n6+n7+n8
76        ntry=ntrial+1
77        ntry=ntry*nseed
78
79 c ntrial : number of trial conformations per seed.
80 c ntry : total number of trial conformations including seed conformations.
81
82        idum2=-123
83        imax=2**31-1
84        ENDIF
85
86        call mpi_bcast(jend,1,mpi_integer,0,CG_COMM,ierr)
87 cccccccccccccccccccccccccccccccccccccccc
88        do 300 jlee=1,jend
89 cccccccccccccccccccccccccccccccccccccccc
90   331   continue 
91         IF (ME.EQ.KING) THEN
92         if(sync_iter) goto 333
93         idum=-  ran2(idum2)*imax
94         if(jlee.lt.jstart) goto 300
95
96 C Restart the random number generator for conformation generation
97
98         if(irestart.gt.0) then
99          idum2=idum2+nstep
100          if(idum2.le.0) idum2=-idum2+1
101          idum=-  ran2(idum2)*imax
102         endif
103
104         idumm=idum
105         call vrndst(idumm)
106
107         open(icsa_seed,file=csa_seed,status="old")
108         write(icsa_seed,*) "jlee : ",jlee
109         close(icsa_seed)
110
111       call history_append
112       write(icsa_history,*) "number of procs is ",nodes
113       write(icsa_history,*) jlee,idum,idum2
114       close(icsa_history)
115
116 cccccccccccccccccccccccccccccccccccccccccccccccc
117   333 icycle=0
118
119        call history_append
120         write(icsa_history,*) "nbank is ",nbank
121        close(icsa_history)
122
123       if(irestart.eq.1) goto 111
124       if(irestart.eq.2) then
125        icycle=0
126        do i=1,nbank
127         ibank(i)=1
128        enddo
129        do i=nbank+1,nbank+nconf
130         ibank(i)=0
131        enddo
132       endif
133
134 c  start energy minimization
135       nconfr=max0(nconf+nadd,nodes-1)
136       if (sync_iter) nconf_in=0
137 c  king-emperor - feed input and sort output
138        write (iout,*) "NCONF_IN",nconf_in
139        m=0
140        if (nconf_in.gt.0) then
141 c al 7/2/00 - added possibility to read in some of the initial conformations
142         do m=1,nconf_in
143           read (intin,'(i5)',end=11,err=12) iconf
144    12     continue
145           write (iout,*) "write READ_ANGLES",iconf,m
146           call read_angles(intin,*11)
147           if (iref.eq.0) then
148             mm=m
149           else
150             mm=m+1
151           endif
152           do j=2,nres-1
153             dihang_in(1,j,1,mm)=theta(j+1)
154             dihang_in(2,j,1,mm)=phi(j+2)
155             dihang_in(3,j,1,mm)=alph(j)
156             dihang_in(4,j,1,mm)=omeg(j)
157           enddo
158         enddo ! m
159         goto 13
160    11   write (iout,*) nconf_in," conformations requested, but only",
161      &   m-1," found in the angle file."
162         nconf_in=m-1
163    13   continue
164         m=nconf_in
165         write (iout,*) nconf_in,
166      &    " initial conformations have been read in."
167        endif
168        if (iref.eq.0) then
169         if (nconfr.gt.nconf_in) then
170           call make_ranvar(nconfr,m,idum)
171           write (iout,*) nconfr-nconf_in,
172      &     " conformations have been generated randomly."
173         endif
174        else
175         nconfr=nconfr*2
176         call from_int(nconfr,m,idum)
177 c       call from_pdb(nconfr,idum)
178        endif
179        write (iout,*) 'Exitted from make_ranvar nconfr=',nconfr
180        write (*,*) 'Exitted from make_ranvar nconfr=',nconfr
181        do m=1,nconfr
182           write (iout,*) 'Initial conformation',m
183           write(iout,'(8f10.4)') (rad2deg*dihang_in(1,j,1,m),j=2,nres-1)
184           write(iout,'(8f10.4)') (rad2deg*dihang_in(2,j,1,m),j=2,nres-1)
185           write(iout,'(8f10.4)') (rad2deg*dihang_in(3,j,1,m),j=2,nres-1)
186           write(iout,'(8f10.4)') (rad2deg*dihang_in(4,j,1,m),j=2,nres-1)
187        enddo 
188        write(iout,*)'Calling FEEDIN NCONF',nconfr
189        time1i=MPI_WTIME()
190        call feedin(nconfr,nft)
191        write (iout,*) ' Time for first bank min.',MPI_WTIME()-time1i
192        call  history_append
193         write(icsa_history,*) jlee,nft,nbank
194         write(icsa_history,851) (etot(i),i=1,nconfr)
195         write(icsa_history,850) (rmsn(i),i=1,nconfr)
196         write(icsa_history,850) (pncn(i),i=1,nconfr)
197         write(icsa_history,*)
198        close(icsa_history)
199       ELSE
200 c To minimize input conformation (bank conformation)
201 c Output to $mol.reminimized   
202        if (irestart.lt.0) then 
203         call reminimize(jlee)
204         return
205        endif
206        if (irestart.eq.1) goto 111
207 c  soldier - perform energy minimization
208  334   call minim_jlee
209       ENDIF
210
211 ccccccccccccccccccccccccccccccccccc
212 c need to syncronize all procs
213       call mpi_barrier(CG_COMM,ierr)
214       if (ierr.ne.0) then
215        print *, ' cannot synchronize MPI'
216        stop
217       endif
218 ccccccccccccccccccccccccccccccccccc
219
220       IF (ME.EQ.KING) THEN
221
222 c      print *,"ok after minim"
223       nstep=nstep+nconf
224       if(irestart.eq.2) then
225        nbank=nbank+nconf
226 c      ntbank=ntbank+nconf
227        if(ntbank.gt.ntbankm) ntbank=ntbankm
228       endif
229 c      print *,"ok before indexx"
230       if(iref.eq.0) then
231        call indexx(nconfr,etot,indx)
232       else
233 c cc/al 7/6/00
234        do k=1,nconfr
235          indx(k)=k
236        enddo
237        call indexx(nconfr-nconf_in,rmsn(nconf_in+1),indx(nconf_in+1))
238        do k=nconf_in+1,nconfr
239          indx(k)=indx(k)+nconf_in
240        enddo
241 c cc/al
242 c       call indexx(nconfr,rmsn,indx)
243       endif
244 c      print *,"ok after indexx"
245       do im=1,nconf
246        m=indx(im)
247        if (m.gt.mxio .or. m.lt.1) then
248          write (iout,*) 'Dimension ERROR in TOGEHER: IM',im,' M',m
249          call mpi_abort(mpi_comm_world,ierror,ierrcode)
250        endif
251        jbank(im+nbank-nconf)=0
252        bene(im+nbank-nconf)=etot(m)
253        rene(im+nbank-nconf)=etot(m)
254 c!bankt       btene(im)=etot(m)
255 c
256        brmsn(im+nbank-nconf)=rmsn(m)
257        bpncn(im+nbank-nconf)=pncn(m)
258        rrmsn(im+nbank-nconf)=rmsn(m)
259        rpncn(im+nbank-nconf)=pncn(m)
260        if (im+nbank-nconf.gt.mxio .or. im+nbank-nconf.lt.1) then
261          write (iout,*) 'Dimension ERROR in TOGEHER: IM',im,
262      &   ' NBANK',nbank,' NCONF',nconf,' IM+NBANK-NCONF',im+nbank-nconf
263          call mpi_abort(mpi_comm_world,ierror,ierrcode)
264        endif
265        do k=1,numch
266         do j=2,nres-1
267          do i=1,4
268           bvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m)
269           rvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m)
270 c!bankt          btvar(i,j,k,im)=dihang(i,j,k,m)
271 c
272          enddo
273         enddo
274        enddo
275        if(iref.eq.1) then
276         if(brmsn(im+nbank-nconf).gt.rmscut.or.
277      &     bpncn(im+nbank-nconf).lt.pnccut) ibank(im+nbank-nconf)=9
278        endif
279        if(vdisulf) then
280            bvar_ns(im+nbank-nconf)=ns-2*nss
281            k=0
282            do i=1,ns
283              j=1
284              do while( iss(i).ne.ihpb(j)-nres .and. 
285      &                 iss(i).ne.jhpb(j)-nres .and. j.le.nss)
286               j=j+1 
287              enddo
288              if (j.gt.nss) then            
289                k=k+1
290                bvar_s(k,im+nbank-nconf)=iss(i)
291              endif
292            enddo
293        endif
294        bvar_nss(im+nbank-nconf)=nss
295        do i=1,nss
296            bvar_ss(1,i,im+nbank-nconf)=ihpb(i)
297            bvar_ss(2,i,im+nbank-nconf)=jhpb(i)
298        enddo
299       enddo
300       ENDIF
301
302   111 continue
303
304       IF (ME.EQ.KING) THEN
305
306       call find_max
307       call find_min
308
309       call get_diff
310       if(nbank.eq.nconf.and.irestart.eq.0) then
311        adif=avedif
312       endif
313
314       cutdif=adif/cut1
315       ctdif1=adif/cut2
316
317 cd      print *,"adif,xctdif,cutdifr"
318 cd      print *,adif,xctdif,cutdifr
319        nst=ntotal/ntrial/nseed
320        xctdif=(cutdif/ctdif1)**(-1.0/nst)
321        if(irestart.ge.1) call estimate_cutdif(adif,xctdif,cutdifr)
322 c       print *,"ok after estimate"
323
324       irestart=0
325
326        call write_rbank(jlee,adif,nft)
327        call write_bank(jlee,nft)
328 c!bankt       call write_bankt(jlee,nft)
329 c       call write_bank1(jlee)
330        call  history_append
331         write(icsa_history,*) "xctdif: ", xctdif,nst,adif/cut1,ctdif1
332         write(icsa_history,851) (bene(i),i=1,nbank)
333         write(icsa_history,850) (brmsn(i),i=1,nbank)
334         write(icsa_history,850) (bpncn(i),i=1,nbank)
335         close(icsa_history)
336   850 format(10f8.3)
337   851 format(5e15.6)
338
339       ifar=nseed/4*3+1
340       ifar=nseed+1
341       ENDIF
342     
343
344       finished=.false.
345       iter = 0
346       irecv = 0
347       isent =0
348       ifrom= 0
349       time0i=MPI_WTIME()
350       time1i=time0i
351       time_start_c=time0i
352       if (.not.sync_iter) then 
353         time_start=time0i
354         nft00=nft
355       else
356         sync_iter=.false.
357       endif
358       nft00_c=nft
359       nft0i=nft
360 ccccccccccccccccccccccccccccccccccccccc
361       do while (.not. finished)
362 ccccccccccccccccccccccccccccccccccccccc
363 crc      print *,"iter ", iter,' isent=',isent
364
365       IF (ME.EQ.KING) THEN
366 c  start energy minimization
367
368        if (isent.eq.0) then
369 c  king-emperor - select seeds & make var & feed input
370 cd        print *,'generating new conf',ntrial,MPI_WTIME()
371         call select_is(nseed,ifar,idum)
372
373         open(icsa_seed,file=csa_seed,status="old")
374         write(icsa_seed,39) 
375      &    jlee,icycle,nstep,(is(i),bene(is(i)),i=1,nseed)
376         close(icsa_seed)
377         call  history_append
378         write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax,
379      *   ebmin,ebmax,nft,iuse,nbank,ntbank
380         close(icsa_history)
381
382          
383
384         call make_var(ntry,idum,iter)
385 cd        print *,'new trial generated',ntrial,MPI_WTIME()
386            time2i=MPI_WTIME()
387            write (iout,'(a20,i4,f12.2)') 
388      &       'Time for make trial',iter+1,time2i-time1i
389        endif
390
391 crc        write(iout,*)'1:Calling FEEDIN NTRY',NTRY,' ntrial',ntrial
392 crc        call feedin(ntry,nft)
393
394        isent=isent+1
395        if (isent.ge.nodes.or.iter.gt.0)  then
396 ct            print *,'waiting ',MPI_WTIME()
397             irecv=irecv+1
398             call recv(0,ifrom,xout,eout,ind,timeout)
399 ct            print *,'   ',irecv,' received from',ifrom,MPI_WTIME()
400        else
401             ifrom=ifrom+1
402        endif
403
404 ct            print *,'sending to',ifrom,MPI_WTIME()
405        call send(isent,ifrom,iter)
406 ct            print *,isent,' sent ',MPI_WTIME()
407
408 c store results -----------------------------------------------
409        if (isent.ge.nodes.or.iter.gt.0)  then
410          nft=nft+ind(3)
411          movernx(irecv)=iabs(ind(5))
412          call getx(ind,xout,eout,cout,rad,iw_pdb,irecv)
413          if(vdisulf) then
414              nss_out(irecv)=nss
415              do i=1,nss
416                iss_out(i,irecv)=ihpb(i)
417                jss_out(i,irecv)=jhpb(i)  
418              enddo
419          endif
420          if(iw_pdb.gt.0) 
421      &          call write_csa_pdb(xout,eout,nft,irecv,iw_pdb)
422        endif
423 c--------------------------------------------------------------
424        if (isent.eq.ntry) then
425            time1i=MPI_WTIME()
426            write (iout,'(a18,f12.2,a14,f10.2)') 
427      &       'Nonsetup time     ',time1i-time_start_c,
428      &       ' sec, Eval/s =',(nft-nft00_c)/(time1i-time_start_c)
429            write (iout,'(a14,i4,f12.2,a14,f10.2)') 
430      &       'Time for iter ',iter+1,time1i-time0i,
431      &       ' sec, Eval/s =',(nft-nft0i)/(time1i-time0i)
432            time0i=time1i
433            nft0i=nft
434            cutdif=cutdif*xctdif
435            if(cutdif.lt.ctdif1) cutdif=ctdif1
436            if (iter.eq.0) then
437               print *,'UPDATING ',ntry-nodes+1,irecv
438               write(iout,*) 'UPDATING ',ntry-nodes+1
439               iter=iter+1
440 c----------------- call update(ntry-nodes+1) -------------------
441               nstep=nstep+ntry-nseed-(nodes-1)
442               call refresh_bank(ntry-nodes+1)
443 c!bankt              call refresh_bankt(ntry-nodes+1)
444            else
445 c----------------- call update(ntry) ---------------------------
446               iter=iter+1
447               print *,'UPDATING ',ntry,irecv
448               write(iout,*) 'UPDATING ',ntry
449               nstep=nstep+ntry-nseed
450               call refresh_bank(ntry)
451 c!bankt              call refresh_bankt(ntry)
452            endif         
453 c----------------------------------------------------------------- 
454
455            call write_bank(jlee,nft)
456 c!bankt           call write_bankt(jlee,nft)
457            call find_min
458
459            time1i=MPI_WTIME()
460            write (iout,'(a20,i4,f12.2)') 
461      &       'Time for refresh ',iter,time1i-time0i
462
463            if(ebmin.lt.estop) finished=.true.
464            if(icycle.gt.icmax) then
465                call write_bank1(jlee)
466                do i=1,nbank
467                  ibank(i)=2
468                  ibank(i)=1
469                enddo
470                nbank=nbank+nconf
471                if(nbank.gt.1000) then 
472                    finished=.true.
473                else
474 crc                   goto 333
475                    sync_iter=.true.
476                endif
477            endif
478            if(nstep.gt.nstmax) finished=.true.
479
480            if(finished.or.sync_iter) then
481             do ij=1,nodes-1
482               call recv(1,ifrom,xout,eout,ind,timeout)
483               if (timeout) then
484                 nstep=nstep+ij-1
485                 print *,'ERROR worker is not responding'
486                 write(iout,*) 'ERROR worker is not responding'
487                 time1i=MPI_WTIME()-time_start_c
488                 print *,'End of cycle, master time for ',iter,' iters ',
489      &             time1i,'sec, Eval/s ',(nft-nft00_c)/time1i
490                 write (iout,*) 'End of cycle, master time for ',iter,
491      &             ' iters ',time1i,' sec'
492                 write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i
493                 print *,'UPDATING ',ij-1
494                 write(iout,*) 'UPDATING ',ij-1
495                 call flush(iout)
496                 call refresh_bank(ij-1)
497 c!bankt                call refresh_bankt(ij-1)
498                 goto 1002
499               endif
500 c              print *,'node ',ifrom,' finished ',ij,nft
501               write(iout,*) 'node ',ifrom,' finished ',ij,nft
502               call flush(iout)
503               nft=nft+ind(3)
504               movernx(ij)=iabs(ind(5))
505               call getx(ind,xout,eout,cout,rad,iw_pdb,ij)
506               if(vdisulf) then
507                nss_out(ij)=nss
508                do i=1,nss
509                  iss_out(i,ij)=ihpb(i)
510                  jss_out(i,ij)=jhpb(i)  
511                enddo
512               endif
513               if(iw_pdb.gt.0) 
514      &          call write_csa_pdb(xout,eout,nft,ij,iw_pdb)
515             enddo
516             nstep=nstep+nodes-1
517 crc            print *,'---------bcast finished--------',finished
518             time1i=MPI_WTIME()-time_start_c
519             print *,'End of cycle, master time for ',iter,' iters ',
520      &             time1i,'sec, Eval/s ',(nft-nft00_c)/time1i
521             write (iout,*) 'End of cycle, master time for ',iter,
522      &             ' iters ',time1i,' sec'
523             write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i
524
525 ctimeout            call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr)
526 ctimeout            call mpi_bcast(sync_iter,1,mpi_logical,0,
527 ctimeout     &                                              CG_COMM,ierr)
528             do ij=1,nodes-1 
529                tstart=MPI_WTIME()
530                call mpi_issend(finished,1,mpi_logical,ij,idchar,
531      &             CG_COMM,ireq,ierr)
532                call mpi_issend(sync_iter,1,mpi_logical,ij,idchar,
533      &             CG_COMM,ireq2,ierr)
534                flag=.false.  
535                timeout1=.false.
536                do while(.not. (flag .or. timeout1))
537                  call MPI_TEST(ireq2,flag,muster,ierr)
538                  tend1=MPI_WTIME()
539                  if(tend1-tstart.gt.60) then 
540                   print *,'ERROR worker ',ij,' is not responding'
541                   write(iout,*) 'ERROR worker ',ij,' is not responding'
542                   timeout1=.true.
543                  endif
544                enddo
545                if(timeout1) then
546                 write(iout,*) 'worker ',ij,' NOT OK ',tend1-tstart
547                 timeout=.true.
548                else
549                 write(iout,*) 'worker ',ij,' OK ',tend1-tstart
550                endif
551             enddo
552             print *,'UPDATING ',nodes-1,ij
553             write(iout,*) 'UPDATING ',nodes-1
554             call refresh_bank(nodes-1)
555 c!bankt            call refresh_bankt(nodes-1)
556  1002       continue
557             call write_bank(jlee,nft)
558 c!bankt            call write_bankt(jlee,nft)
559             call find_min
560
561             do i=0,mxmv  
562               do j=1,3
563                 nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j)
564                 nstatnx(i,j)=0
565               enddo
566             enddo
567
568             write(iout,*)'### Total stats:'
569             do i=0,mxmv
570              if(nstatnx_tot(i,1).ne.0) then
571               if (i.le.9) then
572               write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') 
573      &        '### N',i,' total=',nstatnx_tot(i,1),
574      &      ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc',
575      &       (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1)
576               else
577               write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') 
578      &        '###N',i,' total=',nstatnx_tot(i,1),
579      &      ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc',
580      &       (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1)
581               endif
582              else
583               if (i.le.9) then
584               write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') 
585      &          '### N',i,' total=',nstatnx_tot(i,1),
586      &          ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),
587      &          ' %acc',0.0
588               else
589               write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') 
590      &          '###N',i,' total=',nstatnx_tot(i,1),
591      &          ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),
592      &          ' %acc',0.0
593               endif
594              endif
595             enddo
596
597            endif
598            if(sync_iter) goto 331
599
600    39 format(2i3,i7,5(i4,f8.3,1x),19(/,13x,5(i4,f8.3,1x)))
601    40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4)
602    43 format(10i8)
603    44 format('jlee =',i3,':',4f10.1,' E =',f8.3,i7,i10)
604
605            isent=0
606            irecv=0
607        endif
608       ELSE
609 c  soldier - perform energy minimization
610         call minim_jlee
611         print *,'End of minim, proc',me,'time ',MPI_WTIME()-time_start
612         write (iout,*) 'End of minim, proc',me,'time ',
613      &                  MPI_WTIME()-time_start
614         call flush(iout)
615 ctimeout        call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr)
616 ctimeout        call mpi_bcast(sync_iter,1,mpi_logical,0,CG_COMM,ierr)
617          call mpi_recv(finished,1,mpi_logical,0,idchar,
618      *                 CG_COMM,muster,ierr)             
619          call mpi_recv(sync_iter,1,mpi_logical,0,idchar,
620      *                 CG_COMM,muster,ierr)             
621         if(sync_iter) goto 331
622       ENDIF
623
624 ccccccccccccccccccccccccccccccccccccccc
625       enddo
626 ccccccccccccccccccccccccccccccccccccccc
627
628       IF (ME.EQ.KING) THEN
629         call  history_append
630         write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax,
631      *  ebmin,ebmax,nft,iuse,nbank,ntbank
632
633         write(icsa_history,44) jlee,0.0,0.0,0.0,
634      &   0.0,ebmin,nstep,nft
635         write(icsa_history,*)
636        close(icsa_history)
637
638        time1i=MPI_WTIME()-time_start
639        print *,'End of RUN, master time ',
640      &             time1i,'sec, Eval/s ',(nft-nft00)/time1i
641        write (iout,*) 'End of RUN, master time  ',
642      &             time1i,' sec'
643        write (iout,*) 'Total eval/s ',(nft-nft00)/time1i
644
645        if(timeout) then 
646         write(iout,*) '!!!! ERROR worker was not responding'
647         write(iout,*) '!!!! cannot finish work normally'
648         write(iout,*) 'Processor0 is calling MPI_ABORT'
649         print *,'!!!! ERROR worker was not responding'
650         print *,'!!!! cannot finish work normally'
651         print *,'Processor0 is calling MPI_ABORT'
652         call flush(iout)
653         call mpi_abort(mpi_comm_world, 111, ierr)
654        endif
655       ENDIF
656
657 cccccccccccccccccccccccccccccc
658   300 continue
659 cccccccccccccccccccccccccccccc
660
661       return
662       end
663 c-------------------------------------------------
664       subroutine feedin(nconf,nft)
665 c  sends out starting conformations and receives results of energy minimization
666       implicit real*8 (a-h,o-z)
667       include 'DIMENSIONS'
668       include 'COMMON.VAR'
669       include 'COMMON.IOUNITS'
670       include 'COMMON.CONTROL'
671       include 'mpif.h'
672       dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1),
673      *          cout(2),ind(9),info(12)
674       dimension muster(mpi_status_size)
675       include 'COMMON.SETUP'
676       parameter (rad=1.745329252d-2)
677
678       print *,'FEEDIN: NCONF=',nconf
679       mm=0
680 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
681       if (nconf .lt. nodes-1) then
682         write (*,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1',
683      &   nconf,nodes-1 
684         write (iout,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1',
685      &   nconf,nodes-1 
686         call mpi_abort(mpi_comm_world,ierror,ierrcode)
687       endif
688       do n=1,nconf
689 c  pull out external and internal variables for next start
690         call putx(xin,n,rad)
691 !        write (iout,*) 'XIN from FEEDIN N=',n
692 !        write(iout,'(8f10.4)') (xin(j),j=1,nvar)
693         mm=mm+1
694         if (mm.lt.nodes) then
695 c  feed task to soldier
696 !       print *, ' sending input for start # ',n
697          info(1)=n
698          info(2)=-1
699          info(3)=0
700          info(4)=0
701          info(5)=0
702          info(6)=0
703          call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM,
704      *                  ierr)
705          call mpi_send(xin,nvar,mpi_double_precision,mm,
706      *                  idreal,CG_COMM,ierr)
707         else
708 c  find an available soldier
709          call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint,
710      *                 CG_COMM,muster,ierr)
711 !        print *, ' receiving output from start # ',ind(1)
712          man=muster(mpi_source)
713 c  receive final energies and variables
714          nft=nft+ind(3)
715          call mpi_recv(eout,1,mpi_double_precision,
716      *                 man,idreal,CG_COMM,muster,ierr)
717 !         print *,eout 
718 #ifdef CO_BIAS
719          call mpi_recv(co,1,mpi_double_precision,
720      *                 man,idreal,CG_COMM,muster,ierr)
721          write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co
722 #endif
723          call mpi_recv(xout,nvar,mpi_double_precision,
724      *                 man,idreal,CG_COMM,muster,ierr)
725 !         print *,nvar , ierr
726 c  feed next task to soldier
727 !        print *, ' sending input for start # ',n
728          info(1)=n
729          info(2)=-1
730          info(3)=0
731          info(4)=0
732          info(5)=0
733          info(6)=0
734          info(7)=0
735          info(8)=0
736          info(9)=0
737          call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,
738      *                  ierr)
739          call mpi_send(xin,nvar,mpi_double_precision,man,
740      *                  idreal,CG_COMM,ierr)
741 c  retrieve latest results
742          call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1))
743          if(iw_pdb.gt.0) 
744      &        call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb)
745         endif
746       enddo
747 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
748 c  no more input
749 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
750       do j=1,nodes-1
751 c  wait for a soldier
752        call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint,
753      *               CG_COMM,muster,ierr)
754 crc       if (ierr.ne.0) go to 30
755 !      print *, ' receiving output from start # ',ind(1)
756        man=muster(mpi_source)
757 c  receive final energies and variables
758        nft=nft+ind(3)
759        call mpi_recv(eout,1,
760      *               mpi_double_precision,man,idreal,
761      *               CG_COMM,muster,ierr)
762 !       print *,eout
763 #ifdef CO_BIAS
764          call mpi_recv(co,1,mpi_double_precision,
765      *                 man,idreal,CG_COMM,muster,ierr)
766          write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co
767 #endif
768 crc       if (ierr.ne.0) go to 30
769        call mpi_recv(xout,nvar,mpi_double_precision,
770      *               man,idreal,CG_COMM,muster,ierr)
771 !       print *,nvar , ierr
772 crc       if (ierr.ne.0) go to 30
773 c  halt soldier
774        info(1)=0
775        info(2)=-1
776        info(3)=0 
777        info(4)=0
778        info(5)=0
779        info(6)=0
780        call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,
781      *                ierr)
782 c  retrieve results
783        call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1))
784        if(iw_pdb.gt.0) 
785      &          call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb)
786       enddo
787 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
788       return
789    10 print *, ' dispatching error'
790       call mpi_abort(mpi_comm_world,ierror,ierrcode)
791       return
792    20 print *, ' communication error'
793       call mpi_abort(mpi_comm_world,ierror,ierrcode)
794       return
795    30 print *, ' receiving error'
796       call mpi_abort(mpi_comm_world,ierror,ierrcode)
797       return
798       end
799 cccccccccccccccccccccccccccccccccccccccccccccccccc
800       subroutine getx(ind,xout,eout,cout,rad,iw_pdb,k)
801 c  receives and stores data from soldiers
802       implicit real*8 (a-h,o-z)
803       include 'DIMENSIONS'
804       include 'COMMON.IOUNITS'
805       include 'COMMON.CSA'
806       include 'COMMON.BANK'
807       include 'COMMON.VAR'
808       include 'COMMON.CHAIN'
809       include 'COMMON.CONTACTS'
810       dimension ind(9),xout(maxvar),eout(mxch*(mxch+1)/2+1)
811 cjlee
812       double precision przes(3),obr(3,3)
813       logical non_conv
814 cjlee
815       iw_pdb=2
816       if (k.gt.mxio .or. k.lt.1) then 
817         write (iout,*) 
818      &   'ERROR - dimensions of ANGMIN have been exceeded K=',k
819         call mpi_abort(mpi_comm_world,ierror,ierrcode)
820       endif
821 c  store ind()
822       do j=1,9
823        indb(k,j)=ind(j)
824       enddo
825 c  store energies
826       etot(k)=eout(1)
827 c  retrieve dihedral angles etc
828       call var_to_geom(nvar,xout)
829       do j=2,nres-1
830         dihang(1,j,1,k)=theta(j+1)
831         dihang(2,j,1,k)=phi(j+2)
832         dihang(3,j,1,k)=alph(j)
833         dihang(4,j,1,k)=omeg(j)
834       enddo
835       dihang(2,nres-1,1,k)=0.0d0
836 cjlee
837       if(iref.eq.0) then 
838        iw_pdb=1
839 cd       write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4)') 
840 cd     &      ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' mv ',
841 cd     &      ind(5),ind(4)
842        return
843       endif
844       call chainbuild
845 c     call dihang_to_c(dihang(1,1,1,k))
846 c     call fitsq(rms,c(1,1),crefjlee(1,1),nres,przes,obr,non_conv)
847 c     call fitsq(rms,c(1,2),crefjlee(1,2),nres-1,przes,obr,non_conv)
848 c           call fitsq(rms,c(1,nstart_seq),crefjlee(1,nstart_sup),
849 c    &                 nsup,przes,obr,non_conv)
850 c      rmsn(k)=dsqrt(rms)
851
852        call rmsd_csa(rmsn(k))
853        call contact(.false.,ncont,icont,co)
854        pncn(k)=contact_fract(ncont,ncont_ref,icont,icont_ref)     
855
856 cd       write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a5
857 cd     &      ,0pf5.2,a5,f5.1,a,f6.3,a4,i3,i4)') 
858 cd     &    ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' rms ',
859 cd     &    rmsn(k),' %NC ',pncn(k)*100,' cont.order',co,' mv ',
860 cd     &    ind(5),ind(4)
861
862  
863       if (rmsn(k).gt.rmscut.or.pncn(k).lt.pnccut) iw_pdb=0
864       return
865       end
866 cccccccccccccccccccccccccccccccccccccccccccccccccc
867       subroutine putx(xin,n,rad)
868 c  gets starting variables
869       implicit real*8 (a-h,o-z)
870       include 'DIMENSIONS'
871       include 'COMMON.CSA'
872       include 'COMMON.BANK'
873       include 'COMMON.VAR'
874       include 'COMMON.CHAIN'
875       include 'COMMON.IOUNITS'
876       dimension xin(maxvar)
877
878 c  pull out starting values for variables
879 !       write (iout,*)'PUTX: N=',n
880       do m=1,numch
881 !        write (iout,'(8f10.4)') (dihang_in(1,j,m,n),j=2,nres-1)
882 !        write (iout,'(8f10.4)') (dihang_in(2,j,m,n),j=2,nres-1)
883 !        write (iout,'(8f10.4)') (dihang_in(3,j,m,n),j=2,nres-1)
884 !        write (iout,'(8f10.4)') (dihang_in(4,j,m,n),j=2,nres-1)
885        do j=2,nres-1
886         theta(j+1)=dihang_in(1,j,m,n)
887         phi(j+2)=dihang_in(2,j,m,n)
888         alph(j)=dihang_in(3,j,m,n)
889         omeg(j)=dihang_in(4,j,m,n)
890        enddo
891       enddo
892 c  set up array of variables
893       call geom_to_var(nvar,xin)
894 !       write (iout,*) 'xin in PUTX N=',n 
895 !       call intout
896 !       write (iout,'(8f10.4)') (xin(i),i=1,nvar) 
897       return
898       end
899 c--------------------------------------------------------
900       subroutine putx2(xin,iff,n)
901 c  gets starting variables
902       implicit real*8 (a-h,o-z)
903       include 'DIMENSIONS'
904       include 'COMMON.CSA'
905       include 'COMMON.BANK'
906       include 'COMMON.VAR'
907       include 'COMMON.CHAIN'
908       include 'COMMON.IOUNITS'
909       dimension xin(maxvar),iff(maxres)
910
911 c  pull out starting values for variables
912       do m=1,numch
913        do j=2,nres-1
914         theta(j+1)=dihang_in2(1,j,m,n)
915         phi(j+2)=dihang_in2(2,j,m,n)
916         alph(j)=dihang_in2(3,j,m,n)
917         omeg(j)=dihang_in2(4,j,m,n)
918        enddo
919       enddo
920 c  set up array of variables
921       call geom_to_var(nvar,xin)
922        
923       do i=1,nres
924         iff(i)=iff_in(i,n)
925       enddo
926       return
927       end
928
929 c-------------------------------------------------------
930       subroutine prune_bank(p_cut)
931       implicit real*8 (a-h,o-z)
932       include 'DIMENSIONS'
933       include 'mpif.h'
934       include 'COMMON.CSA'
935       include 'COMMON.BANK'
936       include 'COMMON.IOUNITS'
937       include 'COMMON.CHAIN'
938       include 'COMMON.TIME1'
939       include 'COMMON.SETUP'
940 c---------------------------
941 c This subroutine prunes bank conformations using p_cut
942 c---------------------------
943
944       nprune=0
945       nprune=nprune+1
946       m=1
947       do k=1,numch
948        do j=2,nres-1
949         do i=1,4
950          dihang(i,j,k,nprune)=bvar(i,j,k,m)
951         enddo
952        enddo
953       enddo
954       bene(nprune)=bene(m)
955       brmsn(nprune)=brmsn(m)
956       bpncn(nprune)=bpncn(m) 
957
958       do m=2,nbank
959        ddmin=9.d190
960        do ip=1,nprune
961         call get_diff12(dihang(1,1,1,ip),bvar(1,1,1,m),diff) 
962         if(diff.lt.p_cut) goto 100
963         if(diff.lt.ddmin) ddmin=diff
964        enddo
965        nprune=nprune+1
966        do k=1,numch
967         do j=2,nres-1
968          do i=1,4
969           dihang(i,j,k,nprune)=bvar(i,j,k,m)
970          enddo
971         enddo
972        enddo
973        bene(nprune)=bene(m)
974        brmsn(nprune)=brmsn(m)
975        bpncn(nprune)=bpncn(m)
976   100  continue
977        write (iout,*) 'Pruning :',m,nprune,p_cut,ddmin
978       enddo
979       nbank=nprune
980       print *, 'Pruning :',m,nprune,p_cut
981       call write_bank(0,0)
982
983       return
984       end
985 c-------------------------------------------------------
986
987       subroutine reminimize(jlee)
988       implicit real*8 (a-h,o-z)
989       include 'DIMENSIONS'
990       include 'mpif.h'
991       include 'COMMON.CSA'
992       include 'COMMON.BANK'
993       include 'COMMON.IOUNITS'
994       include 'COMMON.CHAIN'
995       include 'COMMON.TIME1'
996       include 'COMMON.SETUP'
997 c---------------------------
998 c This subroutine re-minimizes bank conformations:
999 c---------------------------
1000
1001        ntry=nbank
1002
1003        call find_max
1004        call find_min
1005
1006        if (me.eq.king) then
1007         open(icsa_history,file=csa_history,status="old")
1008          write(icsa_history,*) "Re-minimization",nodes,"nodes"
1009          write(icsa_history,851) (bene(i),i=1,nbank)
1010          write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax,
1011      *   ebmin,ebmax,nft,iuse,nbank,ntbank
1012         close(icsa_history)
1013         do index=1,ntry
1014          do k=1,numch
1015           do j=2,nres-1
1016            do i=1,4
1017             dihang_in(i,j,k,index)=bvar(i,j,k,index)
1018            enddo
1019           enddo
1020          enddo
1021         enddo
1022         nft=0
1023         call feedin(ntry,nft)
1024        else
1025         call minim_jlee
1026        endif
1027
1028        call find_max
1029        call find_min
1030
1031        if (me.eq.king) then
1032         do i=1,ntry
1033          call replace_bvar(i,i)
1034         enddo
1035         open(icsa_history,file=csa_history,status="old")
1036          write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax,
1037      *   ebmin,ebmax,nft,iuse,nbank,ntbank
1038          write(icsa_history,851) (bene(i),i=1,nbank)
1039         close(icsa_history)
1040         call write_bank_reminimized(jlee,nft)
1041        endif
1042
1043    40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4)
1044   851 format(5e15.6)
1045   850 format(5e15.10)
1046 c  850 format(10f8.3)
1047
1048       return
1049       end
1050 c-------------------------------------------------------
1051       subroutine send(n,mm,it)
1052 c  sends out starting conformation for minimization
1053       implicit real*8 (a-h,o-z)
1054       include 'DIMENSIONS'
1055       include 'COMMON.VAR'
1056       include 'COMMON.IOUNITS'
1057       include 'COMMON.CONTROL'
1058       include 'COMMON.BANK'
1059       include 'COMMON.CHAIN'
1060       include 'mpif.h'
1061       dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1),
1062      *          cout(2),ind(8),xin2(maxvar),iff(maxres),info(12)
1063       dimension muster(mpi_status_size)
1064       include 'COMMON.SETUP'
1065       parameter (rad=1.745329252d-2)
1066
1067       if (isend2(n).eq.0) then
1068 c  pull out external and internal variables for next start
1069         call putx(xin,n,rad)
1070         info(1)=n
1071         info(2)=it
1072         info(3)=movenx(n)
1073         info(4)=nss_in(n)
1074         info(5)=parent(1,n)
1075         info(6)=parent(2,n)
1076
1077         if (movenx(n).eq.14.or.movenx(n).eq.17) then
1078           info(7)=idata(1,n)
1079           info(8)=idata(2,n)
1080         else if (movenx(n).eq.16) then
1081           info(7)=idata(1,n)
1082           info(8)=idata(2,n)
1083           info(10)=idata(3,n)
1084           info(11)=idata(4,n)
1085           info(12)=idata(5,n)
1086         else
1087          info(7)=0
1088          info(8)=0
1089          info(10)=0
1090          info(11)=0
1091          info(12)=0
1092         endif
1093
1094         if (movenx(n).eq.15) then
1095          info(9)=parent(3,n)
1096         else
1097          info(9)=0
1098         endif
1099         call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM,
1100      *                  ierr)
1101         call mpi_send(xin,nvar,mpi_double_precision,mm,
1102      *                  idreal,CG_COMM,ierr)
1103       else
1104 c  distfit & minimization for n7 move
1105         info(1)=-n
1106         info(2)=it
1107         info(3)=movenx(n)
1108         info(4)=nss_in(n)
1109         info(5)=parent(1,n)
1110         info(6)=parent(2,n)
1111         info(7)=0
1112         info(8)=0
1113         info(9)=0
1114         call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM,
1115      *                  ierr)
1116         call putx2(xin,iff,isend2(n))
1117         call mpi_send(xin,nvar,mpi_double_precision,mm,
1118      *                  idreal,CG_COMM,ierr)
1119         call mpi_send(iff,nres,mpi_integer,mm,
1120      *                  idint,CG_COMM,ierr)
1121         call putx(xin2,n,rad)
1122         call mpi_send(xin2,nvar,mpi_double_precision,mm,
1123      *                  idreal,CG_COMM,ierr)
1124       endif 
1125       if (vdisulf.and.nss_in(n).ne.0) then
1126         call mpi_send(iss_in(1,n),nss_in(n),mpi_integer,mm,
1127      *                  idint,CG_COMM,ierr)
1128         call mpi_send(jss_in(1,n),nss_in(n),mpi_integer,mm,
1129      *                  idint,CG_COMM,ierr)
1130       endif
1131       return
1132       end
1133 c-------------------------------------------------
1134
1135       subroutine recv(ihalt,man,xout,eout,ind,tout)
1136 c  receives results of energy minimization
1137       implicit real*8 (a-h,o-z)
1138       include 'DIMENSIONS'
1139       include 'COMMON.VAR'
1140       include 'COMMON.IOUNITS'
1141       include 'COMMON.CONTROL'
1142       include 'COMMON.SBRIDGE'
1143       include 'COMMON.BANK'
1144       include 'COMMON.CHAIN'
1145       include 'mpif.h'
1146       dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1),
1147      *          cout(2),ind(9),info(12)
1148       dimension muster(mpi_status_size)
1149       include 'COMMON.SETUP'
1150       logical tout,flag
1151       double precision twait,tstart,tend1
1152       parameter(twait=600.0d0)
1153
1154 c  find an available soldier
1155        tout=.false.
1156        flag=.false.
1157        tstart=MPI_WTIME()
1158        do while(.not. (flag .or. tout))
1159          call MPI_IPROBE(mpi_any_source,idint,CG_COMM,flag, 
1160      *            muster,ierr)
1161          tend1=MPI_WTIME()
1162          if(tend1-tstart.gt.twait .and. ihalt.eq.1) tout=.true.
1163 c_error         if(tend1-tstart.gt.twait) tout=.true.
1164        enddo
1165        if (tout) then 
1166          write(iout,*) 'ERROR = timeout for recv ',tend1-tstart
1167          call flush(iout)
1168          return
1169        endif
1170        man=muster(mpi_source)        
1171
1172 ctimeout         call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint,
1173 ctimeout     *                 CG_COMM,muster,ierr)
1174 !        print *, ' receiving output from start # ',ind(1)
1175 ct         print *,'receiving ',MPI_WTIME()
1176 ctimeout         man=muster(mpi_source)
1177          call mpi_recv(ind,9,mpi_integer,man,idint,
1178      *                 CG_COMM,muster,ierr)
1179 ctimeout
1180 c  receive final energies and variables
1181          call mpi_recv(eout,1,mpi_double_precision,
1182      *                 man,idreal,CG_COMM,muster,ierr)
1183 !         print *,eout 
1184 #ifdef CO_BIAS
1185          call mpi_recv(co,1,mpi_double_precision,
1186      *                 man,idreal,CG_COMM,muster,ierr)
1187          write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co
1188 #endif
1189          call mpi_recv(xout,nvar,mpi_double_precision,
1190      *                 man,idreal,CG_COMM,muster,ierr)
1191 !         print *,nvar , ierr
1192          if(vdisulf) nss=ind(6)
1193          if(vdisulf.and.nss.ne.0) then
1194           call mpi_recv(ihpb,nss,mpi_integer,
1195      *                 man,idint,CG_COMM,muster,ierr)         
1196           call mpi_recv(jhpb,nss,mpi_integer,
1197      *                 man,idint,CG_COMM,muster,ierr)
1198          endif
1199 c  halt soldier
1200        if(ihalt.eq.1) then 
1201 c        print *,'sending halt to ',man
1202         write(iout,*) 'sending halt to ',man
1203         info(1)=0
1204         call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,ierr)
1205        endif
1206       return
1207       end
1208
1209 c---------------------------------------------------------- 
1210       subroutine history_append 
1211       implicit real*8 (a-h,o-z)
1212       include 'DIMENSIONS'
1213       include 'COMMON.IOUNITS'
1214
1215 #if defined(AIX) || defined(PGI)
1216        open(icsa_history,file=csa_history,position="append")
1217 #else
1218        open(icsa_history,file=csa_history,access="append")
1219 #endif
1220        return
1221        end