subroutine friction_force implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.MD' #ifndef LANG0 include 'COMMON.LANGEVIN' #else include 'COMMON.LANGEVIN.lang0' #endif include 'COMMON.IOUNITS' double precision gamvec(MAXRES6) common /syfek/ gamvec double precision vv(3),vvtot(3,maxres),v_work(MAXRES6), & ginvfric(maxres2,maxres2) common /przechowalnia/ ginvfric logical lprn /.false./, checkmode /.false./ do i=0,MAXRES2 do j=1,3 friction(j,i)=0.0d0 enddo enddo do j=1,3 d_t_work(j)=d_t(j,0) enddo ind=3 do i=nnt,nct-1 do j=1,3 d_t_work(ind+j)=d_t(j,i) enddo ind=ind+3 enddo do i=nnt,nct if (itype(i).ne.10) then do j=1,3 d_t_work(ind+j)=d_t(j,i+nres) enddo ind=ind+3 endif enddo call fricmat_mult(d_t_work,fric_work) if (.not.checkmode) return if (lprn) then write (iout,*) "d_t_work and fric_work" do i=1,3*dimen write (iout,'(i3,2e15.5)') i,d_t_work(i),fric_work(i) enddo endif do j=1,3 friction(j,0)=fric_work(j) enddo ind=3 do i=nnt,nct-1 do j=1,3 friction(j,i)=fric_work(ind+j) enddo ind=ind+3 enddo do i=nnt,nct if (itype(i).ne.10) then do j=1,3 friction(j,i+nres)=fric_work(ind+j) enddo ind=ind+3 endif enddo if (lprn) then write(iout,*) "Friction backbone" do i=0,nct-1 write(iout,'(i5,3e15.5,5x,3e15.5)') & i,(friction(j,i),j=1,3),(d_t(j,i),j=1,3) enddo write(iout,*) "Friction side chain" do i=nnt,nct write(iout,'(i5,3e15.5,5x,3e15.5)') & i,(friction(j,i+nres),j=1,3),(d_t(j,i+nres),j=1,3) enddo endif if (lprn) then do j=1,3 vv(j)=d_t(j,0) enddo do i=nnt,nct do j=1,3 vvtot(j,i)=vv(j)+0.5d0*d_t(j,i) vvtot(j,i+nres)=vv(j)+d_t(j,i+nres) vv(j)=vv(j)+d_t(j,i) enddo enddo write (iout,*) "vvtot backbone and sidechain" do i=nnt,nct write (iout,'(i5,3e15.5,5x,3e15.5)') i,(vvtot(j,i),j=1,3), & (vvtot(j,i+nres),j=1,3) enddo ind=0 do i=nnt,nct-1 do j=1,3 v_work(ind+j)=vvtot(j,i) enddo ind=ind+3 enddo do i=nnt,nct do j=1,3 v_work(ind+j)=vvtot(j,i+nres) enddo ind=ind+3 enddo write (iout,*) "v_work gamvec and site-based friction forces" do i=1,dimen1 write (iout,'(i5,3e15.5)') i,v_work(i),gamvec(i), & gamvec(i)*v_work(i) enddo c do i=1,dimen c fric_work1(i)=0.0d0 c do j=1,dimen1 c fric_work1(i)=fric_work1(i)-A(j,i)*gamvec(j)*v_work(j) c enddo c enddo c write (iout,*) "fric_work and fric_work1" c do i=1,dimen c write (iout,'(i5,2e15.5)') i,fric_work(i),fric_work1(i) c enddo do i=1,dimen do j=1,dimen ginvfric(i,j)=0.0d0 do k=1,dimen ginvfric(i,j)=ginvfric(i,j)+ginv(i,k)*fricmat(k,j) enddo enddo enddo write (iout,*) "ginvfric" do i=1,dimen write (iout,'(i5,100f8.3)') i,(ginvfric(i,j),j=1,dimen) enddo write (iout,*) "symmetry check" do i=1,dimen do j=1,i-1 write (iout,*) i,j,ginvfric(i,j)-ginvfric(j,i) enddo enddo endif return end c----------------------------------------------------- subroutine stochastic_force(stochforcvec) implicit real*8 (a-h,o-z) include 'DIMENSIONS' #ifdef MPI include 'mpif.h' #endif include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.MD' include 'COMMON.TIME1' #ifndef LANG0 include 'COMMON.LANGEVIN' #else include 'COMMON.LANGEVIN.lang0' #endif include 'COMMON.IOUNITS' double precision x,sig,lowb,highb, & ff(3),force(3,0:MAXRES2),zeta2,lowb2, & highb2,sig2,forcvec(MAXRES6),stochforcvec(MAXRES6) logical lprn /.false./ do i=0,MAXRES2 do j=1,3 stochforc(j,i)=0.0d0 enddo enddo x=0.0d0 #ifdef MPI time00=MPI_Wtime() #else time00=tcpu() #endif c Compute the stochastic forces acting on bodies. Store in force. do i=nnt,nct-1 sig=stdforcp(i) lowb=-5*sig highb=5*sig do j=1,3 force(j,i)=anorm_distr(x,sig,lowb,highb) enddo enddo do i=nnt,nct sig2=stdforcsc(i) lowb2=-5*sig2 highb2=5*sig2 do j=1,3 force(j,i+nres)=anorm_distr(x,sig2,lowb2,highb2) enddo enddo #ifdef MPI time_fsample=time_fsample+MPI_Wtime()-time00 #else time_fsample=time_fsample+tcpu()-time00 #endif c Compute the stochastic forces acting on virtual-bond vectors. do j=1,3 ff(j)=0.0d0 enddo do i=nct-1,nnt,-1 do j=1,3 stochforc(j,i)=ff(j)+0.5d0*force(j,i) enddo do j=1,3 ff(j)=ff(j)+force(j,i) enddo if (itype(i+1).ne.21) then do j=1,3 stochforc(j,i)=stochforc(j,i)+force(j,i+nres+1) ff(j)=ff(j)+force(j,i+nres+1) enddo endif enddo do j=1,3 stochforc(j,0)=ff(j)+force(j,nnt+nres) enddo do i=nnt,nct if (itype(i).ne.10) then do j=1,3 stochforc(j,i+nres)=force(j,i+nres) enddo endif enddo do j=1,3 stochforcvec(j)=stochforc(j,0) enddo ind=3 do i=nnt,nct-1 do j=1,3 stochforcvec(ind+j)=stochforc(j,i) enddo ind=ind+3 enddo do i=nnt,nct if (itype(i).ne.10) then do j=1,3 stochforcvec(ind+j)=stochforc(j,i+nres) enddo ind=ind+3 endif enddo if (lprn) then write (iout,*) "stochforcvec" do i=1,3*dimen write(iout,'(i5,e15.5)') i,stochforcvec(i) enddo write(iout,*) "Stochastic forces backbone" do i=0,nct-1 write(iout,'(i5,3e15.5)') i,(stochforc(j,i),j=1,3) enddo write(iout,*) "Stochastic forces side chain" do i=nnt,nct write(iout,'(i5,3e15.5)') & i,(stochforc(j,i+nres),j=1,3) enddo endif if (lprn) then ind=0 do i=nnt,nct-1 write (iout,*) i,ind do j=1,3 forcvec(ind+j)=force(j,i) enddo ind=ind+3 enddo do i=nnt,nct write (iout,*) i,ind do j=1,3 forcvec(j+ind)=force(j,i+nres) enddo ind=ind+3 enddo write (iout,*) "forcvec" ind=0 do i=nnt,nct-1 do j=1,3 write (iout,'(2i3,2f10.5)') i,j,force(j,i), & forcvec(ind+j) enddo ind=ind+3 enddo do i=nnt,nct do j=1,3 write (iout,'(2i3,2f10.5)') i,j,force(j,i+nres), & forcvec(ind+j) enddo ind=ind+3 enddo endif return end c------------------------------------------------------------------ subroutine setup_fricmat implicit real*8 (a-h,o-z) #ifdef MPI include 'mpif.h' #endif include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.MD' include 'COMMON.SETUP' include 'COMMON.TIME1' c integer licznik /0/ c save licznik #ifndef LANG0 include 'COMMON.LANGEVIN' #else include 'COMMON.LANGEVIN.lang0' #endif include 'COMMON.IOUNITS' integer IERROR integer i,j,ind,ind1,m logical lprn /.false./ double precision dtdi,gamvec(MAXRES2), & ginvfric(maxres2,maxres2),Ghalf(mmaxres2),fcopy(maxres2,maxres2) common /syfek/ gamvec double precision work(8*maxres2) integer iwork(maxres2) common /przechowalnia/ ginvfric,Ghalf,fcopy #ifdef MPI if (fg_rank.ne.king) goto 10 #endif c Zeroing out fricmat do i=1,dimen do j=1,dimen fricmat(i,j)=0.0d0 enddo enddo c Load the friction coefficients corresponding to peptide groups ind1=0 do i=nnt,nct-1 ind1=ind1+1 gamvec(ind1)=gamp enddo c Load the friction coefficients corresponding to side chains m=nct-nnt ind=0 do i=nnt,nct ind=ind+1 ii = ind+m iti=itype(i) gamvec(ii)=gamsc(iti) enddo if (surfarea) call sdarea(gamvec) c if (lprn) then c write (iout,*) "Matrix A and vector gamma" c do i=1,dimen1 c write (iout,'(i2,$)') i c do j=1,dimen c write (iout,'(f4.1,$)') A(i,j) c enddo c write (iout,'(f8.3)') gamvec(i) c enddo c endif if (lprn) then write (iout,*) "Vector gamvec" do i=1,dimen1 write (iout,'(i5,f10.5)') i, gamvec(i) enddo endif c The friction matrix do k=1,dimen do i=1,dimen dtdi=0.0d0 do j=1,dimen1 dtdi=dtdi+A(j,k)*A(j,i)*gamvec(j) enddo fricmat(k,i)=dtdi enddo enddo if (lprn) then write (iout,'(//a)') "Matrix fricmat" call matout2(dimen,dimen,maxres2,maxres2,fricmat) endif if (lang.eq.2 .or. lang.eq.3) then c Mass-scale the friction matrix if non-direct integration will be performed do i=1,dimen do j=1,dimen Ginvfric(i,j)=0.0d0 do k=1,dimen do l=1,dimen Ginvfric(i,j)=Ginvfric(i,j)+ & Gsqrm(i,k)*Gsqrm(l,j)*fricmat(k,l) enddo enddo enddo enddo c Diagonalize the friction matrix ind=0 do i=1,dimen do j=1,i ind=ind+1 Ghalf(ind)=Ginvfric(i,j) enddo enddo call gldiag(maxres2,dimen,dimen,Ghalf,work,fricgam,fricvec, & ierr,iwork) if (lprn) then write (iout,'(//2a)') "Eigenvectors and eigenvalues of the", & " mass-scaled friction matrix" call eigout(dimen,dimen,maxres2,maxres2,fricvec,fricgam) endif c Precompute matrices for tinker stochastic integrator #ifndef LANG0 do i=1,dimen do j=1,dimen mt1(i,j)=0.0d0 mt2(i,j)=0.0d0 do k=1,dimen mt1(i,j)=mt1(i,j)+fricvec(k,i)*gsqrm(k,j) mt2(i,j)=mt2(i,j)+fricvec(k,i)*gsqrp(k,j) enddo mt3(j,i)=mt1(i,j) enddo enddo #endif else if (lang.eq.4) then c Diagonalize the friction matrix ind=0 do i=1,dimen do j=1,i ind=ind+1 Ghalf(ind)=fricmat(i,j) enddo enddo call gldiag(maxres2,dimen,dimen,Ghalf,work,fricgam,fricvec, & ierr,iwork) if (lprn) then write (iout,'(//2a)') "Eigenvectors and eigenvalues of the", & " friction matrix" call eigout(dimen,dimen,maxres2,maxres2,fricvec,fricgam) endif c Determine the number of zero eigenvalues of the friction matrix nzero=max0(dimen-dimen1,0) c do while (fricgam(nzero+1).le.1.0d-5 .and. nzero.lt.dimen) c nzero=nzero+1 c enddo write (iout,*) "Number of zero eigenvalues:",nzero do i=1,dimen do j=1,dimen fricmat(i,j)=0.0d0 do k=nzero+1,dimen fricmat(i,j)=fricmat(i,j) & +fricvec(i,k)*fricvec(j,k)/fricgam(k) enddo enddo enddo if (lprn) then write (iout,'(//a)') "Generalized inverse of fricmat" call matout(dimen,dimen,maxres6,maxres6,fricmat) endif endif #ifdef MPI 10 continue if (nfgtasks.gt.1) then if (fg_rank.eq.0) then c The matching BROADCAST for fg processors is called in ERGASTULUM #ifdef MPI time00=MPI_Wtime() #else time00=tcpu() #endif call MPI_Bcast(10,1,MPI_INTEGER,king,FG_COMM,IERROR) #ifdef MPI time_Bcast=time_Bcast+MPI_Wtime()-time00 #else time_Bcast=time_Bcast+tcpu()-time00 #endif c print *,"Processor",myrank, c & " BROADCAST iorder in SETUP_FRICMAT" endif c licznik=licznik+1 c write (iout,*) "setup_fricmat licznik",licznik #ifdef MPI time00=MPI_Wtime() #else time00=tcpu() #endif c Scatter the friction matrix call MPI_Scatterv(fricmat(1,1),nginv_counts(0), & nginv_start(0),MPI_DOUBLE_PRECISION,fcopy(1,1), & myginv_ng_count,MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) #ifdef TIMING #ifdef MPI time_scatter=time_scatter+MPI_Wtime()-time00 time_scatter_fmat=time_scatter_fmat+MPI_Wtime()-time00 #else time_scatter=time_scatter+tcpu()-time00 time_scatter_fmat=time_scatter_fmat+tcpu()-time00 #endif #endif do i=1,dimen do j=1,2*my_ng_count fricmat(j,i)=fcopy(i,j) enddo enddo c write (iout,*) "My chunk of fricmat" c call MATOUT2(my_ng_count,dimen,maxres2,maxres2,fcopy) endif #endif return end c------------------------------------------------------------------------------- subroutine sdarea(gamvec) c c Scale the friction coefficients according to solvent accessible surface areas c Code adapted from TINKER c AL 9/3/04 c implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' #ifndef LANG0 include 'COMMON.LANGEVIN' #else include 'COMMON.LANGEVIN.lang0' #endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.NAMES' double precision radius(maxres2),gamvec(maxres2) parameter (twosix=1.122462048309372981d0) logical lprn /.false./ c c determine new friction coefficients every few SD steps c c set the atomic radii to estimates of sigma values c c print *,"Entered sdarea" probe = 0.0d0 do i=1,2*nres radius(i)=0.0d0 enddo c Load peptide group radii do i=nnt,nct-1 radius(i)=pstok enddo c Load side chain radii do i=nnt,nct iti=itype(i) radius(i+nres)=restok(iti) enddo c do i=1,2*nres c write (iout,*) "i",i," radius",radius(i) c enddo do i = 1, 2*nres radius(i) = radius(i) / twosix if (radius(i) .ne. 0.0d0) radius(i) = radius(i) + probe end do c c scale atomic friction coefficients by accessible area c if (lprn) write (iout,*) & "Original gammas, surface areas, scaling factors, new gammas, ", & "std's of stochastic forces" ind=0 do i=nnt,nct-1 if (radius(i).gt.0.0d0) then call surfatom (i,area,radius) ratio = dmax1(area/(4.0d0*pi*radius(i)**2),1.0d-1) if (lprn) write (iout,'(i5,3f10.5,$)') & i,gamvec(ind+1),area,ratio do j=1,3 ind=ind+1 gamvec(ind) = ratio * gamvec(ind) enddo stdforcp(i)=stdfp*dsqrt(gamvec(ind)) if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcp(i) endif enddo do i=nnt,nct if (radius(i+nres).gt.0.0d0) then call surfatom (i+nres,area,radius) ratio = dmax1(area/(4.0d0*pi*radius(i+nres)**2),1.0d-1) if (lprn) write (iout,'(i5,3f10.5,$)') & i,gamvec(ind+1),area,ratio do j=1,3 ind=ind+1 gamvec(ind) = ratio * gamvec(ind) enddo stdforcsc(i)=stdfsc(itype(i))*dsqrt(gamvec(ind)) if (lprn) write (iout,'(2f10.5)') gamvec(ind),stdforcsc(i) endif enddo return end