Subroutine together c feeds tasks for parallel processing implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'mpif.h' real ran1,ran2 include 'COMMON.CSA' include 'COMMON.BANK' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.TIME1' include 'COMMON.SETUP' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.CONTROL' include 'COMMON.SBRIDGE' real tcpu double precision time_start,time_start_c,time0f,time0i logical ovrtim,sync_iter,timeout,flag,timeout1 dimension muster(mpi_status_size) dimension t100(0:100),indx(mxio) dimension xout(maxvar),eout(mxch*(mxch+1)/2+1),ind(9) dimension cout(2) parameter (rad=1.745329252d-2) cccccccccccccccccccccccccccccccccccccccccccccccc IF (ME.EQ.KING) THEN time0f=MPI_WTIME() ilastnstep=1 sync_iter=.false. numch=1 nrmsdb=0 nrmsdb1=0 rmsdbc1c=rmsdbc1 nstep=0 call csa_read call make_array if(iref.ne.0) call from_int(1,0,idum) c To minimize input conformation (bank conformation) c Output to $mol.reminimized if (irestart.lt.0) then call read_bank(0,nft,cutdifr) if (irestart.lt.-10) then p_cut=nres*4.d0 call prune_bank(p_cut) return endif call reminimize(jlee) return endif if (irestart.eq.0) then call initial_write nbank=nconf ntbank=nconf if (ntbankm.eq.0) ntbank=0 nstep=0 nft=0 do i=1,mxio ibank(i)=0 jbank(i)=0 enddo else call restart_write c!bankt call read_bankt(jlee,nft,cutdifr) call read_bank(jlee,nft,cutdifr) call read_rbank(jlee,adif) if(iref.ne.0) call from_int(1,0,idum) endif nstmax=nstmax+nstep ntrial=n1+n2+n3+n4+n5+n6+n7+n8 ntry=ntrial+1 ntry=ntry*nseed c ntrial : number of trial conformations per seed. c ntry : total number of trial conformations including seed conformations. idum2=-123 c imax=2**31-1 imax=huge(0) ENDIF call mpi_bcast(jend,1,mpi_integer,0,CG_COMM,ierr) cccccccccccccccccccccccccccccccccccccccc do 300 jlee=1,jend cccccccccccccccccccccccccccccccccccccccc 331 continue IF (ME.EQ.KING) THEN if(sync_iter) goto 333 idum=- ran2(idum2)*imax if(jlee.lt.jstart) goto 300 C Restart the random number generator for conformation generation if(irestart.gt.0) then idum2=idum2+nstep if(idum2.le.0) idum2=-idum2+1 idum=- ran2(idum2)*imax endif idumm=idum call vrndst(idumm) open(icsa_seed,file=csa_seed,status="old") write(icsa_seed,*) "jlee : ",jlee close(icsa_seed) call history_append write(icsa_history,*) "number of procs is ",nodes write(icsa_history,*) jlee,idum,idum2 close(icsa_history) cccccccccccccccccccccccccccccccccccccccccccccccc 333 icycle=0 call history_append write(icsa_history,*) "nbank is ",nbank close(icsa_history) if(irestart.eq.1) goto 111 if(irestart.eq.2) then icycle=0 do i=1,nbank ibank(i)=1 enddo do i=nbank+1,nbank+nconf ibank(i)=0 enddo endif c start energy minimization nconfr=max0(nconf+nadd,nodes-1) if (sync_iter) nconf_in=0 c king-emperor - feed input and sort output write (iout,*) "NCONF_IN",nconf_in m=0 if (nconf_in.gt.0) then c al 7/2/00 - added possibility to read in some of the initial conformations do m=1,nconf_in read (intin,'(i5)',end=11,err=12) iconf 12 continue write (iout,*) "write READ_ANGLES",iconf,m call read_angles(intin,*11) if (iref.eq.0) then mm=m else mm=m+1 endif do j=2,nres-1 dihang_in(1,j,1,mm)=theta(j+1) dihang_in(2,j,1,mm)=phi(j+2) dihang_in(3,j,1,mm)=alph(j) dihang_in(4,j,1,mm)=omeg(j) enddo enddo ! m goto 13 11 write (iout,*) nconf_in," conformations requested, but only", & m-1," found in the angle file." nconf_in=m-1 13 continue m=nconf_in write (iout,*) nconf_in, & " initial conformations have been read in." endif if (iref.eq.0) then if (nconfr.gt.nconf_in) then call make_ranvar(nconfr,m,idum) write (iout,*) nconfr-nconf_in, & " conformations have been generated randomly." endif else nconfr=nconfr*2 call from_int(nconfr,m,idum) c call from_pdb(nconfr,idum) endif write (iout,*) 'Exitted from make_ranvar nconfr=',nconfr write (*,*) 'Exitted from make_ranvar nconfr=',nconfr do m=1,nconfr write (iout,*) 'Initial conformation',m write(iout,'(8f10.4)') (rad2deg*dihang_in(1,j,1,m),j=2,nres-1) write(iout,'(8f10.4)') (rad2deg*dihang_in(2,j,1,m),j=2,nres-1) write(iout,'(8f10.4)') (rad2deg*dihang_in(3,j,1,m),j=2,nres-1) write(iout,'(8f10.4)') (rad2deg*dihang_in(4,j,1,m),j=2,nres-1) enddo write(iout,*)'Calling FEEDIN NCONF',nconfr time1i=MPI_WTIME() call feedin(nconfr,nft) write (iout,*) ' Time for first bank min.',MPI_WTIME()-time1i call history_append write(icsa_history,*) jlee,nft,nbank write(icsa_history,851) (etot(i),i=1,nconfr) write(icsa_history,850) (rmsn(i),i=1,nconfr) write(icsa_history,850) (pncn(i),i=1,nconfr) write(icsa_history,*) close(icsa_history) ELSE c To minimize input conformation (bank conformation) c Output to $mol.reminimized if (irestart.lt.0) then call reminimize(jlee) return endif if (irestart.eq.1) goto 111 c soldier - perform energy minimization 334 call minim_jlee ENDIF ccccccccccccccccccccccccccccccccccc c need to syncronize all procs call mpi_barrier(CG_COMM,ierr) if (ierr.ne.0) then print *, ' cannot synchronize MPI' stop endif ccccccccccccccccccccccccccccccccccc IF (ME.EQ.KING) THEN c print *,"ok after minim" nstep=nstep+nconf if(irestart.eq.2) then nbank=nbank+nconf c ntbank=ntbank+nconf if(ntbank.gt.ntbankm) ntbank=ntbankm endif c print *,"ok before indexx" if(iref.eq.0) then call indexx(nconfr,etot,indx) else c cc/al 7/6/00 do k=1,nconfr indx(k)=k enddo call indexx(nconfr-nconf_in,rmsn(nconf_in+1),indx(nconf_in+1)) do k=nconf_in+1,nconfr indx(k)=indx(k)+nconf_in enddo c cc/al c call indexx(nconfr,rmsn,indx) endif c print *,"ok after indexx" do im=1,nconf m=indx(im) if (m.gt.mxio .or. m.lt.1) then write (iout,*) 'Dimension ERROR in TOGEHER: IM',im,' M',m call mpi_abort(mpi_comm_world,ierror,ierrcode) endif jbank(im+nbank-nconf)=0 bene(im+nbank-nconf)=etot(m) rene(im+nbank-nconf)=etot(m) c!bankt btene(im)=etot(m) c brmsn(im+nbank-nconf)=rmsn(m) bpncn(im+nbank-nconf)=pncn(m) rrmsn(im+nbank-nconf)=rmsn(m) rpncn(im+nbank-nconf)=pncn(m) if (im+nbank-nconf.gt.mxio .or. im+nbank-nconf.lt.1) then write (iout,*) 'Dimension ERROR in TOGEHER: IM',im, & ' NBANK',nbank,' NCONF',nconf,' IM+NBANK-NCONF',im+nbank-nconf call mpi_abort(mpi_comm_world,ierror,ierrcode) endif do k=1,numch do j=2,nres-1 do i=1,4 bvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m) rvar(i,j,k,im+nbank-nconf)=dihang(i,j,k,m) c!bankt btvar(i,j,k,im)=dihang(i,j,k,m) c enddo enddo enddo if(iref.eq.1) then if(brmsn(im+nbank-nconf).gt.rmscut.or. & bpncn(im+nbank-nconf).lt.pnccut) ibank(im+nbank-nconf)=9 endif if(vdisulf) then bvar_ns(im+nbank-nconf)=ns-2*nss k=0 do i=1,ns j=1 do while( iss(i).ne.ihpb(j)-nres .and. & iss(i).ne.jhpb(j)-nres .and. j.le.nss) j=j+1 enddo if (j.gt.nss) then k=k+1 bvar_s(k,im+nbank-nconf)=iss(i) endif enddo endif bvar_nss(im+nbank-nconf)=nss do i=1,nss bvar_ss(1,i,im+nbank-nconf)=ihpb(i) bvar_ss(2,i,im+nbank-nconf)=jhpb(i) enddo enddo ENDIF 111 continue IF (ME.EQ.KING) THEN call find_max call find_min call get_diff if(nbank.eq.nconf.and.irestart.eq.0) then adif=avedif endif cutdif=adif/cut1 ctdif1=adif/cut2 cd print *,"adif,xctdif,cutdifr" cd print *,adif,xctdif,cutdifr nst=ntotal/ntrial/nseed xctdif=(cutdif/ctdif1)**(-1.0/nst) if(irestart.ge.1) call estimate_cutdif(adif,xctdif,cutdifr) c print *,"ok after estimate" irestart=0 call write_rbank(jlee,adif,nft) call write_bank(jlee,nft) c!bankt call write_bankt(jlee,nft) c call write_bank1(jlee) call history_append write(icsa_history,*) "xctdif: ", xctdif,nst,adif/cut1,ctdif1 write(icsa_history,851) (bene(i),i=1,nbank) write(icsa_history,850) (brmsn(i),i=1,nbank) write(icsa_history,850) (bpncn(i),i=1,nbank) close(icsa_history) 850 format(10f8.3) 851 format(5e15.6) ifar=nseed/4*3+1 ifar=nseed+1 ENDIF finished=.false. iter = 0 irecv = 0 isent =0 ifrom= 0 time0i=MPI_WTIME() time1i=time0i time_start_c=time0i if (.not.sync_iter) then time_start=time0i nft00=nft else sync_iter=.false. endif nft00_c=nft nft0i=nft ccccccccccccccccccccccccccccccccccccccc do while (.not. finished) ccccccccccccccccccccccccccccccccccccccc crc print *,"iter ", iter,' isent=',isent IF (ME.EQ.KING) THEN c start energy minimization if (isent.eq.0) then c king-emperor - select seeds & make var & feed input cd print *,'generating new conf',ntrial,MPI_WTIME() call select_is(nseed,ifar,idum) open(icsa_seed,file=csa_seed,status="old") write(icsa_seed,39) & jlee,icycle,nstep,(is(i),bene(is(i)),i=1,nseed) close(icsa_seed) call history_append write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, * ebmin,ebmax,nft,iuse,nbank,ntbank close(icsa_history) call make_var(ntry,idum,iter) cd print *,'new trial generated',ntrial,MPI_WTIME() time2i=MPI_WTIME() write (iout,'(a20,i4,f12.2)') & 'Time for make trial',iter+1,time2i-time1i endif crc write(iout,*)'1:Calling FEEDIN NTRY',NTRY,' ntrial',ntrial crc call feedin(ntry,nft) isent=isent+1 if (isent.ge.nodes.or.iter.gt.0) then ct print *,'waiting ',MPI_WTIME() irecv=irecv+1 call recv(0,ifrom,xout,eout,ind,timeout) ct print *,' ',irecv,' received from',ifrom,MPI_WTIME() else ifrom=ifrom+1 endif ct print *,'sending to',ifrom,MPI_WTIME() call send(isent,ifrom,iter) ct print *,isent,' sent ',MPI_WTIME() c store results ----------------------------------------------- if (isent.ge.nodes.or.iter.gt.0) then nft=nft+ind(3) movernx(irecv)=iabs(ind(5)) call getx(ind,xout,eout,cout,rad,iw_pdb,irecv) if(vdisulf) then nss_out(irecv)=nss do i=1,nss iss_out(i,irecv)=ihpb(i) jss_out(i,irecv)=jhpb(i) enddo endif if(iw_pdb.gt.0) & call write_csa_pdb(xout,eout,nft,irecv,iw_pdb) endif c-------------------------------------------------------------- if (isent.eq.ntry) then time1i=MPI_WTIME() write (iout,'(a18,f12.2,a14,f10.2)') & 'Nonsetup time ',time1i-time_start_c, & ' sec, Eval/s =',(nft-nft00_c)/(time1i-time_start_c) write (iout,'(a14,i4,f12.2,a14,f10.2)') & 'Time for iter ',iter+1,time1i-time0i, & ' sec, Eval/s =',(nft-nft0i)/(time1i-time0i) time0i=time1i nft0i=nft cutdif=cutdif*xctdif if(cutdif.lt.ctdif1) cutdif=ctdif1 if (iter.eq.0) then print *,'UPDATING ',ntry-nodes+1,irecv write(iout,*) 'UPDATING ',ntry-nodes+1 iter=iter+1 c----------------- call update(ntry-nodes+1) ------------------- nstep=nstep+ntry-nseed-(nodes-1) call refresh_bank(ntry-nodes+1) c!bankt call refresh_bankt(ntry-nodes+1) else c----------------- call update(ntry) --------------------------- iter=iter+1 print *,'UPDATING ',ntry,irecv write(iout,*) 'UPDATING ',ntry nstep=nstep+ntry-nseed call refresh_bank(ntry) c!bankt call refresh_bankt(ntry) endif c----------------------------------------------------------------- call write_bank(jlee,nft) c!bankt call write_bankt(jlee,nft) call find_min time1i=MPI_WTIME() write (iout,'(a20,i4,f12.2)') & 'Time for refresh ',iter,time1i-time0i if(ebmin.lt.estop) finished=.true. if(icycle.gt.icmax) then call write_bank1(jlee) do i=1,nbank ibank(i)=2 ibank(i)=1 enddo nbank=nbank+nconf if(nbank.gt.1000) then finished=.true. else crc goto 333 sync_iter=.true. endif endif if(nstep.gt.nstmax) finished=.true. if(finished.or.sync_iter) then do ij=1,nodes-1 call recv(1,ifrom,xout,eout,ind,timeout) if (timeout) then nstep=nstep+ij-1 print *,'ERROR worker is not responding' write(iout,*) 'ERROR worker is not responding' time1i=MPI_WTIME()-time_start_c print *,'End of cycle, master time for ',iter,' iters ', & time1i,'sec, Eval/s ',(nft-nft00_c)/time1i write (iout,*) 'End of cycle, master time for ',iter, & ' iters ',time1i,' sec' write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i print *,'UPDATING ',ij-1 write(iout,*) 'UPDATING ',ij-1 call flush(iout) call refresh_bank(ij-1) c!bankt call refresh_bankt(ij-1) goto 1002 endif c print *,'node ',ifrom,' finished ',ij,nft write(iout,*) 'node ',ifrom,' finished ',ij,nft call flush(iout) nft=nft+ind(3) movernx(ij)=iabs(ind(5)) call getx(ind,xout,eout,cout,rad,iw_pdb,ij) if(vdisulf) then nss_out(ij)=nss do i=1,nss iss_out(i,ij)=ihpb(i) jss_out(i,ij)=jhpb(i) enddo endif if(iw_pdb.gt.0) & call write_csa_pdb(xout,eout,nft,ij,iw_pdb) enddo nstep=nstep+nodes-1 crc print *,'---------bcast finished--------',finished time1i=MPI_WTIME()-time_start_c print *,'End of cycle, master time for ',iter,' iters ', & time1i,'sec, Eval/s ',(nft-nft00_c)/time1i write (iout,*) 'End of cycle, master time for ',iter, & ' iters ',time1i,' sec' write (iout,*) 'Total eval/s ',(nft-nft00_c)/time1i ctimeout call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr) ctimeout call mpi_bcast(sync_iter,1,mpi_logical,0, ctimeout & CG_COMM,ierr) do ij=1,nodes-1 tstart=MPI_WTIME() call mpi_issend(finished,1,mpi_logical,ij,idchar, & CG_COMM,ireq,ierr) call mpi_issend(sync_iter,1,mpi_logical,ij,idchar, & CG_COMM,ireq2,ierr) flag=.false. timeout1=.false. do while(.not. (flag .or. timeout1)) call MPI_TEST(ireq2,flag,muster,ierr) tend1=MPI_WTIME() if(tend1-tstart.gt.60) then print *,'ERROR worker ',ij,' is not responding' write(iout,*) 'ERROR worker ',ij,' is not responding' timeout1=.true. endif enddo if(timeout1) then write(iout,*) 'worker ',ij,' NOT OK ',tend1-tstart timeout=.true. else write(iout,*) 'worker ',ij,' OK ',tend1-tstart endif enddo print *,'UPDATING ',nodes-1,ij write(iout,*) 'UPDATING ',nodes-1 call refresh_bank(nodes-1) c!bankt call refresh_bankt(nodes-1) 1002 continue call write_bank(jlee,nft) c!bankt call write_bankt(jlee,nft) call find_min do i=0,mxmv do j=1,3 nstatnx_tot(i,j)=nstatnx_tot(i,j)+nstatnx(i,j) nstatnx(i,j)=0 enddo enddo write(iout,*)'### Total stats:' do i=0,mxmv if(nstatnx_tot(i,1).ne.0) then if (i.le.9) then write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') & '### N',i,' total=',nstatnx_tot(i,1), & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc', & (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1) else write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') & '###N',i,' total=',nstatnx_tot(i,1), & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3),'%acc', & (nstatnx_tot(i,2)+nstatnx_tot(i,3))*100.0/nstatnx_tot(i,1) endif else if (i.le.9) then write(iout,'(a5,i1,a7,i6,a7,i4,a5,i4,a5,f5.1)') & '### N',i,' total=',nstatnx_tot(i,1), & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3), & ' %acc',0.0 else write(iout,'(a4,i2,a7,i6,a7,i4,a5,i4,a5,f5.1)') & '###N',i,' total=',nstatnx_tot(i,1), & ' close=',nstatnx_tot(i,2),' far=',nstatnx_tot(i,3), & ' %acc',0.0 endif endif enddo endif if(sync_iter) goto 331 39 format(2i3,i7,5(i4,f8.3,1x),19(/,13x,5(i4,f8.3,1x))) 40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4) 43 format(10i8) 44 format('jlee =',i3,':',4f10.1,' E =',f8.3,i7,i10) isent=0 irecv=0 endif ELSE c soldier - perform energy minimization call minim_jlee print *,'End of minim, proc',me,'time ',MPI_WTIME()-time_start write (iout,*) 'End of minim, proc',me,'time ', & MPI_WTIME()-time_start call flush(iout) ctimeout call mpi_bcast(finished,1,mpi_logical,0,CG_COMM,ierr) ctimeout call mpi_bcast(sync_iter,1,mpi_logical,0,CG_COMM,ierr) call mpi_recv(finished,1,mpi_logical,0,idchar, * CG_COMM,muster,ierr) call mpi_recv(sync_iter,1,mpi_logical,0,idchar, * CG_COMM,muster,ierr) if(sync_iter) goto 331 ENDIF ccccccccccccccccccccccccccccccccccccccc enddo ccccccccccccccccccccccccccccccccccccccc IF (ME.EQ.KING) THEN call history_append write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, * ebmin,ebmax,nft,iuse,nbank,ntbank write(icsa_history,44) jlee,0.0,0.0,0.0, & 0.0,ebmin,nstep,nft write(icsa_history,*) close(icsa_history) time1i=MPI_WTIME()-time_start print *,'End of RUN, master time ', & time1i,'sec, Eval/s ',(nft-nft00)/time1i write (iout,*) 'End of RUN, master time ', & time1i,' sec' write (iout,*) 'Total eval/s ',(nft-nft00)/time1i if(timeout) then write(iout,*) '!!!! ERROR worker was not responding' write(iout,*) '!!!! cannot finish work normally' write(iout,*) 'Processor0 is calling MPI_ABORT' print *,'!!!! ERROR worker was not responding' print *,'!!!! cannot finish work normally' print *,'Processor0 is calling MPI_ABORT' call flush(iout) call mpi_abort(mpi_comm_world, 111, ierr) endif ENDIF cccccccccccccccccccccccccccccc 300 continue cccccccccccccccccccccccccccccc return end c------------------------------------------------- subroutine feedin(nconf,nft) c sends out starting conformations and receives results of energy minimization implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.IOUNITS' include 'COMMON.CONTROL' include 'mpif.h' dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1), * cout(2),ind(9),info(12) dimension muster(mpi_status_size) include 'COMMON.SETUP' parameter (rad=1.745329252d-2) print *,'FEEDIN: NCONF=',nconf mm=0 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if (nconf .lt. nodes-1) then write (*,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1', & nconf,nodes-1 write (iout,*) 'FATAL ERROR in FEEDIN, nconf < nodes -1', & nconf,nodes-1 call mpi_abort(mpi_comm_world,ierror,ierrcode) endif do n=1,nconf c pull out external and internal variables for next start call putx(xin,n,rad) ! write (iout,*) 'XIN from FEEDIN N=',n ! write(iout,'(8f10.4)') (xin(j),j=1,nvar) mm=mm+1 if (mm.lt.nodes) then c feed task to soldier ! print *, ' sending input for start # ',n info(1)=n info(2)=-1 info(3)=0 info(4)=0 info(5)=0 info(6)=0 call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM, * ierr) call mpi_send(xin,nvar,mpi_double_precision,mm, * idreal,CG_COMM,ierr) else c find an available soldier call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, * CG_COMM,muster,ierr) ! print *, ' receiving output from start # ',ind(1) man=muster(mpi_source) c receive final energies and variables nft=nft+ind(3) call mpi_recv(eout,1,mpi_double_precision, * man,idreal,CG_COMM,muster,ierr) ! print *,eout #ifdef CO_BIAS call mpi_recv(co,1,mpi_double_precision, * man,idreal,CG_COMM,muster,ierr) write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co #endif call mpi_recv(xout,nvar,mpi_double_precision, * man,idreal,CG_COMM,muster,ierr) ! print *,nvar , ierr c feed next task to soldier ! print *, ' sending input for start # ',n info(1)=n info(2)=-1 info(3)=0 info(4)=0 info(5)=0 info(6)=0 info(7)=0 info(8)=0 info(9)=0 call mpi_send(info,12,mpi_integer,man,idint,CG_COMM, * ierr) call mpi_send(xin,nvar,mpi_double_precision,man, * idreal,CG_COMM,ierr) c retrieve latest results call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1)) if(iw_pdb.gt.0) & call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb) endif enddo cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c no more input cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc do j=1,nodes-1 c wait for a soldier call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, * CG_COMM,muster,ierr) crc if (ierr.ne.0) go to 30 ! print *, ' receiving output from start # ',ind(1) man=muster(mpi_source) c receive final energies and variables nft=nft+ind(3) call mpi_recv(eout,1, * mpi_double_precision,man,idreal, * CG_COMM,muster,ierr) ! print *,eout #ifdef CO_BIAS call mpi_recv(co,1,mpi_double_precision, * man,idreal,CG_COMM,muster,ierr) write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co #endif crc if (ierr.ne.0) go to 30 call mpi_recv(xout,nvar,mpi_double_precision, * man,idreal,CG_COMM,muster,ierr) ! print *,nvar , ierr crc if (ierr.ne.0) go to 30 c halt soldier info(1)=0 info(2)=-1 info(3)=0 info(4)=0 info(5)=0 info(6)=0 call mpi_send(info,12,mpi_integer,man,idint,CG_COMM, * ierr) c retrieve results call getx(ind,xout,eout,cout,rad,iw_pdb,ind(1)) if(iw_pdb.gt.0) & call write_csa_pdb(xout,eout,nft,ind(1),iw_pdb) enddo cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc return 10 print *, ' dispatching error' call mpi_abort(mpi_comm_world,ierror,ierrcode) return 20 print *, ' communication error' call mpi_abort(mpi_comm_world,ierror,ierrcode) return 30 print *, ' receiving error' call mpi_abort(mpi_comm_world,ierror,ierrcode) return end cccccccccccccccccccccccccccccccccccccccccccccccccc subroutine getx(ind,xout,eout,cout,rad,iw_pdb,k) c receives and stores data from soldiers implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.CSA' include 'COMMON.BANK' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.CONTACTS' dimension ind(9),xout(maxvar),eout(mxch*(mxch+1)/2+1) cjlee double precision przes(3),obr(3,3),cout(2) logical non_conv cjlee iw_pdb=2 if (k.gt.mxio .or. k.lt.1) then write (iout,*) & 'ERROR - dimensions of ANGMIN have been exceeded K=',k call mpi_abort(mpi_comm_world,ierror,ierrcode) endif c store ind() do j=1,9 indb(k,j)=ind(j) enddo c store energies etot(k)=eout(1) c retrieve dihedral angles etc call var_to_geom(nvar,xout) do j=2,nres-1 dihang(1,j,1,k)=theta(j+1) dihang(2,j,1,k)=phi(j+2) dihang(3,j,1,k)=alph(j) dihang(4,j,1,k)=omeg(j) enddo dihang(2,nres-1,1,k)=0.0d0 cjlee if(iref.eq.0) then iw_pdb=1 cd write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a4,i3,i4)') cd & ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' mv ', cd & ind(5),ind(4) return endif call chainbuild c call dihang_to_c(dihang(1,1,1,k)) c call fitsq(rms,c(1,1),crefjlee(1,1),nres,przes,obr,non_conv) c call fitsq(rms,c(1,2),crefjlee(1,2),nres-1,przes,obr,non_conv) c call fitsq(rms,c(1,nstart_seq),crefjlee(1,nstart_sup), c & nsup,przes,obr,non_conv) c rmsn(k)=dsqrt(rms) call rmsd_csa(rmsn(k)) call contact(.false.,ncont,icont,co) pncn(k)=contact_fract(ncont,ncont_ref,icont,icont_ref) cd write(iout,'(i3,a3,i4,i5,a6,1pe12.4,a5 cd & ,0pf5.2,a5,f5.1,a,f6.3,a4,i3,i4)') cd & ind(2),' e ',ind(3),ind(1),' etot ',etot(k),' rms ', cd & rmsn(k),' %NC ',pncn(k)*100,' cont.order',co,' mv ', cd & ind(5),ind(4) if (rmsn(k).gt.rmscut.or.pncn(k).lt.pnccut) iw_pdb=0 return end cccccccccccccccccccccccccccccccccccccccccccccccccc subroutine putx(xin,n,rad) c gets starting variables implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.CSA' include 'COMMON.BANK' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' dimension xin(maxvar) c pull out starting values for variables ! write (iout,*)'PUTX: N=',n do m=1,numch ! write (iout,'(8f10.4)') (dihang_in(1,j,m,n),j=2,nres-1) ! write (iout,'(8f10.4)') (dihang_in(2,j,m,n),j=2,nres-1) ! write (iout,'(8f10.4)') (dihang_in(3,j,m,n),j=2,nres-1) ! write (iout,'(8f10.4)') (dihang_in(4,j,m,n),j=2,nres-1) do j=2,nres-1 theta(j+1)=dihang_in(1,j,m,n) phi(j+2)=dihang_in(2,j,m,n) alph(j)=dihang_in(3,j,m,n) omeg(j)=dihang_in(4,j,m,n) enddo enddo c set up array of variables call geom_to_var(nvar,xin) ! write (iout,*) 'xin in PUTX N=',n ! call intout ! write (iout,'(8f10.4)') (xin(i),i=1,nvar) return end c-------------------------------------------------------- subroutine putx2(xin,iff,n) c gets starting variables implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.CSA' include 'COMMON.BANK' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' dimension xin(maxvar),iff(maxres) c pull out starting values for variables do m=1,numch do j=2,nres-1 theta(j+1)=dihang_in2(1,j,m,n) phi(j+2)=dihang_in2(2,j,m,n) alph(j)=dihang_in2(3,j,m,n) omeg(j)=dihang_in2(4,j,m,n) enddo enddo c set up array of variables call geom_to_var(nvar,xin) do i=1,nres iff(i)=iff_in(i,n) enddo return end c------------------------------------------------------- subroutine prune_bank(p_cut) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'mpif.h' include 'COMMON.CSA' include 'COMMON.BANK' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.TIME1' include 'COMMON.SETUP' c--------------------------- c This subroutine prunes bank conformations using p_cut c--------------------------- nprune=0 nprune=nprune+1 m=1 do k=1,numch do j=2,nres-1 do i=1,4 dihang(i,j,k,nprune)=bvar(i,j,k,m) enddo enddo enddo bene(nprune)=bene(m) brmsn(nprune)=brmsn(m) bpncn(nprune)=bpncn(m) do m=2,nbank ddmin=9.d190 do ip=1,nprune call get_diff12(dihang(1,1,1,ip),bvar(1,1,1,m),diff) if(diff.lt.p_cut) goto 100 if(diff.lt.ddmin) ddmin=diff enddo nprune=nprune+1 do k=1,numch do j=2,nres-1 do i=1,4 dihang(i,j,k,nprune)=bvar(i,j,k,m) enddo enddo enddo bene(nprune)=bene(m) brmsn(nprune)=brmsn(m) bpncn(nprune)=bpncn(m) 100 continue write (iout,*) 'Pruning :',m,nprune,p_cut,ddmin enddo nbank=nprune print *, 'Pruning :',m,nprune,p_cut call write_bank(0,0) return end c------------------------------------------------------- subroutine reminimize(jlee) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'mpif.h' include 'COMMON.CSA' include 'COMMON.BANK' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' include 'COMMON.TIME1' include 'COMMON.SETUP' c--------------------------- c This subroutine re-minimizes bank conformations: c--------------------------- ntry=nbank call find_max call find_min if (me.eq.king) then open(icsa_history,file=csa_history,status="old") write(icsa_history,*) "Re-minimization",nodes,"nodes" write(icsa_history,851) (bene(i),i=1,nbank) write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, * ebmin,ebmax,nft,iuse,nbank,ntbank close(icsa_history) do index=1,ntry do k=1,numch do j=2,nres-1 do i=1,4 dihang_in(i,j,k,index)=bvar(i,j,k,index) enddo enddo enddo enddo nft=0 call feedin(ntry,nft) else call minim_jlee endif call find_max call find_min if (me.eq.king) then do i=1,ntry call replace_bvar(i,i) enddo open(icsa_history,file=csa_history,status="old") write(icsa_history,40) jlee,icycle,nstep,cutdif,ibmin,ibmax, * ebmin,ebmax,nft,iuse,nbank,ntbank write(icsa_history,851) (bene(i),i=1,nbank) close(icsa_history) call write_bank_reminimized(jlee,nft) endif 40 format(2i2,i8,f8.1,2i4,2(1pe14.5),i10,3i4) 851 format(5e15.6) 850 format(5e15.10) c 850 format(10f8.3) return end c------------------------------------------------------- subroutine send(n,mm,it) c sends out starting conformation for minimization implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.IOUNITS' include 'COMMON.CONTROL' include 'COMMON.BANK' include 'COMMON.CHAIN' include 'mpif.h' dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1), * cout(2),ind(8),xin2(maxvar),iff(maxres),info(12) dimension muster(mpi_status_size) include 'COMMON.SETUP' parameter (rad=1.745329252d-2) if (isend2(n).eq.0) then c pull out external and internal variables for next start call putx(xin,n,rad) info(1)=n info(2)=it info(3)=movenx(n) info(4)=nss_in(n) info(5)=parent(1,n) info(6)=parent(2,n) if (movenx(n).eq.14.or.movenx(n).eq.17) then info(7)=idata(1,n) info(8)=idata(2,n) else if (movenx(n).eq.16) then info(7)=idata(1,n) info(8)=idata(2,n) info(10)=idata(3,n) info(11)=idata(4,n) info(12)=idata(5,n) else info(7)=0 info(8)=0 info(10)=0 info(11)=0 info(12)=0 endif if (movenx(n).eq.15) then info(9)=parent(3,n) else info(9)=0 endif call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM, * ierr) call mpi_send(xin,nvar,mpi_double_precision,mm, * idreal,CG_COMM,ierr) else c distfit & minimization for n7 move info(1)=-n info(2)=it info(3)=movenx(n) info(4)=nss_in(n) info(5)=parent(1,n) info(6)=parent(2,n) info(7)=0 info(8)=0 info(9)=0 call mpi_send(info,12,mpi_integer,mm,idint,CG_COMM, * ierr) call putx2(xin,iff,isend2(n)) call mpi_send(xin,nvar,mpi_double_precision,mm, * idreal,CG_COMM,ierr) call mpi_send(iff,nres,mpi_integer,mm, * idint,CG_COMM,ierr) call putx(xin2,n,rad) call mpi_send(xin2,nvar,mpi_double_precision,mm, * idreal,CG_COMM,ierr) endif if (vdisulf.and.nss_in(n).ne.0) then call mpi_send(iss_in(1,n),nss_in(n),mpi_integer,mm, * idint,CG_COMM,ierr) call mpi_send(jss_in(1,n),nss_in(n),mpi_integer,mm, * idint,CG_COMM,ierr) endif return end c------------------------------------------------- subroutine recv(ihalt,man,xout,eout,ind,tout) c receives results of energy minimization implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.IOUNITS' include 'COMMON.CONTROL' include 'COMMON.SBRIDGE' include 'COMMON.BANK' include 'COMMON.CHAIN' include 'mpif.h' dimension xin(maxvar),xout(maxvar),eout(mxch*(mxch+1)/2+1), * cout(2),ind(9),info(12) dimension muster(mpi_status_size) include 'COMMON.SETUP' logical tout,flag double precision twait,tstart,tend1 parameter(twait=600.0d0) c find an available soldier tout=.false. flag=.false. tstart=MPI_WTIME() do while(.not. (flag .or. tout)) call MPI_IPROBE(mpi_any_source,idint,CG_COMM,flag, * muster,ierr) tend1=MPI_WTIME() if(tend1-tstart.gt.twait .and. ihalt.eq.1) tout=.true. c_error if(tend1-tstart.gt.twait) tout=.true. enddo if (tout) then write(iout,*) 'ERROR = timeout for recv ',tend1-tstart call flush(iout) return endif man=muster(mpi_source) ctimeout call mpi_recv(ind,9,mpi_integer,mpi_any_source,idint, ctimeout * CG_COMM,muster,ierr) ! print *, ' receiving output from start # ',ind(1) ct print *,'receiving ',MPI_WTIME() ctimeout man=muster(mpi_source) call mpi_recv(ind,9,mpi_integer,man,idint, * CG_COMM,muster,ierr) ctimeout c receive final energies and variables call mpi_recv(eout,1,mpi_double_precision, * man,idreal,CG_COMM,muster,ierr) ! print *,eout #ifdef CO_BIAS call mpi_recv(co,1,mpi_double_precision, * man,idreal,CG_COMM,muster,ierr) write (iout,'(a15,f3.2,$)') ' BIAS by contact order*100 ',co #endif call mpi_recv(xout,nvar,mpi_double_precision, * man,idreal,CG_COMM,muster,ierr) ! print *,nvar , ierr if(vdisulf) nss=ind(6) if(vdisulf.and.nss.ne.0) then call mpi_recv(ihpb,nss,mpi_integer, * man,idint,CG_COMM,muster,ierr) call mpi_recv(jhpb,nss,mpi_integer, * man,idint,CG_COMM,muster,ierr) endif c halt soldier if(ihalt.eq.1) then c print *,'sending halt to ',man write(iout,*) 'sending halt to ',man info(1)=0 call mpi_send(info,12,mpi_integer,man,idint,CG_COMM,ierr) endif return end c---------------------------------------------------------- subroutine history_append implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.IOUNITS' #if defined(AIX) || defined(PGI) open(icsa_history,file=csa_history,position="append") #else open(icsa_history,file=csa_history,access="append") #endif return end