From: Cezary Czaplewski Date: Tue, 24 Mar 2020 01:45:14 +0000 (+0100) Subject: make cp src-HCD-5D X-Git-Url: http://mmka.chem.univ.gda.pl/gitweb/?p=unres.git;a=commitdiff_plain;h=a30bd29e64da2aa47b84963fdd0bf4192ead2738 make cp src-HCD-5D --- diff --git a/source/cluster/wham/src-HCD-5D/energy_p_new.F b/source/cluster/wham/src-HCD-5D/energy_p_new.F index f599f70..c2d7f85 100644 --- a/source/cluster/wham/src-HCD-5D/energy_p_new.F +++ b/source/cluster/wham/src-HCD-5D/energy_p_new.F @@ -130,8 +130,10 @@ C if (wliptran.gt.0) then call Eliptransfer(eliptran) + else + eliptran=0.0d0 endif - +#ifdef FOURBODY C C 12/1/95 Multi-body terms C @@ -153,6 +155,7 @@ c write (iout,*) ecorr,ecorr5,ecorr6,eturn6 c write (iout,*) "Calling multibody_hbond" call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) endif +#endif c write (iout,*) "NSAXS",nsaxs if (nsaxs.gt.0 .and. saxs_mode.eq.0) then call e_saxs(Esaxs_constr) @@ -189,8 +192,10 @@ c write(iout,*)'edfab is finished!', wdfa_beta,edfabet & +welec*fact(1)*ees & +fact(1)*wvdwpp*evdw1 & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc - & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 - & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 + & +wstrain*ehpb + & +wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 + & +wcorr6*fact(5)*ecorr6 + & +wturn4*fact(3)*eello_turn4 & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr @@ -505,10 +510,17 @@ C Bartek #ifdef SPLITELE write(iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,wvdwpp, & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1), - & etors_d,wtor_d*fact(2),ehpb,wstrain,ecorr,wcorr*fact(3), - & ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),eel_loc, + & etors_d,wtor_d*fact(2),ehpb,wstrain, +#ifdef FOURBODY + & ecorr,wcorr*fact(3), + & ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), +#endif + & eel_loc, & wel_loc*fact(2),eello_turn3,wturn3*fact(2), - & eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5), + & eello_turn4,wturn4*fact(3), +#ifdef FOURBODY + & eello_turn6,wturn6*fact(5), +#endif & esccor,wsccor*fact(1),edihcnstr, & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, & etube,wtube,esaxs,wsaxs,ehomology_constr, @@ -527,13 +539,17 @@ C Bartek & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, & ' (SS bridges & dist. cnstr.)'/ +#ifdef FOURBODY & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ @@ -553,10 +569,16 @@ C Bartek #else write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1), & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1), - & etors_d,wtor_d*fact(2),ehpb,wstrain,ecorr,wcorr*fact(3), + & etors_d,wtor_d*fact(2),ehpb, +#ifdef FOURBODY + & wstrain,ecorr,wcorr*fact(3), & ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), +#endif & eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2), - & eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5), + & eello_turn4,wturn4*fact(3), +#ifdef FOURBODY + & eello_turn6,wturn6*fact(5), +#endif & esccor,wsccor*fact(1),edihcnstr, & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, & etube,wtube,esaxs,wsaxs,ehomology_constr, @@ -574,13 +596,17 @@ C Bartek & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, & ' (SS bridges & dist. restr.)'/ +#ifdef FOURBODY & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ @@ -619,7 +645,10 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif dimension gg(3) integer icant external icant @@ -658,6 +687,10 @@ cd & 'iend=',iend(i,iint) C Change 12/1/95 to calculate four-body interactions rij=xj*xj+yj*yj+zj*zj rrij=1.0D0/rij + sqrij=dsqrt(rij) + sss1=sscale(sqrij) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(sqrij) c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj eps0ij=eps(itypi,itypj) fac=rrij**expon2 @@ -677,15 +710,16 @@ cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, cd & (c(k,i),k=1,3),(c(k,j),k=1,3) if (bb.gt.0.0d0) then - evdw=evdw+evdwij + evdw=evdw+sss1*evdwij else - evdw_t=evdw_t+evdwij + evdw_t=evdw_t+sss1*evdwij endif if (calc_grad) then C C Calculate the components of the gradient in DC and X C - fac=-rrij*(e1+evdwij) + fac=-rrij*(e1+evdwij)*sss1 + & +evdwij*sssgrad1/sqrij/expon gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -699,6 +733,7 @@ C enddo enddo endif +#ifdef FOURBODY C C 12/1/95, revised on 5/20/97 C @@ -755,10 +790,13 @@ cd write (iout,'(2i3,3f10.5)') cd & i,j,(gacont(kk,num_conti,i),kk=1,3) endif endif +#endif enddo ! j enddo ! iint +#ifdef FOURBODY C Change 12/1/95 num_cont(i)=num_conti +#endif enddo ! i if (calc_grad) then do i=1,nct @@ -830,6 +868,9 @@ C e_augm=augm(itypi,itypj)*fac_augm r_inv_ij=dsqrt(rrij) rij=1.0D0/r_inv_ij + sss1=sscale(rij) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(rij) r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) fac=r_shift_inv**expon e1=fac*fac*aa @@ -847,15 +888,16 @@ cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, cd & (c(k,i),k=1,3),(c(k,j),k=1,3) if (bb.gt.0.0d0) then - evdw=evdw+evdwij + evdw=evdw+evdwij*sss1 else - evdw_t=evdw_t+evdwij + evdw_t=evdw_t+evdwij*sss1 endif if (calc_grad) then C C Calculate the components of the gradient in DC and X C - fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) + fac=(-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2))*sss1 + & +evdwij*sssgrad1*r_inv_ij/expon gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -1230,8 +1272,8 @@ C finding the closest c write (iout,*) i,j,xj,yj,zj rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) - sss=sscale((1.0d0/rij)/sigma(itypi,itypj)) - sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj)) + sss=sscale(1.0d0/rij)) + sssgrad=sscagrad(1.0d0/rij) if (sss.le.0.0) cycle C Calculate angle-dependent terms of energy and contributions to their C derivatives. @@ -1387,6 +1429,9 @@ c alf12=0.0D0 dzj=dc_norm(3,nres+j) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) + sss=sscale(1.0d0/rij) + if (sss.eq.0.0d0) cycle + sssgrad=sscagrad(1.0d0/rij) C Calculate angle-dependent terms of energy and contributions to their C derivatives. call sc_angular @@ -1411,9 +1456,9 @@ c--------------------------------------------------------------- e_augm=augm(itypi,itypj)*fac_augm evdwij=evdwij*eps2rt*eps3rt if (bb.gt.0.0d0) then - evdw=evdw+evdwij+e_augm + evdw=evdw+(evdwij+e_augm)*sss else - evdw_t=evdw_t+evdwij+e_augm + evdw_t=evdw_t+(evdwij+e_augm)*sss endif ij=icant(itypi,itypj) aux=eps1*eps2rt**2*eps3rt**2 @@ -1439,6 +1484,7 @@ C Calculate gradient components. fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac-2*expon*rrij*e_augm + fac=fac+(evdwij+e_augm)*sssgrad/sss*rij C Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac @@ -1717,6 +1763,7 @@ C-------------------------------------------------------------------------- include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' + include 'COMMON.CORRMAT' double precision auxvec(2),auxmat(2,2) C C Compute the virtual-bond-torsional-angle dependent quantities needed @@ -1943,6 +1990,7 @@ c & EE(1,2,iti),EE(2,2,i) c write(iout,*) "Macierz EUG", c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2), c & eug(2,2,i-2) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) & then call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2)) @@ -1951,6 +1999,7 @@ c & eug(2,2,i-2) call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2)) call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2)) endif +#endif else do k=1,2 Ub2(k,i-2)=0.0d0 @@ -1992,6 +2041,7 @@ c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then #endif cd write (iout,*) 'mu1',mu1(:,i-2) cd write (iout,*) 'mu2',mu2(:,i-2) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) & then if (calc_grad) then @@ -2014,7 +2064,9 @@ C Vectors and matrices dependent on a single virtual-bond dihedral. call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2)) endif endif +#endif enddo +#ifdef FOURBODY C Matrices dependent on two consecutive virtual-bond dihedrals. C The order of matrices is from left to right. if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) @@ -2032,6 +2084,7 @@ C The order of matrices is from left to right. call transpose2(DtUg2der(1,1,i-1),auxmat(1,1)) call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i)) endif +#endif enddo endif return @@ -2058,7 +2111,11 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAP' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -2131,9 +2188,11 @@ cd enddo eello_turn3=0.0d0 eello_turn4=0.0d0 ind=0 +#ifdef FOURBODY do i=1,nres num_cont_hb(i)=0 enddo +#endif cd print '(a)','Enter EELEC' c write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e c call flush(iout) @@ -2185,7 +2244,9 @@ c end if num_conti=0 call eelecij(i,i+2,ees,evdw1,eel_loc) if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo do i=iturn4_start,iturn4_end if (i.lt.1) cycle @@ -2241,12 +2302,16 @@ c endif zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif c write(iout,*) "JESTEM W PETLI" call eelecij(i,i+3,ees,evdw1,eel_loc) if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) & call eturn4(i,eello_turn4) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i C Loop over all neighbouring boxes C do xshift=-1,1 @@ -2313,7 +2378,9 @@ c go to 166 c endif c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif C I TU KURWA do j=ielstart(i),ielend(i) C do j=16,17 @@ -2329,7 +2396,9 @@ c & .or.itype(j-1).eq.ntyp1 &) cycle call eelecij(i,j,ees,evdw1,eel_loc) enddo ! j +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i C enddo ! zshift C enddo ! yshift @@ -2360,7 +2429,11 @@ C------------------------------------------------------------------------------- include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAP' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -2478,8 +2551,9 @@ C yj=yj-ymedi C zj=zj-zmedi rij=xj*xj+yj*yj+zj*zj - sss=sscale(sqrt(rij)) - sssgrad=sscagrad(sqrt(rij)) + sss=sscale(sqrt(rij)) + if (sss.eq.0.0d0) return + sssgrad=sscagrad(sqrt(rij)) c write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut, c & " rlamb",rlamb," sss",sss c if (sss.gt.0.0d0) then @@ -2647,9 +2721,10 @@ cgrad gelc(l,k)=gelc(l,k)+ggg(l) cgrad enddo cgrad enddo if (sss.gt.0.0) then - ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj - ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj - ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj + facvdw=facvdw+sssgrad*rmij*evdwij + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj else ggg(1)=0.0 ggg(2)=0.0 @@ -2676,10 +2751,11 @@ cgrad enddo endif ! calc_grad #else C MARYSIA - facvdw=(ev1+evdwij)*sss + facvdw=(ev1+evdwij) facel=(el1+eesij) fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) + fac=-3*rrmij*(facvdw+facvdw+facel)*sss + & +(evdwij+eesij)*sssgrad*rrmij erij(1)=xj*rmij erij(2)=yj*rmij erij(3)=zj*rmij @@ -3002,7 +3078,7 @@ c if (eel_loc_ij.ne.0) c & write (iout,'(a4,2i4,8f9.5)')'chuj', c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4) - eel_loc=eel_loc+eel_loc_ij + eel_loc=eel_loc+eel_loc_ij*sss C Now derivative over eel_loc if (calc_grad) then if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. @@ -3059,7 +3135,7 @@ C Calculate patrial derivative for theta angle & +a23*gmuij1(2) & +a32*gmuij1(3) & +a33*gmuij1(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss c write(iout,*) "derivative over thatai" c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3), c & a33*gmuij1(4) @@ -3075,7 +3151,7 @@ c & a33*gmuij2(4) & +a33*gmuij2(4) gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ & geel_loc_ij*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss c Derivative over j residue geel_loc_ji=a22*gmuji1(1) @@ -3100,7 +3176,7 @@ c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3), c & a33*gmuji2(4) gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+ & geel_loc_ji*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss #endif cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij @@ -3116,10 +3192,14 @@ C Partial derivatives in virtual-bond dihedral angles gamma & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) & *fac_shield(i)*fac_shield(j) C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) + aux=eel_loc_ij/sss*sssgrad*rmij + ggg(1)=aux*xj + ggg(2)=aux*yj + ggg(3)=aux*zj do l=1,3 - ggg(l)=(agg(l,1)*muij(1)+ + ggg(l)=ggg(l)+(agg(l,1)*muij(1)+ & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) cgrad ghalf=0.5d0*ggg(l) @@ -3156,6 +3236,7 @@ C Remaining derivatives of eello C Change 12/26/95 to calculate four-body contributions to H-bonding energy c if (j.gt.i+1 .and. num_conti.le.maxconts) then +#ifdef FOURBODY if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 & .and. num_conti.le.maxconts) then c write (iout,*) i,j," entered corr" @@ -3295,11 +3376,17 @@ cd fprimcont=0.0D0 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) enddo gggp(1)=gggp(1)+ees0pijp*xj + & +ees0p(num_conti,i)/sss*rmij*xj*sssgrad gggp(2)=gggp(2)+ees0pijp*yj + & +ees0p(num_conti,i)/sss*rmij*yj*sssgrad gggp(3)=gggp(3)+ees0pijp*zj + & +ees0p(num_conti,i)/sss*rmij*zj*sssgrad gggm(1)=gggm(1)+ees0mijp*xj + & +ees0m(num_conti,i)/sss*rmij*xj*sssgrad gggm(2)=gggm(2)+ees0mijp*yj + & +ees0m(num_conti,i)/sss*rmij*yj*sssgrad gggm(3)=gggm(3)+ees0mijp*zj + & +ees0m(num_conti,i)/sss*rmij*zj*sssgrad C Derivatives due to the contact function gacont_hbr(1,num_conti,i)=fprimcont*xj gacont_hbr(2,num_conti,i)=fprimcont*yj @@ -3314,29 +3401,29 @@ cgrad ghalfm=0.5D0*gggm(k) gacontp_hb1(k,num_conti,i)=!ghalfp & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontp_hb2(k,num_conti,i)=!ghalfp & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontp_hb3(k,num_conti,i)=gggp(k) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontm_hb1(k,num_conti,i)=!ghalfm & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontm_hb2(k,num_conti,i)=!ghalfm & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontm_hb3(k,num_conti,i)=gggm(k) & *fac_shield(i)*fac_shield(j) - +*sss enddo C Diagnostics. Comment out or remove after debugging! cdiag do k=1,3 @@ -3354,6 +3441,7 @@ cdiag enddo endif ! num_conti.le.maxconts endif ! fcont.gt.0 endif ! j.gt.i+1 +#endif if (calc_grad) then if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then do k=1,4 @@ -6270,6 +6358,7 @@ c gsccor_loc(i-3)=gloci enddo return end +#ifdef FOURBODY c------------------------------------------------------------------------------ subroutine multibody(ecorr) C This subroutine calculates multi-body contributions to energy following @@ -6282,6 +6371,8 @@ C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision gx(3),gx1(3) logical lprn @@ -6336,6 +6427,8 @@ c------------------------------------------------------------------------------ include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision gx(3),gx1(3) logical lprn lprn=.false. @@ -6377,6 +6470,8 @@ C This subroutine calculates multi-body contributions to hydrogen-bonding include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision gx(3),gx1(3) logical lprn,ldone @@ -6449,6 +6544,8 @@ C This subroutine calculates multi-body contributions to hydrogen-bonding include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.CHAIN' include 'COMMON.CONTROL' include 'COMMON.SHIELD' @@ -6605,6 +6702,8 @@ c------------------------------------------------------------------------------ include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.SHIELD' include 'COMMON.CONTROL' double precision gx(3),gx1(3) @@ -6780,6 +6879,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -6845,6 +6946,8 @@ C include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -7223,6 +7326,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -7337,6 +7442,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -7753,6 +7860,8 @@ c-------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -7895,6 +8004,8 @@ c-------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -8001,6 +8112,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -8188,6 +8301,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -8305,6 +8420,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -8551,6 +8668,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -8871,7 +8990,7 @@ cd write (2,*) 'ekont',ekont cd write (2,*) 'eel_turn6',ekont*eel_turn6 return end - +#endif crc------------------------------------------------- CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC subroutine Eliptransfer(eliptran) diff --git a/source/cluster/wham/src-HCD-5D/energy_p_new.F.safe b/source/cluster/wham/src-HCD-5D/energy_p_new.F.safe deleted file mode 100644 index a71e55b..0000000 --- a/source/cluster/wham/src-HCD-5D/energy_p_new.F.safe +++ /dev/null @@ -1,9056 +0,0 @@ - subroutine etotal(energia,fact) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - -#ifndef ISNAN - external proc_proc -#endif -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif - - include 'COMMON.IOUNITS' - double precision energia(0:max_ene),energia1(0:max_ene+1) -#ifdef MPL - include 'COMMON.INFO' - external d_vadd - integer ready -#endif - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.SHIELD' - include 'COMMON.CONTROL' - double precision fact(6) -cd write(iout, '(a,i2)')'Calling etotal ipot=',ipot -cd print *,'nnt=',nnt,' nct=',nct -C -C Compute the side-chain and electrostatic interaction energy -C - goto (101,102,103,104,105) ipot -C Lennard-Jones potential. - 101 call elj(evdw,evdw_t) -cd print '(a)','Exit ELJ' - goto 106 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk(evdw,evdw_t) - goto 106 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp(evdw,evdw_t) - goto 106 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb(evdw,evdw_t) - goto 106 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv(evdw,evdw_t) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 106 continue -C write(iout,*) "shield_mode",shield_mode,ethetacnstr - if (shield_mode.eq.1) then - call set_shield_fac - else if (shield_mode.eq.2) then - call set_shield_fac2 - endif - call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) -C -C Calculate excluded-volume interaction energy between peptide groups -C and side chains. -C - call escp(evdw2,evdw2_14) -c -c Calculate the bond-stretching energy -c - call ebond(estr) -c write (iout,*) "estr",estr -C -C Calculate the disulfide-bridge and other energy and the contributions -C from other distance constraints. -cd print *,'Calling EHPB' - call edis(ehpb) -cd print *,'EHPB exitted succesfully.' -C -C Calculate the virtual-bond-angle energy. -C - call ebend(ebe,ethetacnstr) -cd print *,'Bend energy finished.' -C -C Calculate the SC local energy. -C - call esc(escloc) -cd print *,'SCLOC energy finished.' -C -C Calculate the virtual-bond torsional energy. -C -cd print *,'nterm=',nterm - call etor(etors,edihcnstr,fact(1)) -C -C 6/23/01 Calculate double-torsional energy -C - call etor_d(etors_d,fact(2)) -C -C 21/5/07 Calculate local sicdechain correlation energy -C - call eback_sc_corr(esccor) - - if (wliptran.gt.0) then - call Eliptransfer(eliptran) - endif - -C -C 12/1/95 Multi-body terms -C - n_corr=0 - n_corr1=0 - if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 - & .or. wturn6.gt.0.0d0) then -c print *,"calling multibody_eello" - call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) -c write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1 -c print *,ecorr,ecorr5,ecorr6,eturn6 - else - ecorr=0.0d0 - ecorr5=0.0d0 - ecorr6=0.0d0 - eturn6=0.0d0 - endif - if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) - endif - write (iout,*) "ft(6)",fact(6),wliptran,eliptran -#ifdef SPLITELE - if (shield_mode.gt.0) then - etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2 - & +welec*fact(1)*ees - & +fact(1)*wvdwpp*evdw1 - & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc - & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 - & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 - & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 - & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d - & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr - & +wliptran*eliptran - else - etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees - & +wvdwpp*evdw1 - & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc - & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 - & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 - & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 - & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d - & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr - & +wliptran*eliptran - endif -#else - if (shield_mode.gt.0) then - etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2 - & +welec*fact(1)*(ees+evdw1) - & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc - & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 - & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 - & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 - & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d - & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr - & +wliptran*eliptran - else - etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2 - & +welec*fact(1)*(ees+evdw1) - & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc - & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5 - & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4 - & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6 - & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d - & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr - & +wliptran*eliptran - endif -#endif - - energia(0)=etot - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(17)=evdw2_14 -#else - energia(2)=evdw2 - energia(17)=0.0d0 -#endif -#ifdef SPLITELE - energia(3)=ees - energia(16)=evdw1 -#else - energia(3)=ees+evdw1 - energia(16)=0.0d0 -#endif - energia(4)=ecorr - energia(5)=ecorr5 - energia(6)=ecorr6 - energia(7)=eel_loc - energia(8)=eello_turn3 - energia(9)=eello_turn4 - energia(10)=eturn6 - energia(11)=ebe - energia(12)=escloc - energia(13)=etors - energia(14)=etors_d - energia(15)=ehpb - energia(18)=estr - energia(19)=esccor - energia(20)=edihcnstr - energia(21)=evdw_t - energia(24)=ethetacnstr - energia(22)=eliptran -c detecting NaNQ -#ifdef ISNAN -#ifdef AIX - if (isnan(etot).ne.0) energia(0)=1.0d+99 -#else - if (isnan(etot)) energia(0)=1.0d+99 -#endif -#else - i=0 -#ifdef WINPGI - idumm=proc_proc(etot,i) -#else - call proc_proc(etot,i) -#endif - if(i.eq.1)energia(0)=1.0d+99 -#endif -#ifdef MPL -c endif -#endif - if (calc_grad) then -C -C Sum up the components of the Cartesian gradient. -C -#ifdef SPLITELE - do i=1,nct - do j=1,3 - if (shield_mode.eq.0) then - gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ - & welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+ - & wbond*gradb(j,i)+ - & wstrain*ghpbc(j,i)+ - & wcorr*fact(3)*gradcorr(j,i)+ - & wel_loc*fact(2)*gel_loc(j,i)+ - & wturn3*fact(2)*gcorr3_turn(j,i)+ - & wturn4*fact(3)*gcorr4_turn(j,i)+ - & wcorr5*fact(4)*gradcorr5(j,i)+ - & wcorr6*fact(5)*gradcorr6(j,i)+ - & wturn6*fact(5)*gcorr6_turn(j,i)+ - & wsccor*fact(2)*gsccorc(j,i) - & +wliptran*gliptranc(j,i) - gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*fact(2)*gsccorx(j,i) - & +wliptran*gliptranx(j,i) - else - gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i) - & +fact(1)*wscp*gvdwc_scp(j,i)+ - & welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+ - & wbond*gradb(j,i)+ - & wstrain*ghpbc(j,i)+ - & wcorr*fact(3)*gradcorr(j,i)+ - & wel_loc*fact(2)*gel_loc(j,i)+ - & wturn3*fact(2)*gcorr3_turn(j,i)+ - & wturn4*fact(3)*gcorr4_turn(j,i)+ - & wcorr5*fact(4)*gradcorr5(j,i)+ - & wcorr6*fact(5)*gradcorr6(j,i)+ - & wturn6*fact(5)*gcorr6_turn(j,i)+ - & wsccor*fact(2)*gsccorc(j,i) - & +wliptran*gliptranc(j,i) - & +welec*gshieldc(j,i) - & +welec*gshieldc_loc(j,i) - & +wcorr*gshieldc_ec(j,i) - & +wcorr*gshieldc_loc_ec(j,i) - & +wturn3*gshieldc_t3(j,i) - & +wturn3*gshieldc_loc_t3(j,i) - & +wturn4*gshieldc_t4(j,i) - & +wturn4*gshieldc_loc_t4(j,i) - & +wel_loc*gshieldc_ll(j,i) - & +wel_loc*gshieldc_loc_ll(j,i) - - gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i) - & +fact(1)*wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*fact(2)*gsccorx(j,i) - & +wliptran*gliptranx(j,i) - & +welec*gshieldx(j,i) - & +wcorr*gshieldx_ec(j,i) - & +wturn3*gshieldx_t3(j,i) - & +wturn4*gshieldx_t4(j,i) - & +wel_loc*gshieldx_ll(j,i) - - - endif - enddo -#else - do i=1,nct - do j=1,3 - if (shield_mode.eq.0) then - gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+ - & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+ - & wbond*gradb(j,i)+ - & wcorr*fact(3)*gradcorr(j,i)+ - & wel_loc*fact(2)*gel_loc(j,i)+ - & wturn3*fact(2)*gcorr3_turn(j,i)+ - & wturn4*fact(3)*gcorr4_turn(j,i)+ - & wcorr5*fact(4)*gradcorr5(j,i)+ - & wcorr6*fact(5)*gradcorr6(j,i)+ - & wturn6*fact(5)*gcorr6_turn(j,i)+ - & wsccor*fact(2)*gsccorc(j,i) - & +wliptran*gliptranc(j,i) - gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*fact(1)*gsccorx(j,i) - & +wliptran*gliptranx(j,i) - else - gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+ - & fact(1)*wscp*gvdwc_scp(j,i)+ - & welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+ - & wbond*gradb(j,i)+ - & wcorr*fact(3)*gradcorr(j,i)+ - & wel_loc*fact(2)*gel_loc(j,i)+ - & wturn3*fact(2)*gcorr3_turn(j,i)+ - & wturn4*fact(3)*gcorr4_turn(j,i)+ - & wcorr5*fact(4)*gradcorr5(j,i)+ - & wcorr6*fact(5)*gradcorr6(j,i)+ - & wturn6*fact(5)*gcorr6_turn(j,i)+ - & wsccor*fact(2)*gsccorc(j,i) - & +wliptran*gliptranc(j,i) - gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+ - & fact(1)*wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*fact(1)*gsccorx(j,i) - & +wliptran*gliptranx(j,i) - endif - enddo -#endif - enddo - - - do i=1,nres-3 - gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i) - & +wcorr5*fact(4)*g_corr5_loc(i) - & +wcorr6*fact(5)*g_corr6_loc(i) - & +wturn4*fact(3)*gel_loc_turn4(i) - & +wturn3*fact(2)*gel_loc_turn3(i) - & +wturn6*fact(5)*gel_loc_turn6(i) - & +wel_loc*fact(2)*gel_loc_loc(i) -c & +wsccor*fact(1)*gsccor_loc(i) -c ROZNICA Z WHAMem - enddo - endif - if (dyn_ss) call dyn_set_nss - return - end -C------------------------------------------------------------------------ - subroutine enerprint(energia,fact) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - double precision energia(0:max_ene),fact(6) - etot=energia(0) - evdw=energia(1)+fact(6)*energia(21) -#ifdef SCP14 - evdw2=energia(2)+energia(17) -#else - evdw2=energia(2) -#endif - ees=energia(3) -#ifdef SPLITELE - evdw1=energia(16) -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eello_turn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - esccor=energia(19) - edihcnstr=energia(20) - estr=energia(18) - ethetacnstr=energia(24) -#ifdef SPLITELE - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1, - & wvdwpp, - & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1), - & etors_d,wtor_d*fact(2),ehpb,wstrain, - & ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), - & eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2), - & eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5), - & esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/ - & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#else - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond, - & ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2, - & ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4), - & ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2), - & eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3), - & eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor, - & edihcnstr,ethetacnstr,ebr*nss,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#endif - return - end -C----------------------------------------------------------------------- - subroutine elj(evdw,evdw_t) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJ potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include "DIMENSIONS.COMPAR" - parameter (accur=1.0d-10) - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.TORSION' - include 'COMMON.SBRIDGE' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) - integer icant - external icant -cd print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon -c ROZNICA DODANE Z WHAM -c do i=1,210 -c do j=1,2 -c eneps_temp(j,i)=0.0d0 -c enddo -c enddo -cROZNICA - - evdw=0.0D0 - evdw_t=0.0d0 - do i=iatsc_s,iatsc_e - itypi=iabs(itype(i)) - if (itypi.eq.ntyp1) cycle - itypi1=iabs(itype(i+1)) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C Change 12/1/95 - num_conti=0 -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) -cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), -cd & 'iend=',iend(i,iint) - do j=istart(i,iint),iend(i,iint) - itypj=iabs(itype(j)) - if (itypj.eq.ntyp1) cycle - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi -C Change 12/1/95 to calculate four-body interactions - rij=xj*xj+yj*yj+zj*zj - rrij=1.0D0/rij -c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa - e2=fac*bb - evdwij=e1+e2 - ij=icant(itypi,itypj) -c ROZNICA z WHAM -c eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij) -c eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij -c - -cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - if (bb.gt.0.0d0) then - evdw=evdw+evdwij - else - evdw_t=evdw_t+evdwij - endif - if (calc_grad) then -C -C Calculate the components of the gradient in DC and X -C - fac=-rrij*(e1+evdwij) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - enddo - do k=i,j-1 - do l=1,3 - gvdwc(l,k)=gvdwc(l,k)+gg(l) - enddo - enddo - endif -C -C 12/1/95, revised on 5/20/97 -C -C Calculate the contact function. The ith column of the array JCONT will -C contain the numbers of atoms that make contacts with the atom I (of numbers -C greater than I). The arrays FACONT and GACONT will contain the values of -C the contact function and its derivative. -C -C Uncomment next line, if the correlation interactions include EVDW explicitly. -c if (j.gt.i+1 .and. evdwij.le.0.0D0) then -C Uncomment next line, if the correlation interactions are contact function only - if (j.gt.i+1.and. eps0ij.gt.0.0D0) then - rij=dsqrt(rij) - sigij=sigma(itypi,itypj) - r0ij=rs0(itypi,itypj) -C -C Check whether the SC's are not too far to make a contact. -C - rcut=1.5d0*r0ij - call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) -C Add a new contact, if the SC's are close enough, but not too close (ri' - do k=1,3 - ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) - enddo - endif - do k=1,3 - gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) - enddo - kstart=min0(i+1,j) - kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) - do k=kstart,kend - do l=1,3 - gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) - enddo - enddo - endif - enddo - enddo ! iint - 1225 continue - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time the factor EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C-------------------------------------------------------------------------- - subroutine edis(ehpb) -C -C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.CONTROL' - dimension ggg(3) - ehpb=0.0D0 -cd print *,'edis: nhpb=',nhpb,' fbr=',fbr -cd print *,'link_start=',link_start,' link_end=',link_end - if (link_end.eq.0) return - do i=link_start,link_end -C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a -C CA-CA distance used in regularization of structure. - ii=ihpb(i) - jj=jhpb(i) -C iii and jjj point to the residues for which the distance is assigned. - if (ii.gt.nres) then - iii=ii-nres - jjj=jj-nres - else - iii=ii - jjj=jj - endif -C 24/11/03 AL: SS bridges handled separately because of introducing a specific -C distance and angle dependent SS bond potential. -C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. -C & iabs(itype(jjj)).eq.1) then -C call ssbond_ene(iii,jjj,eij) -C ehpb=ehpb+2*eij -C else - if (.not.dyn_ss .and. i.le.nss) then - if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and. - & iabs(itype(jjj)).eq.1) then - call ssbond_ene(iii,jjj,eij) - ehpb=ehpb+2*eij - endif !ii.gt.neres - else if (ii.gt.nres .and. jj.gt.nres) then -c Restraints from contact prediction - dd=dist(ii,jj) - if (constr_dist.eq.11) then -C ehpb=ehpb+fordepth(i)**4.0d0 -C & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) - ehpb=ehpb+fordepth(i)**4.0d0 - & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) - fac=fordepth(i)**4.0d0 - & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd -C write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, -C & ehpb,fordepth(i),dd -C print *,"TUTU" -C write(iout,*) ehpb,"atu?" -C ehpb,"tu?" -C fac=fordepth(i)**4.0d0 -C & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd - else !constr_dist.eq.11 - if (dhpb1(i).gt.0.0d0) then - ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd -c write (iout,*) "beta nmr", -c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - else !dhpb(i).gt.0.00 - -C Calculate the distance between the two points and its difference from the -C target distance. - dd=dist(ii,jj) - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd - endif !dhpb(i).gt.0 - endif -cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, -cd & ' waga=',waga,' fac=',fac - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo -cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) -C If this is a SC-SC distance, we need to calculate the contributions to the -C Cartesian gradient in the SC vectors (ghpbx). - if (iii.lt.ii) then - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - endif - else !ii.gt.nres -C write(iout,*) "before" - dd=dist(ii,jj) -C write(iout,*) "after",dd - if (constr_dist.eq.11) then - ehpb=ehpb+fordepth(i)**4.0d0 - & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)) - fac=fordepth(i)**4.0d0 - & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd -C ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i)) -C fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd -C print *,ehpb,"tu?" -C write(iout,*) ehpb,"btu?", -C & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i) -C write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, -C & ehpb,fordepth(i),dd - else - if (dhpb1(i).gt.0.0d0) then - ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd -c write (iout,*) "alph nmr", -c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)) - else - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -c write (iout,*) "alpha reg",dd,waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd - endif - endif - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo -cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) -C If this is a SC-SC distance, we need to calculate the contributions to the -C Cartesian gradient in the SC vectors (ghpbx). - if (iii.lt.ii) then - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - endif - do j=iii,jjj-1 - do k=1,3 - ghpbc(k,j)=ghpbc(k,j)+ggg(k) - enddo - enddo - endif - enddo - if (constr_dist.ne.11) ehpb=0.5D0*ehpb - return - end -C-------------------------------------------------------------------------- - subroutine ssbond_ene(i,j,eij) -C -C Calculate the distance and angle dependent SS-bond potential energy -C using a free-energy function derived based on RHF/6-31G** ab initio -C calculations of diethyl disulfide. -C -C A. Liwo and U. Kozlowska, 11/24/03 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - double precision erij(3),dcosom1(3),dcosom2(3),gg(3) - itypi=iabs(itype(i)) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) - dsci_inv=dsc_inv(itypi) - itypj=iabs(itype(j)) - dscj_inv=dsc_inv(itypj) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - erij(1)=xj*rij - erij(2)=yj*rij - erij(3)=zj*rij - om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) - om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) - om12=dxi*dxj+dyi*dyj+dzi*dzj - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - rij=1.0d0/rij - deltad=rij-d0cm - deltat1=1.0d0-om1 - deltat2=1.0d0+om2 - deltat12=om2-om1+2.0d0 - cosphi=om12-om1*om2 - eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) - & +akct*deltad*deltat12 - & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi -c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, -c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, -c & " deltat12",deltat12," eij",eij - ed=2*akcm*deltad+akct*deltat12 - pom1=akct*deltad - pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi - eom1=-2*akth*deltat1-pom1-om2*pom2 - eom2= 2*akth*deltat2+pom1-om1*pom2 - eom12=pom2 - do k=1,3 - gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) - enddo - do k=1,3 - ghpbx(k,i)=ghpbx(k,i)-gg(k) - & +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv - ghpbx(k,j)=ghpbx(k,j)+gg(k) - & +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv - enddo -C -C Calculate the components of the gradient in DC and X -C - do k=i,j-1 - do l=1,3 - ghpbc(l,k)=ghpbc(l,k)+gg(l) - enddo - enddo - return - end -C-------------------------------------------------------------------------- - subroutine ebond(estr) -c -c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - logical energy_dec /.false./ - double precision u(3),ud(3) - estr=0.0d0 - estr1=0.0d0 - do i=nnt+1,nct - if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle -C estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) -C do j=1,3 -C gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) -C & *dc(j,i-1)/vbld(i) -C enddo -C if (energy_dec) write(iout,*) -C & "estr1",i,vbld(i),distchainmax, -C & gnmr1(vbld(i),-1.0d0,distchainmax) -C else - if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then - diff = vbld(i)-vbldpDUM - else - diff = vbld(i)-vbldp0 -c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff - endif - estr=estr+diff*diff - do j=1,3 - gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) - enddo -C endif -C write (iout,'(a7,i5,4f7.3)') -C & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff - enddo - estr=0.5d0*AKP*estr+estr1 -c -c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included -c - do i=nnt,nct - iti=iabs(itype(i)) - if (iti.ne.10 .and. iti.ne.ntyp1) then - nbi=nbondterm(iti) - if (nbi.eq.1) then - diff=vbld(i+nres)-vbldsc0(1,iti) -c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff, -c & AKSC(1,iti),AKSC(1,iti)*diff*diff - estr=estr+0.5d0*AKSC(1,iti)*diff*diff - do j=1,3 - gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) - enddo - else - do j=1,nbi - diff=vbld(i+nres)-vbldsc0(j,iti) - ud(j)=aksc(j,iti)*diff - u(j)=abond0(j,iti)+0.5d0*ud(j)*diff - enddo - uprod=u(1) - do j=2,nbi - uprod=uprod*u(j) - enddo - usum=0.0d0 - usumsqder=0.0d0 - do j=1,nbi - uprod1=1.0d0 - uprod2=1.0d0 - do k=1,nbi - if (k.ne.j) then - uprod1=uprod1*u(k) - uprod2=uprod2*u(k)*u(k) - endif - enddo - usum=usum+uprod1 - usumsqder=usumsqder+ud(j)*uprod2 - enddo -c write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti), -c & AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi) - estr=estr+uprod/usum - do j=1,3 - gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) - enddo - endif - endif - enddo - return - end -#ifdef CRYST_THETA -C-------------------------------------------------------------------------- - subroutine ebend(etheta,ethetacnstr) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - double precision y(2),z(2) - delta=0.02d0*pi -c time11=dexp(-2*time) -c time12=1.0d0 - etheta=0.0D0 -c write (iout,*) "nres",nres -c write (*,'(a,i2)') 'EBEND ICG=',icg -c write (iout,*) ithet_start,ithet_end - do i=ithet_start,ithet_end - if (i.le.2) cycle - if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 - & .or.itype(i).eq.ntyp1) cycle -C Zero the energy function and its derivative at 0 or pi. - call splinthet(theta(i),0.5d0*delta,ss,ssd) - it=itype(i-1) - ichir1=isign(1,itype(i-2)) - ichir2=isign(1,itype(i)) - if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1)) - if (itype(i).eq.10) ichir2=isign(1,itype(i-1)) - if (itype(i-1).eq.10) then - itype1=isign(10,itype(i-2)) - ichir11=isign(1,itype(i-2)) - ichir12=isign(1,itype(i-2)) - itype2=isign(10,itype(i)) - ichir21=isign(1,itype(i)) - ichir22=isign(1,itype(i)) - endif - if (i.eq.3) then - y(1)=0.0D0 - y(2)=0.0D0 - else - if (i.gt.3 .and. itype(i-3).ne.ntyp1) then -#ifdef OSF - phii=phi(i) -c icrc=0 -c call proc_proc(phii,icrc) - if (icrc.eq.1) phii=150.0 -#else - phii=phi(i) -#endif - y(1)=dcos(phii) - y(2)=dsin(phii) - else - y(1)=0.0D0 - y(2)=0.0D0 - endif - endif - if (i.lt.nres .and. itype(i+1).ne.ntyp1) then -#ifdef OSF - phii1=phi(i+1) -c icrc=0 -c call proc_proc(phii1,icrc) - if (icrc.eq.1) phii1=150.0 - phii1=pinorm(phii1) - z(1)=cos(phii1) -#else - phii1=phi(i+1) - z(1)=dcos(phii1) -#endif - z(2)=dsin(phii1) - else - z(1)=0.0D0 - z(2)=0.0D0 - endif -C Calculate the "mean" value of theta from the part of the distribution -C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). -C In following comments this theta will be referred to as t_c. - thet_pred_mean=0.0d0 - do k=1,2 - athetk=athet(k,it,ichir1,ichir2) - bthetk=bthet(k,it,ichir1,ichir2) - if (it.eq.10) then - athetk=athet(k,itype1,ichir11,ichir12) - bthetk=bthet(k,itype2,ichir21,ichir22) - endif - thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) - enddo -c write (iout,*) "thet_pred_mean",thet_pred_mean - dthett=thet_pred_mean*ssd - thet_pred_mean=thet_pred_mean*ss+a0thet(it) -c write (iout,*) "thet_pred_mean",thet_pred_mean -C Derivatives of the "mean" values in gamma1 and gamma2. - dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) - &+athet(2,it,ichir1,ichir2)*y(1))*ss - dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) - & +bthet(2,it,ichir1,ichir2)*z(1))*ss - if (it.eq.10) then - dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) - &+athet(2,itype1,ichir11,ichir12)*y(1))*ss - dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) - & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss - endif - if (theta(i).gt.pi-delta) then - call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, - & E_tc0) - call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) - call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, - & E_theta) - call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else if (theta(i).lt.delta) then - call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) - call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, - & E_theta) - call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) - call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else - call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, - & E_theta,E_tc) - endif - etheta=etheta+ethetai -c write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i), -c & rad2deg*phii,rad2deg*phii1,ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 - gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett) -c 1215 continue - enddo -C Ufff.... We've done all this!!! -C now constrains - ethetacnstr=0.0d0 -C print *,ithetaconstr_start,ithetaconstr_end,"TU" - do i=1,ntheta_constr - itheta=itheta_constr(i) - thetiii=theta(itheta) - difi=pinorm(thetiii-theta_constr0(i)) - if (difi.gt.theta_drange(i)) then - difi=difi-theta_drange(i) - ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 - gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) - & +for_thet_constr(i)*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 - gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) - & +for_thet_constr(i)*difi**3 - else - difi=0.0 - endif -C if (energy_dec) then -C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", -C & i,itheta,rad2deg*thetiii, -C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), -C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, -C & gloc(itheta+nphi-2,icg) -C endif - enddo - return - end -C--------------------------------------------------------------------------- - subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, - & E_tc) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it -C Calculate the contributions to both Gaussian lobes. -C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) -C The "polynomial part" of the "standard deviation" of this part of -C the distribution. - sig=polthet(3,it) - do j=2,0,-1 - sig=sig*thet_pred_mean+polthet(j,it) - enddo -C Derivative of the "interior part" of the "standard deviation of the" -C gamma-dependent Gaussian lobe in t_c. - sigtc=3*polthet(3,it) - do j=2,1,-1 - sigtc=sigtc*thet_pred_mean+j*polthet(j,it) - enddo - sigtc=sig*sigtc -C Set the parameters of both Gaussian lobes of the distribution. -C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) - fac=sig*sig+sigc0(it) - sigcsq=fac+fac - sigc=1.0D0/sigcsq -C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c - sigsqtc=-4.0D0*sigcsq*sigtc -c print *,i,sig,sigtc,sigsqtc -C Following variable (sigtc) is d[sigma(t_c)]/dt_c - sigtc=-sigtc/(fac*fac) -C Following variable is sigma(t_c)**(-2) - sigcsq=sigcsq*sigcsq - sig0i=sig0(it) - sig0inv=1.0D0/sig0i**2 - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i - term1=-0.5D0*sigcsq*delthec*delthec - term2=-0.5D0*sig0inv*delthe0*delthe0 -C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and -C NaNs in taking the logarithm. We extract the largest exponent which is added -C to the energy (this being the log of the distribution) at the end of energy -C term evaluation for this virtual-bond angle. - if (term1.gt.term2) then - termm=term1 - term2=dexp(term2-termm) - term1=1.0d0 - else - termm=term2 - term1=dexp(term1-termm) - term2=1.0d0 - endif -C The ratio between the gamma-independent and gamma-dependent lobes of -C the distribution is a Gaussian function of thet_pred_mean too. - diffak=gthet(2,it)-thet_pred_mean - ratak=diffak/gthet(3,it)**2 - ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) -C Let's differentiate it in thet_pred_mean NOW. - aktc=ak*ratak -C Now put together the distribution terms to make complete distribution. - termexp=term1+ak*term2 - termpre=sigc+ak*sig0i -C Contribution of the bending energy from this theta is just the -log of -C the sum of the contributions from the two lobes and the pre-exponential -C factor. Simple enough, isn't it? - ethetai=(-dlog(termexp)-termm+dlog(termpre)) -C NOW the derivatives!!! -C 6/6/97 Take into account the deformation. - E_theta=(delthec*sigcsq*term1 - & +ak*delthe0*sig0inv*term2)/termexp - E_tc=((sigtc+aktc*sig0i)/termpre - & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ - & aktc*term2)/termexp) - return - end -c----------------------------------------------------------------------------- - subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i -C "Thank you" to MAPLE (probably spared one day of hand-differentiation). - t3 = thetai-thet_pred_mean - t6 = t3**2 - t9 = term1 - t12 = t3*sigcsq - t14 = t12+t6*sigsqtc - t16 = 1.0d0 - t21 = thetai-theta0i - t23 = t21**2 - t26 = term2 - t27 = t21*t26 - t32 = termexp - t40 = t32**2 - E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 - & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 - & *(-t12*t9-ak*sig0inv*t27) - return - end -#else -C-------------------------------------------------------------------------- - subroutine ebend(etheta,ethetacnstr) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C ab initio-derived potentials from -c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - include 'COMMON.TORCNSTR' - double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), - & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), - & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), - & sinph1ph2(maxdouble,maxdouble) - logical lprn /.false./, lprn1 /.false./ - etheta=0.0D0 -c write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1) - do i=ithet_start,ithet_end - if (i.le.2) cycle - if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1 - & .or.itype(i).eq.ntyp1) cycle -c if (itype(i-1).eq.ntyp1) cycle - if (iabs(itype(i+1)).eq.20) iblock=2 - if (iabs(itype(i+1)).ne.20) iblock=1 - dethetai=0.0d0 - dephii=0.0d0 - dephii1=0.0d0 - theti2=0.5d0*theta(i) - ityp2=ithetyp((itype(i-1))) - do k=1,nntheterm - coskt(k)=dcos(k*theti2) - sinkt(k)=dsin(k*theti2) - enddo - if (i.eq.3) then - phii=0.0d0 - ityp1=nthetyp+1 - do k=1,nsingle - cosph1(k)=0.0d0 - sinph1(k)=0.0d0 - enddo - else - if (i.gt.3 .and. itype(i-3).ne.ntyp1) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - ityp1=ithetyp((itype(i-2))) - do k=1,nsingle - cosph1(k)=dcos(k*phii) - sinph1(k)=dsin(k*phii) - enddo - else - phii=0.0d0 -c ityp1=nthetyp+1 - do k=1,nsingle - ityp1=ithetyp((itype(i-2))) - cosph1(k)=0.0d0 - sinph1(k)=0.0d0 - enddo - endif - endif - if (i.lt.nres .and. itype(i+1).ne.ntyp1) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) -#else - phii1=phi(i+1) -#endif - ityp3=ithetyp((itype(i))) - do k=1,nsingle - cosph2(k)=dcos(k*phii1) - sinph2(k)=dsin(k*phii1) - enddo - else - phii1=0.0d0 -c ityp3=nthetyp+1 - ityp3=ithetyp((itype(i))) - do k=1,nsingle - cosph2(k)=0.0d0 - sinph2(k)=0.0d0 - enddo - endif -c write (iout,*) "i",i," ityp1",itype(i-2),ityp1, -c & " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3 -c call flush(iout) - ethetai=aa0thet(ityp1,ityp2,ityp3,iblock) - do k=1,ndouble - do l=1,k-1 - ccl=cosph1(l)*cosph2(k-l) - ssl=sinph1(l)*sinph2(k-l) - scl=sinph1(l)*cosph2(k-l) - csl=cosph1(l)*sinph2(k-l) - cosph1ph2(l,k)=ccl-ssl - cosph1ph2(k,l)=ccl+ssl - sinph1ph2(l,k)=scl+csl - sinph1ph2(k,l)=scl-csl - enddo - enddo - if (lprn) then - write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2, - & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 - write (iout,*) "coskt and sinkt" - do k=1,nntheterm - write (iout,*) k,coskt(k),sinkt(k) - enddo - endif - do k=1,ntheterm - ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k) - dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) - & *coskt(k) - if (lprn) - & write (iout,*) "k",k," aathet", - & aathet(k,ityp1,ityp2,ityp3,iblock), - & " ethetai",ethetai - enddo - if (lprn) then - write (iout,*) "cosph and sinph" - do k=1,nsingle - write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) - enddo - write (iout,*) "cosph1ph2 and sinph2ph2" - do k=2,ndouble - do l=1,k-1 - write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), - & sinph1ph2(l,k),sinph1ph2(k,l) - enddo - enddo - write(iout,*) "ethetai",ethetai - endif - do m=1,ntheterm2 - do k=1,nsingle - aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) - & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) - & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) - & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*aux*coskt(m) - dephii=dephii+k*sinkt(m)*( - & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- - & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)) - dephii1=dephii1+k*sinkt(m)*( - & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- - & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)) - if (lprn) - & write (iout,*) "m",m," k",k," bbthet", - & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", - & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", - & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", - & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai - enddo - enddo - if (lprn) - & write(iout,*) "ethetai",ethetai - do m=1,ntheterm3 - do k=2,ndouble - do l=1,k-1 - aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*coskt(m)*aux - dephii=dephii+l*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- - & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) - dephii1=dephii1+(k-l)*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- - & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)) - if (lprn) then - write (iout,*) "m",m," k",k," l",l," ffthet", - & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock), - & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet", - & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock), - & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock), - & " ethetai",ethetai - write (iout,*) cosph1ph2(l,k)*sinkt(m), - & cosph1ph2(k,l)*sinkt(m), - & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) - endif - enddo - enddo - enddo -10 continue - if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') - & i,theta(i)*rad2deg,phii*rad2deg, - & phii1*rad2deg,ethetai - etheta=etheta+ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 -c gloc(nphi+i-2,icg)=wang*dethetai - gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai - enddo -C now constrains - ethetacnstr=0.0d0 -C print *,ithetaconstr_start,ithetaconstr_end,"TU" - do i=1,ntheta_constr - itheta=itheta_constr(i) - thetiii=theta(itheta) - difi=pinorm(thetiii-theta_constr0(i)) - if (difi.gt.theta_drange(i)) then - difi=difi-theta_drange(i) - ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 - gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) - & +for_thet_constr(i)*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4 - gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) - & +for_thet_constr(i)*difi**3 - else - difi=0.0 - endif -C if (energy_dec) then -C write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", -C & i,itheta,rad2deg*thetiii, -C & rad2deg*theta_constr0(i), rad2deg*theta_drange(i), -C & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, -C & gloc(itheta+nphi-2,icg) -C endif - enddo - return - end -#endif -#ifdef CRYST_SC -c----------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), - & ddersc0(3),ddummy(3),xtemp(3),temp(3) - common /sccalc/ time11,time12,time112,theti,it,nlobit - delta=0.02d0*pi - escloc=0.0D0 -c write (iout,'(a)') 'ESC' - do i=loc_start,loc_end - it=itype(i) - if (it.eq.ntyp1) cycle - if (it.eq.10) goto 1 - nlobit=nlob(iabs(it)) -c print *,'i=',i,' it=',it,' nlobit=',nlobit -c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad - theti=theta(i+1)-pipol - x(1)=dtan(theti) - x(2)=alph(i) - x(3)=omeg(i) -c write (iout,*) "i",i," x",x(1),x(2),x(3) - - if (x(2).gt.pi-delta) then - xtemp(1)=x(1) - xtemp(2)=pi-delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=pi - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=pi-delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=pi - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - call splinthet(x(2),0.5d0*delta,ss,ssd) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c escloci=esclocbi -c write (iout,*) escloci - else if (x(2).lt.delta) then - xtemp(1)=x(1) - xtemp(2)=delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=0.0d0 - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=0.0d0 - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - call splinthet(x(2),0.5d0*delta,ss,ssd) - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c write (iout,*) escloci - else - call enesc(x,escloci,dersc,ddummy,.false.) - endif - - escloc=escloc+escloci -c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc - - gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ - & wscloc*dersc(1) - gloc(ialph(i,1),icg)=wscloc*dersc(2) - gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) - 1 continue - enddo - return - end -C--------------------------------------------------------------------------- - subroutine enesc(x,escloci,dersc,ddersc,mixed) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /sccalc/ time11,time12,time112,theti,it,nlobit - double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) - double precision contr(maxlob,-1:1) - logical mixed -c write (iout,*) 'it=',it,' nlobit=',nlobit - escloc_i=0.0D0 - do j=1,3 - dersc(j)=0.0D0 - if (mixed) ddersc(j)=0.0d0 - enddo - x3=x(3) - -C Because of periodicity of the dependence of the SC energy in omega we have -C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). -C To avoid underflows, first compute & store the exponents. - - do iii=-1,1 - - x(3)=x3+iii*dwapi - - do j=1,nlobit - do k=1,3 - z(k)=x(k)-censc(k,j,it) - enddo - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j,iii)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j,iii)*z(k) - enddo - contr(j,iii)=expfac - enddo ! j - - enddo ! iii - - x(3)=x3 -C As in the case of ebend, we want to avoid underflows in exponentiation and -C subsequent NaNs and INFs in energy calculation. -C Find the largest exponent - emin=contr(1,-1) - do iii=-1,1 - do j=1,nlobit - if (emin.gt.contr(j,iii)) emin=contr(j,iii) - enddo - enddo - emin=0.5D0*emin -cd print *,'it=',it,' emin=',emin - -C Compute the contribution to SC energy and derivatives - do iii=-1,1 - - do j=1,nlobit - expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin) -cd print *,'j=',j,' expfac=',expfac - escloc_i=escloc_i+expfac - do k=1,3 - dersc(k)=dersc(k)+Ax(k,j,iii)*expfac - enddo - if (mixed) then - do k=1,3,2 - ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) - & +gaussc(k,2,j,it))*expfac - enddo - endif - enddo - - enddo ! iii - - dersc(1)=dersc(1)/cos(theti)**2 - ddersc(1)=ddersc(1)/cos(theti)**2 - ddersc(3)=ddersc(3) - - escloci=-(dlog(escloc_i)-emin) - do j=1,3 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) then - do j=1,3,2 - ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) - enddo - endif - return - end -C------------------------------------------------------------------------------ - subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /sccalc/ time11,time12,time112,theti,it,nlobit - double precision x(3),z(3),Ax(3,maxlob),dersc(3) - double precision contr(maxlob) - logical mixed - - escloc_i=0.0D0 - - do j=1,3 - dersc(j)=0.0D0 - enddo - - do j=1,nlobit - do k=1,2 - z(k)=x(k)-censc(k,j,it) - enddo - z(3)=dwapi - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j)*z(k) - enddo - contr(j)=expfac - enddo ! j - -C As in the case of ebend, we want to avoid underflows in exponentiation and -C subsequent NaNs and INFs in energy calculation. -C Find the largest exponent - emin=contr(1) - do j=1,nlobit - if (emin.gt.contr(j)) emin=contr(j) - enddo - emin=0.5D0*emin - -C Compute the contribution to SC energy and derivatives - - dersc12=0.0d0 - do j=1,nlobit - expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin) - escloc_i=escloc_i+expfac - do k=1,2 - dersc(k)=dersc(k)+Ax(k,j)*expfac - enddo - if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) - & +gaussc(1,2,j,it))*expfac - dersc(3)=0.0d0 - enddo - - dersc(1)=dersc(1)/cos(theti)**2 - dersc12=dersc12/cos(theti)**2 - escloci=-(dlog(escloc_i)-emin) - do j=1,2 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) - return - end -#else -c---------------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA derived from AM1 all-atom calculations. -C added by Urszula Kozlowska. 07/11/2007 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.SCROT' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - include 'COMMON.VECTORS' - double precision x_prime(3),y_prime(3),z_prime(3) - & , sumene,dsc_i,dp2_i,x(65), - & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, - & de_dxx,de_dyy,de_dzz,de_dt - double precision s1_t,s1_6_t,s2_t,s2_6_t - double precision - & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), - & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), - & dt_dCi(3),dt_dCi1(3) - common /sccalc/ time11,time12,time112,theti,it,nlobit - delta=0.02d0*pi - escloc=0.0D0 - do i=loc_start,loc_end - if (itype(i).eq.ntyp1) cycle - costtab(i+1) =dcos(theta(i+1)) - sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) - cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) - sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) - cosfac2=0.5d0/(1.0d0+costtab(i+1)) - cosfac=dsqrt(cosfac2) - sinfac2=0.5d0/(1.0d0-costtab(i+1)) - sinfac=dsqrt(sinfac2) - it=iabs(itype(i)) - if (it.eq.10) goto 1 -c -C Compute the axes of tghe local cartesian coordinates system; store in -c x_prime, y_prime and z_prime -c - do j=1,3 - x_prime(j) = 0.00 - y_prime(j) = 0.00 - z_prime(j) = 0.00 - enddo -C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), -C & dc_norm(3,i+nres) - do j = 1,3 - x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac - y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac - enddo - do j = 1,3 - z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i))) - enddo -c write (2,*) "i",i -c write (2,*) "x_prime",(x_prime(j),j=1,3) -c write (2,*) "y_prime",(y_prime(j),j=1,3) -c write (2,*) "z_prime",(z_prime(j),j=1,3) -c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), -c & " xy",scalar(x_prime(1),y_prime(1)), -c & " xz",scalar(x_prime(1),z_prime(1)), -c & " yy",scalar(y_prime(1),y_prime(1)), -c & " yz",scalar(y_prime(1),z_prime(1)), -c & " zz",scalar(z_prime(1),z_prime(1)) -c -C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), -C to local coordinate system. Store in xx, yy, zz. -c - xx=0.0d0 - yy=0.0d0 - zz=0.0d0 - do j = 1,3 - xx = xx + x_prime(j)*dc_norm(j,i+nres) - yy = yy + y_prime(j)*dc_norm(j,i+nres) - zz = zz + z_prime(j)*dc_norm(j,i+nres) - enddo - - xxtab(i)=xx - yytab(i)=yy - zztab(i)=zz -C -C Compute the energy of the ith side cbain -C -c write (2,*) "xx",xx," yy",yy," zz",zz - it=iabs(itype(i)) - do j = 1,65 - x(j) = sc_parmin(j,it) - enddo -#ifdef CHECK_COORD -Cc diagnostics - remove later - xx1 = dcos(alph(2)) - yy1 = dsin(alph(2))*dcos(omeg(2)) -c zz1 = -dsin(alph(2))*dsin(omeg(2)) - zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2)) - write(2,'(3f8.1,3f9.3,1x,3f9.3)') - & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, - & xx1,yy1,zz1 -C," --- ", xx_w,yy_w,zz_w -c end diagnostics -#endif - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) - & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) -c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, -c & sumene4, -c & dscp1,dscp2,sumene -c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - escloc = escloc + sumene -c write (2,*) "escloc",escloc - if (.not. calc_grad) goto 1 -#ifdef DEBUG -C -C This section to check the numerical derivatives of the energy of ith side -C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert -C #define DEBUG in the code to turn it on. -C - write (2,*) "sumene =",sumene - aincr=1.0d-7 - xxsave=xx - xx=xx+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dxx_num=(sumenep-sumene)/aincr - xx=xxsave - write (2,*) "xx+ sumene from enesc=",sumenep - yysave=yy - yy=yy+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dyy_num=(sumenep-sumene)/aincr - yy=yysave - write (2,*) "yy+ sumene from enesc=",sumenep - zzsave=zz - zz=zz+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dzz_num=(sumenep-sumene)/aincr - zz=zzsave - write (2,*) "zz+ sumene from enesc=",sumenep - costsave=cost2tab(i+1) - sintsave=sint2tab(i+1) - cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) - sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dt_num=(sumenep-sumene)/aincr - write (2,*) " t+ sumene from enesc=",sumenep - cost2tab(i+1)=costsave - sint2tab(i+1)=sintsave -C End of diagnostics section. -#endif -C -C Compute the gradient of esc -C - pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 - pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 - pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 - pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 - pom_dx=dsc_i*dp2_i*cost2tab(i+1) - pom_dy=dsc_i*dp2_i*sint2tab(i+1) - pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) - pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) - pom1=(sumene3*sint2tab(i+1)+sumene1) - & *(pom_s1/dscp1+pom_s16*dscp1**4) - pom2=(sumene4*cost2tab(i+1)+sumene2) - & *(pom_s2/dscp2+pom_s26*dscp2**4) - sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy - sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 - & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) - & +x(40)*yy*zz - sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy - sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 - & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) - & +x(60)*yy*zz - de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) - & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) - & +(pom1+pom2)*pom_dx -#ifdef DEBUG - write(2,*), "de_dxx = ", de_dxx,de_dxx_num -#endif -C - sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz - sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 - & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) - & +x(40)*xx*zz - sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz - sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz - & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz - & +x(59)*zz**2 +x(60)*xx*zz - de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) - & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) - & +(pom1-pom2)*pom_dy -#ifdef DEBUG - write(2,*), "de_dyy = ", de_dyy,de_dyy_num -#endif -C - de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy - & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx - & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) - & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) - & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 - & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy - & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) - & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) -#ifdef DEBUG - write(2,*), "de_dzz = ", de_dzz,de_dzz_num -#endif -C - de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) - & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) - & +pom1*pom_dt1+pom2*pom_dt2 -#ifdef DEBUG - write(2,*), "de_dt = ", de_dt,de_dt_num -#endif -c -C - cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) - cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) - cosfac2xx=cosfac2*xx - sinfac2yy=sinfac2*yy - do k = 1,3 - dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* - & vbld_inv(i+1) - dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* - & vbld_inv(i) - pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) - pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) -c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, -c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) -c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), -c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) - dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx - dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx - dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy - dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy - dZZ_Ci1(k)=0.0d0 - dZZ_Ci(k)=0.0d0 - do j=1,3 - dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) - & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) - dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) - & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres) - enddo - - dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) - dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) - dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) -c - dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) - dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) - enddo - - do k=1,3 - dXX_Ctab(k,i)=dXX_Ci(k) - dXX_C1tab(k,i)=dXX_Ci1(k) - dYY_Ctab(k,i)=dYY_Ci(k) - dYY_C1tab(k,i)=dYY_Ci1(k) - dZZ_Ctab(k,i)=dZZ_Ci(k) - dZZ_C1tab(k,i)=dZZ_Ci1(k) - dXX_XYZtab(k,i)=dXX_XYZ(k) - dYY_XYZtab(k,i)=dYY_XYZ(k) - dZZ_XYZtab(k,i)=dZZ_XYZ(k) - enddo - - do k = 1,3 -c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", -c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) -c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", -c & dyy_ci(k)," dzz_ci",dzz_ci(k) -c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", -c & dt_dci(k) -c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", -c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) - gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) - & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) - gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) - & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) - gsclocx(k,i)= de_dxx*dxx_XYZ(k) - & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) - enddo -c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), -c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) - -C to check gradient call subroutine check_grad - - 1 continue - enddo - return - end -#endif -c------------------------------------------------------------------------------ - subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) -C -C This procedure calculates two-body contact function g(rij) and its derivative: -C -C eps0ij ! x < -1 -C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 -C 0 ! x > 1 -C -C where x=(rij-r0ij)/delta -C -C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy -C - implicit none - double precision rij,r0ij,eps0ij,fcont,fprimcont - double precision x,x2,x4,delta -c delta=0.02D0*r0ij -c delta=0.2D0*r0ij - x=(rij-r0ij)/delta - if (x.lt.-1.0D0) then - fcont=eps0ij - fprimcont=0.0D0 - else if (x.le.1.0D0) then - x2=x*x - x4=x2*x2 - fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) - fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta - else - fcont=0.0D0 - fprimcont=0.0D0 - endif - return - end -c------------------------------------------------------------------------------ - subroutine splinthet(theti,delta,ss,ssder) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.VAR' - include 'COMMON.GEO' - thetup=pi-delta - thetlow=delta - if (theti.gt.pipol) then - call gcont(theti,thetup,1.0d0,delta,ss,ssder) - else - call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) - ssder=-ssder - endif - return - end -c------------------------------------------------------------------------------ - subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) - implicit none - double precision x,x0,delta,f0,f1,fprim0,f,fprim - double precision ksi,ksi2,ksi3,a1,a2,a3 - a1=fprim0*delta/(f1-f0) - a2=3.0d0-2.0d0*a1 - a3=a1-2.0d0 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) - fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) - return - end -c------------------------------------------------------------------------------ - subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) - implicit none - double precision x,x0,delta,f0x,f1x,fprim0x,fx - double precision ksi,ksi2,ksi3,a1,a2,a3 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - a1=fprim0x*delta - a2=3*(f1x-f0x)-2*fprim0x*delta - a3=fprim0x*delta-2*(f1x-f0x) - fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 - return - end -C----------------------------------------------------------------------------- -#ifdef CRYST_TOR -C----------------------------------------------------------------------------- - subroutine etor(etors,edihcnstr,fact) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1 - & .or. itype(i).eq.ntyp1) cycle - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -C Proline-Proline pair is a special case... - if (itori.eq.3 .and. itori1.eq.3) then - if (phii.gt.-dwapi3) then - cosphi=dcos(3*phii) - fac=1.0D0/(1.0D0-cosphi) - etorsi=v1(1,3,3)*fac - etorsi=etorsi+etorsi - etors=etors+etorsi-v1(1,3,3) - gloci=gloci-3*fac*etorsi*dsin(3*phii) - endif - do j=1,3 - v1ij=v1(j+1,itori,itori1) - v2ij=v2(j+1,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - else - do j=1,nterm_old - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - endif - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci -c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 - do i=1,ndih_constr - itori=idih_constr(i) - phii=phi(itori) - difi=phii-phi0(i) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 - endif -! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, -! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -! write (iout,*) 'edihcnstr',edihcnstr - return - end -c------------------------------------------------------------------------------ -#else - subroutine etor(etors,edihcnstr,fact) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - if (i.le.2) cycle - if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1 - & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle - if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215 - if (iabs(itype(i)).eq.20) then - iblock=2 - else - iblock=1 - endif - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -C Regular cosine and sine terms - do j=1,nterm(itori,itori1,iblock) - v1ij=v1(j,itori,itori1,iblock) - v2ij=v2(j,itori,itori1,iblock) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo -C Lorentz terms -C v1 -C E = SUM ----------------------------------- - v1 -C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 -C - cosphi=dcos(0.5d0*phii) - sinphi=dsin(0.5d0*phii) - do j=1,nlor(itori,itori1,iblock) - vl1ij=vlor1(j,itori,itori1) - vl2ij=vlor2(j,itori,itori1) - vl3ij=vlor3(j,itori,itori1) - pom=vl2ij*cosphi+vl3ij*sinphi - pom1=1.0d0/(pom*pom+1.0d0) - etors=etors+vl1ij*pom1 - pom=-pom*pom1*pom1 - gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom - enddo -C Subtract the constant term - etors=etors-v0(itori,itori1,iblock) - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci -c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - 1215 continue - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 - do i=1,ndih_constr - itori=idih_constr(i) - phii=phi(itori) - difi=pinorm(phii-phi0(i)) - edihi=0.0d0 - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 - edihi=0.25d0*ftors(i)*difi**4 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3 - edihi=0.25d0*ftors(i)*difi**4 - else - difi=0.0d0 - endif -c write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi, -c & drange(i),edihi -! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, -! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -! write (iout,*) 'edihcnstr',edihcnstr - return - end -c---------------------------------------------------------------------------- - subroutine etor_d(etors_d,fact2) -C 6/23/01 Compute double torsional energy - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors_d=0.0D0 - do i=iphi_start,iphi_end-1 - if (i.le.3) cycle - if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or. - & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or. - & (itype(i+1).eq.ntyp1)) cycle - if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0) - & goto 1215 - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - itori2=itortyp(itype(i)) - phii=phi(i) - phii1=phi(i+1) - gloci1=0.0D0 - gloci2=0.0D0 - iblock=1 - if (iabs(itype(i+1)).eq.20) iblock=2 -C Regular cosine and sine terms - do j=1,ntermd_1(itori,itori1,itori2,iblock) - v1cij=v1c(1,j,itori,itori1,itori2,iblock) - v1sij=v1s(1,j,itori,itori1,itori2,iblock) - v2cij=v1c(2,j,itori,itori1,itori2,iblock) - v2sij=v1s(2,j,itori,itori1,itori2,iblock) - cosphi1=dcos(j*phii) - sinphi1=dsin(j*phii) - cosphi2=dcos(j*phii1) - sinphi2=dsin(j*phii1) - etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ - & v2cij*cosphi2+v2sij*sinphi2 - gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) - gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) - enddo - do k=2,ntermd_2(itori,itori1,itori2,iblock) - do l=1,k-1 - v1cdij = v2c(k,l,itori,itori1,itori2,iblock) - v2cdij = v2c(l,k,itori,itori1,itori2,iblock) - v1sdij = v2s(k,l,itori,itori1,itori2,iblock) - v2sdij = v2s(l,k,itori,itori1,itori2,iblock) - cosphi1p2=dcos(l*phii+(k-l)*phii1) - cosphi1m2=dcos(l*phii-(k-l)*phii1) - sinphi1p2=dsin(l*phii+(k-l)*phii1) - sinphi1m2=dsin(l*phii-(k-l)*phii1) - etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ - & v1sdij*sinphi1p2+v2sdij*sinphi1m2 - gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 - & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) - gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 - & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) - enddo - enddo - gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1 - gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2 - 1215 continue - enddo - return - end -#endif -c------------------------------------------------------------------------------ - subroutine eback_sc_corr(esccor) -c 7/21/2007 Correlations between the backbone-local and side-chain-local -c conformational states; temporarily implemented as differences -c between UNRES torsional potentials (dependent on three types of -c residues) and the torsional potentials dependent on all 20 types -c of residues computed from AM1 energy surfaces of terminally-blocked -c amino-acid residues. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.SCCOR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. -c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor - esccor=0.0D0 - do i=itau_start,itau_end - if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle - esccor_ii=0.0D0 - isccori=isccortyp(itype(i-2)) - isccori1=isccortyp(itype(i-1)) - phii=phi(i) - do intertyp=1,3 !intertyp -cc Added 09 May 2012 (Adasko) -cc Intertyp means interaction type of backbone mainchain correlation: -c 1 = SC...Ca...Ca...Ca -c 2 = Ca...Ca...Ca...SC -c 3 = SC...Ca...Ca...SCi - gloci=0.0D0 - if (((intertyp.eq.3).and.((itype(i-2).eq.10).or. - & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or. - & (itype(i-1).eq.ntyp1))) - & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10) - & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1) - & .or.(itype(i).eq.ntyp1))) - & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or. - & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or. - & (itype(i-3).eq.ntyp1)))) cycle - if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle - if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1)) - & cycle - do j=1,nterm_sccor(isccori,isccori1) - v1ij=v1sccor(j,intertyp,isccori,isccori1) - v2ij=v2sccor(j,intertyp,isccori,isccori1) - cosphi=dcos(j*tauangle(intertyp,i)) - sinphi=dsin(j*tauangle(intertyp,i)) - esccor=esccor+v1ij*cosphi+v2ij*sinphi -c gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo -c write (iout,*) "EBACK_SC_COR",i,esccor,intertyp -c gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1sccor(j,1,itori,itori1),j=1,6), - & (v2sccor(j,1,itori,itori1),j=1,6) - gsccor_loc(i-3)=gloci - enddo !intertyp - enddo - return - end -c------------------------------------------------------------------------------ - subroutine multibody(ecorr) -C This subroutine calculates multi-body contributions to energy following -C the idea of Skolnick et al. If side chains I and J make a contact and -C at the same time side chains I+1 and J+1 make a contact, an extra -C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - -C Set lprn=.true. for debugging - lprn=.false. - - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(i2,20(1x,i2,f10.5))') - & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) - enddo - endif - ecorr=0.0D0 - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo - do i=nnt,nct-2 - - DO ISHIFT = 3,4 - - i1=i+ishift - num_conti=num_cont(i) - num_conti1=num_cont(i1) - do jj=1,num_conti - j=jcont(jj,i) - do kk=1,num_conti1 - j1=jcont(kk,i1) - if (j1.eq.j+ishift .or. j1.eq.j-ishift) then -cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, -cd & ' ishift=',ishift -C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) - endif ! j1==j+-ishift - enddo ! kk - enddo ! jj - - ENDDO ! ISHIFT - - enddo ! i - return - end -c------------------------------------------------------------------------------ - double precision function esccorr(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont(jj,i) - ekl=facont(kk,k) -cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl -C Calculate the multi-body contribution to energy. -C Calculate multi-body contributions to the gradient. -cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), -cd & k,l,(gacont(m,kk,k),m=1,3) - do m=1,3 - gx(m) =ekl*gacont(m,jj,i) - gx1(m)=eij*gacont(m,kk,k) - gradxorr(m,i)=gradxorr(m,i)-gx(m) - gradxorr(m,j)=gradxorr(m,j)+gx(m) - gradxorr(m,k)=gradxorr(m,k)-gx1(m) - gradxorr(m,l)=gradxorr(m,l)+gx1(m) - enddo - do m=i,j-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) - enddo - enddo - do m=k,l-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) - enddo - enddo - esccorr=-eij*ekl - return - end -c------------------------------------------------------------------------------ -#ifdef MPL - subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - integer dimen1,dimen2,atom,indx - double precision buffer(dimen1,dimen2) - double precision zapas - common /contacts_hb/ zapas(3,20,maxres,7), - & facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres), - & num_cont_hb(maxres),jcont_hb(20,maxres) - num_kont=num_cont_hb(atom) - do i=1,num_kont - do k=1,7 - do j=1,3 - buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k) - enddo ! j - enddo ! k - buffer(i,indx+22)=facont_hb(i,atom) - buffer(i,indx+23)=ees0p(i,atom) - buffer(i,indx+24)=ees0m(i,atom) - buffer(i,indx+25)=dfloat(jcont_hb(i,atom)) - enddo ! i - buffer(1,indx+26)=dfloat(num_kont) - return - end -c------------------------------------------------------------------------------ - subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - integer dimen1,dimen2,atom,indx - double precision buffer(dimen1,dimen2) - double precision zapas - common /contacts_hb/ zapas(3,ntyp,maxres,7), - & facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres), - & num_cont_hb(maxres),jcont_hb(ntyp,maxres) - num_kont=buffer(1,indx+26) - num_kont_old=num_cont_hb(atom) - num_cont_hb(atom)=num_kont+num_kont_old - do i=1,num_kont - ii=i+num_kont_old - do k=1,7 - do j=1,3 - zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j) - enddo ! j - enddo ! k - facont_hb(ii,atom)=buffer(i,indx+22) - ees0p(ii,atom)=buffer(i,indx+23) - ees0m(ii,atom)=buffer(i,indx+24) - jcont_hb(ii,atom)=buffer(i,indx+25) - enddo ! i - return - end -c------------------------------------------------------------------------------ -#endif - subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -C This subroutine calculates multi-body contributions to hydrogen-bonding - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.IOUNITS' -#ifdef MPL - include 'COMMON.INFO' -#endif - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' -#ifdef MPL - parameter (max_cont=maxconts) - parameter (max_dim=2*(8*3+2)) - parameter (msglen1=max_cont*max_dim*4) - parameter (msglen2=2*msglen1) - integer source,CorrelType,CorrelID,Error - double precision buffer(max_cont,max_dim) -#endif - double precision gx(3),gx1(3) - logical lprn,ldone - -C Set lprn=.true. for debugging - lprn=.false. -#ifdef MPL - n_corr=0 - n_corr1=0 - if (fgProcs.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif -C Caution! Following code assumes that electrostatic interactions concerning -C a given atom are split among at most two processors! - CorrelType=477 - CorrelID=MyID+1 - ldone=.false. - do i=1,max_cont - do j=1,max_dim - buffer(i,j)=0.0D0 - enddo - enddo - mm=mod(MyRank,2) -cd write (iout,*) 'MyRank',MyRank,' mm',mm - if (mm) 20,20,10 - 10 continue -cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone - if (MyRank.gt.0) then -C Send correlation contributions to the preceding processor - msglen=msglen1 - nn=num_cont_hb(iatel_s) - call pack_buffer(max_cont,max_dim,iatel_s,0,buffer) -cd write (iout,*) 'The BUFFER array:' -cd do i=1,nn -cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26) -cd enddo - if (ielstart(iatel_s).gt.iatel_s+ispp) then - msglen=msglen2 - call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer) -C Clear the contacts of the atom passed to the neighboring processor - nn=num_cont_hb(iatel_s+1) -cd do i=1,nn -cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26) -cd enddo - num_cont_hb(iatel_s)=0 - endif -cd write (iout,*) 'Processor ',MyID,MyRank, -cd & ' is sending correlation contribution to processor',MyID-1, -cd & ' msglen=',msglen -cd write (*,*) 'Processor ',MyID,MyRank, -cd & ' is sending correlation contribution to processor',MyID-1, -cd & ' msglen=',msglen,' CorrelType=',CorrelType - call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID) -cd write (iout,*) 'Processor ',MyID, -cd & ' has sent correlation contribution to processor',MyID-1, -cd & ' msglen=',msglen,' CorrelID=',CorrelID -cd write (*,*) 'Processor ',MyID, -cd & ' has sent correlation contribution to processor',MyID-1, -cd & ' msglen=',msglen,' CorrelID=',CorrelID - msglen=msglen1 - endif ! (MyRank.gt.0) - if (ldone) goto 30 - ldone=.true. - 20 continue -cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone - if (MyRank.lt.fgProcs-1) then -C Receive correlation contributions from the next processor - msglen=msglen1 - if (ielend(iatel_e).lt.nct-1) msglen=msglen2 -cd write (iout,*) 'Processor',MyID, -cd & ' is receiving correlation contribution from processor',MyID+1, -cd & ' msglen=',msglen,' CorrelType=',CorrelType -cd write (*,*) 'Processor',MyID, -cd & ' is receiving correlation contribution from processor',MyID+1, -cd & ' msglen=',msglen,' CorrelType=',CorrelType - nbytes=-1 - do while (nbytes.le.0) - call mp_probe(MyID+1,CorrelType,nbytes) - enddo -cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes - call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes) -cd write (iout,*) 'Processor',MyID, -cd & ' has received correlation contribution from processor',MyID+1, -cd & ' msglen=',msglen,' nbytes=',nbytes -cd write (iout,*) 'The received BUFFER array:' -cd do i=1,max_cont -cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52) -cd enddo - if (msglen.eq.msglen1) then - call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer) - else if (msglen.eq.msglen2) then - call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) - call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) - else - write (iout,*) - & 'ERROR!!!! message length changed while processing correlations.' - write (*,*) - & 'ERROR!!!! message length changed while processing correlations.' - call mp_stopall(Error) - endif ! msglen.eq.msglen1 - endif ! MyRank.lt.fgProcs-1 - if (ldone) goto 30 - ldone=.true. - goto 10 - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 -C Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -C Calculate the local-electrostatic correlation terms - do i=iatel_s,iatel_e+1 - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if (j1.eq.j+1 .or. j1.eq.j-1) then -C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) - n_corr=n_corr+1 - else if (j1.eq.j) then -C Contacts I-J and I-(J+1) occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) - endif - enddo ! kk - do kk=1,num_conti - j1=jcont_hb(kk,i) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if (j1.eq.j+1) then -C Contacts I-J and (I+1)-J occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) - endif ! j1==j+1 - enddo ! kk - enddo ! jj - enddo ! i - return - end -c------------------------------------------------------------------------------ - subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, - & n_corr1) -C This subroutine calculates multi-body contributions to hydrogen-bonding - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.IOUNITS' -#ifdef MPL - include 'COMMON.INFO' -#endif - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' -#ifdef MPL - parameter (max_cont=maxconts) - parameter (max_dim=2*(8*3+2)) - parameter (msglen1=max_cont*max_dim*4) - parameter (msglen2=2*msglen1) - integer source,CorrelType,CorrelID,Error - double precision buffer(max_cont,max_dim) -#endif - double precision gx(3),gx1(3) - logical lprn,ldone - -C Set lprn=.true. for debugging - lprn=.false. - eturn6=0.0d0 -#ifdef MPL - n_corr=0 - n_corr1=0 - if (fgProcs.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif -C Caution! Following code assumes that electrostatic interactions concerning -C a given atom are split among at most two processors! - CorrelType=477 - CorrelID=MyID+1 - ldone=.false. - do i=1,max_cont - do j=1,max_dim - buffer(i,j)=0.0D0 - enddo - enddo - mm=mod(MyRank,2) -cd write (iout,*) 'MyRank',MyRank,' mm',mm - if (mm) 20,20,10 - 10 continue -cd write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone - if (MyRank.gt.0) then -C Send correlation contributions to the preceding processor - msglen=msglen1 - nn=num_cont_hb(iatel_s) - call pack_buffer(max_cont,max_dim,iatel_s,0,buffer) -cd write (iout,*) 'The BUFFER array:' -cd do i=1,nn -cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26) -cd enddo - if (ielstart(iatel_s).gt.iatel_s+ispp) then - msglen=msglen2 - call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer) -C Clear the contacts of the atom passed to the neighboring processor - nn=num_cont_hb(iatel_s+1) -cd do i=1,nn -cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26) -cd enddo - num_cont_hb(iatel_s)=0 - endif -cd write (iout,*) 'Processor ',MyID,MyRank, -cd & ' is sending correlation contribution to processor',MyID-1, -cd & ' msglen=',msglen -cd write (*,*) 'Processor ',MyID,MyRank, -cd & ' is sending correlation contribution to processor',MyID-1, -cd & ' msglen=',msglen,' CorrelType=',CorrelType - call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID) -cd write (iout,*) 'Processor ',MyID, -cd & ' has sent correlation contribution to processor',MyID-1, -cd & ' msglen=',msglen,' CorrelID=',CorrelID -cd write (*,*) 'Processor ',MyID, -cd & ' has sent correlation contribution to processor',MyID-1, -cd & ' msglen=',msglen,' CorrelID=',CorrelID - msglen=msglen1 - endif ! (MyRank.gt.0) - if (ldone) goto 30 - ldone=.true. - 20 continue -cd write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone - if (MyRank.lt.fgProcs-1) then -C Receive correlation contributions from the next processor - msglen=msglen1 - if (ielend(iatel_e).lt.nct-1) msglen=msglen2 -cd write (iout,*) 'Processor',MyID, -cd & ' is receiving correlation contribution from processor',MyID+1, -cd & ' msglen=',msglen,' CorrelType=',CorrelType -cd write (*,*) 'Processor',MyID, -cd & ' is receiving correlation contribution from processor',MyID+1, -cd & ' msglen=',msglen,' CorrelType=',CorrelType - nbytes=-1 - do while (nbytes.le.0) - call mp_probe(MyID+1,CorrelType,nbytes) - enddo -cd print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes - call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes) -cd write (iout,*) 'Processor',MyID, -cd & ' has received correlation contribution from processor',MyID+1, -cd & ' msglen=',msglen,' nbytes=',nbytes -cd write (iout,*) 'The received BUFFER array:' -cd do i=1,max_cont -cd write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52) -cd enddo - if (msglen.eq.msglen1) then - call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer) - else if (msglen.eq.msglen2) then - call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer) - call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer) - else - write (iout,*) - & 'ERROR!!!! message length changed while processing correlations.' - write (*,*) - & 'ERROR!!!! message length changed while processing correlations.' - call mp_stopall(Error) - endif ! msglen.eq.msglen1 - endif ! MyRank.lt.fgProcs-1 - if (ldone) goto 30 - ldone=.true. - goto 10 - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 - ecorr5=0.0d0 - ecorr6=0.0d0 -C Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -C Calculate the dipole-dipole interaction energies - if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then - do i=iatel_s,iatel_e+1 - num_conti=num_cont_hb(i) - do jj=1,num_conti - j=jcont_hb(jj,i) - call dipole(i,j,jj) - enddo - enddo - endif -C Calculate the local-electrostatic correlation terms - do i=iatel_s,iatel_e+1 - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) -c write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if (j1.eq.j+1 .or. j1.eq.j-1) then -C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -C The system gains extra energy. - n_corr=n_corr+1 - sqd1=dsqrt(d_cont(jj,i)) - sqd2=dsqrt(d_cont(kk,i1)) - sred_geom = sqd1*sqd2 - IF (sred_geom.lt.cutoff_corr) THEN - call gcont(sred_geom,r0_corr,1.0D0,delt_corr, - & ekont,fprimcont) -c write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - fac_prim1=0.5d0*sqd2/sqd1*fprimcont - fac_prim2=0.5d0*sqd1/sqd2*fprimcont - do l=1,3 - g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) - g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) - enddo - n_corr1=n_corr1+1 -cd write (iout,*) 'sred_geom=',sred_geom, -cd & ' ekont=',ekont,' fprim=',fprimcont - call calc_eello(i,j,i+1,j1,jj,kk) - if (wcorr4.gt.0.0d0) - & ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk) - if (wcorr5.gt.0.0d0) - & ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk) -c print *,"wcorr5",ecorr5 -cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 -cd write(2,*)'ijkl',i,j,i+1,j1 - if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3 - & .or. wturn6.eq.0.0d0))then -cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 - ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk) -cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, -cd & 'ecorr6=',ecorr6 -cd write (iout,'(4e15.5)') sred_geom, -cd & dabs(eello4(i,j,i+1,j1,jj,kk)), -cd & dabs(eello5(i,j,i+1,j1,jj,kk)), -cd & dabs(eello6(i,j,i+1,j1,jj,kk)) - else if (wturn6.gt.0.0d0 - & .and. (j.eq.i+4 .and. j1.eq.i+3)) then -cd write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1 - eturn6=eturn6+eello_turn6(i,jj,kk) -cd write (2,*) 'multibody_eello:eturn6',eturn6 - endif - ENDIF -1111 continue - else if (j1.eq.j) then -C Contacts I-J and I-(J+1) occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) - endif - enddo ! kk - do kk=1,num_conti - j1=jcont_hb(kk,i) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if (j1.eq.j+1) then -C Contacts I-J and (I+1)-J occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) - endif ! j1==j+1 - enddo ! kk - enddo ! jj - enddo ! i - return - end -c------------------------------------------------------------------------------ - double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.SHIELD' - - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont_hb(jj,i) - ekl=facont_hb(kk,k) - ees0pij=ees0p(jj,i) - ees0pkl=ees0p(kk,k) - ees0mij=ees0m(jj,i) - ees0mkl=ees0m(kk,k) - ekont=eij*ekl - ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) -cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) -C Following 4 lines for diagnostics. -cd ees0pkl=0.0D0 -cd ees0pij=1.0D0 -cd ees0mkl=0.0D0 -cd ees0mij=1.0D0 -c write (iout,*)'Contacts have occurred for peptide groups',i,j, -c & ' and',k,l -c write (iout,*)'Contacts have occurred for peptide groups', -c & i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l -c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees -C Calculate the multi-body contribution to energy. - ecorr=ecorr+ekont*ees - if (calc_grad) then -C Calculate multi-body contributions to the gradient. - do ll=1,3 - ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i) - gradcorr(ll,i)=gradcorr(ll,i)+ghalf - & -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+ - & coeffm*ees0mkl*gacontm_hb1(ll,jj,i)) - gradcorr(ll,j)=gradcorr(ll,j)+ghalf - & -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+ - & coeffm*ees0mkl*gacontm_hb2(ll,jj,i)) - ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k) - gradcorr(ll,k)=gradcorr(ll,k)+ghalf - & -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+ - & coeffm*ees0mij*gacontm_hb1(ll,kk,k)) - gradcorr(ll,l)=gradcorr(ll,l)+ghalf - & -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+ - & coeffm*ees0mij*gacontm_hb2(ll,kk,k)) - enddo - do m=i+1,j-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+ - & ees*ekl*gacont_hbr(ll,jj,i)- - & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ - & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) - enddo - enddo - do m=k+1,l-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+ - & ees*eij*gacont_hbr(ll,kk,k)- - & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ - & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) - enddo - enddo - if (shield_mode.gt.0) then - j=ees0plist(jj,i) - l=ees0plist(kk,k) -C print *,i,j,fac_shield(i),fac_shield(j), -C &fac_shield(k),fac_shield(l) - if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. - & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then - do ilist=1,ishield_list(i) - iresshield=shield_list(ilist,i) - do m=1,3 - rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i) -C & *2.0 - gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ - & rlocshield - & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i) - gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) - &+rlocshield - enddo - enddo - do ilist=1,ishield_list(j) - iresshield=shield_list(ilist,j) - do m=1,3 - rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j) -C & *2.0 - gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ - & rlocshield - & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j) - gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) - & +rlocshield - enddo - enddo - do ilist=1,ishield_list(k) - iresshield=shield_list(ilist,k) - do m=1,3 - rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k) -C & *2.0 - gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ - & rlocshield - & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k) - gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) - & +rlocshield - enddo - enddo - do ilist=1,ishield_list(l) - iresshield=shield_list(ilist,l) - do m=1,3 - rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l) -C & *2.0 - gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ - & rlocshield - & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l) - gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) - & +rlocshield - enddo - enddo -C print *,gshieldx(m,iresshield) - do m=1,3 - gshieldc_ec(m,i)=gshieldc_ec(m,i)+ - & grad_shield(m,i)*ehbcorr/fac_shield(i) - gshieldc_ec(m,j)=gshieldc_ec(m,j)+ - & grad_shield(m,j)*ehbcorr/fac_shield(j) - gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+ - & grad_shield(m,i)*ehbcorr/fac_shield(i) - gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+ - & grad_shield(m,j)*ehbcorr/fac_shield(j) - - gshieldc_ec(m,k)=gshieldc_ec(m,k)+ - & grad_shield(m,k)*ehbcorr/fac_shield(k) - gshieldc_ec(m,l)=gshieldc_ec(m,l)+ - & grad_shield(m,l)*ehbcorr/fac_shield(l) - gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+ - & grad_shield(m,k)*ehbcorr/fac_shield(k) - gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+ - & grad_shield(m,l)*ehbcorr/fac_shield(l) - - enddo - endif - endif - endif - ehbcorr=ekont*ees - return - end -C--------------------------------------------------------------------------- - subroutine dipole(i,j,jj) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), - & auxmat(2,2) - iti1 = itortyp(itype(i+1)) - if (j.lt.nres-1) then - if (itype(j).le.ntyp) then - itj1 = itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - else - itj1=ntortyp+1 - endif - do iii=1,2 - dipi(iii,1)=Ub2(iii,i) - dipderi(iii)=Ub2der(iii,i) - dipi(iii,2)=b1(iii,iti1) - dipj(iii,1)=Ub2(iii,j) - dipderj(iii)=Ub2der(iii,j) - dipj(iii,2)=b1(iii,itj1) - enddo - kkk=0 - do iii=1,2 - call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) - do jjj=1,2 - kkk=kkk+1 - dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - if (.not.calc_grad) return - do kkk=1,5 - do lll=1,3 - mmm=0 - do iii=1,2 - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), - & auxvec(1)) - do jjj=1,2 - mmm=mmm+1 - dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - enddo - enddo - call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) - call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) - do iii=1,2 - dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) - enddo - call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) - do iii=1,2 - dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) - enddo - return - end -C--------------------------------------------------------------------------- - subroutine calc_eello(i,j,k,l,jj,kk) -C -C This subroutine computes matrices and vectors needed to calculate -C the fourth-, fifth-, and sixth-order local-electrostatic terms. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), - & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) - logical lprn - common /kutas/ lprn -cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, -cd & ' jj=',jj,' kk=',kk -cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) - aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) - enddo - enddo - call transpose2(aa1(1,1),aa1t(1,1)) - call transpose2(aa2(1,1),aa2t(1,1)) - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), - & aa1tder(1,1,lll,kkk)) - call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), - & aa2tder(1,1,lll,kkk)) - enddo - enddo - if (l.eq.j+1) then -C parallel orientation of the two CA-CA-CA frames. -c if (i.gt.1) then - if (i.gt.1 .and. itype(i).le.ntyp) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itj=itortyp(itype(j)) -c if (l.lt.nres-1) then - if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -C A1 kernel(j+1) A2T -cd do iii=1,2 -cd write (iout,'(3f10.5,5x,3f10.5)') -cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) -cd enddo - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), - & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), - & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), - & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), - & ADtEAderx(1,1,1,1,1,1)) - lprn=.false. - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), - & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), - & ADtEA1derx(1,1,1,1,1,1)) - ENDIF -C End 6-th order cumulants -cd lprn=.false. -cd if (lprn) then -cd write (2,*) 'In calc_eello6' -cd do iii=1,2 -cd write (2,*) 'iii=',iii -cd do kkk=1,5 -cd write (2,*) 'kkk=',kkk -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) -cd enddo -cd enddo -cd enddo -cd endif - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -C A1T kernel(i+1) A2 - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), - & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), - & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), - & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), - & ADtEAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), - & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), - & ADtEA1derx(1,1,1,1,1,2)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -C AEAb1 and AEAb2 -C Calculate the vectors and their derivatives in virtual-bond dihedral angles. -C They are needed only when the fifth- or the sixth-order cumulants are -C indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) -C Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -C End vectors - else -C Antiparallel orientation of the two CA-CA-CA frames. -c if (i.gt.1) then - if (i.gt.1 .and. itype(i).le.ntyp) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) -c if (j.lt.nres-1) then - if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif -C A2 kernel(j-1)T A1T - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), - & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. - & j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), - & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), - & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), - & ADtEAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), - & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), - & ADtEA1derx(1,1,1,1,1,1)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -C A2T kernel(i+1)T A1 - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), - & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. - & j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), - & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), - & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), - & ADtEAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), - & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), - & ADtEA1derx(1,1,1,1,1,2)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -C AEAb1 and AEAb2 -C Calculate the vectors and their derivatives in virtual-bond dihedral angles. -C They are needed only when the fifth- or the sixth-order cumulants are -C indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. - & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) -C Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -C End vectors - endif - return - end -C--------------------------------------------------------------------------- - subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, - & KK,KKderg,AKA,AKAderg,AKAderx) - implicit none - integer nderg - logical transp - double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), - & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), - & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) - integer iii,kkk,lll - integer jjj,mmm - logical lprn - common /kutas/ lprn - call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) - do iii=1,nderg - call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, - & AKAderg(1,1,iii)) - enddo -cd if (lprn) write (2,*) 'In kernel' - do kkk=1,5 -cd if (lprn) write (2,*) 'kkk=',kkk - do lll=1,3 - call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), - & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) -cd if (lprn) then -cd write (2,*) 'lll=',lll -cd write (2,*) 'iii=1' -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) -cd enddo -cd endif - call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), - & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) -cd if (lprn) then -cd write (2,*) 'lll=',lll -cd write (2,*) 'iii=2' -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) -cd enddo -cd endif - enddo - enddo - return - end -C--------------------------------------------------------------------------- - double precision function eello4(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then -cd eello4=0.0d0 -cd return -cd endif -cd print *,'eello4:',i,j,k,l,jj,kk -cd write (2,*) 'i',i,' j',j,' k',k,' l',l -cd call checkint4(i,j,k,l,jj,kk,eel4_num) -cold eij=facont_hb(jj,i) -cold ekl=facont_hb(kk,k) -cold ekont=eij*ekl - eel4=-EAEA(1,1,1)-EAEA(2,2,1) - if (calc_grad) then -cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) - gcorr_loc(k-1)=gcorr_loc(k-1) - & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) - if (l.eq.j+1) then - gcorr_loc(l-1)=gcorr_loc(l-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - else - gcorr_loc(j-1)=gcorr_loc(j-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) - & -EAEAderx(2,2,lll,kkk,iii,1) -cd derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd gcorr_loc(l-1)=0.0d0 -cd gcorr_loc(j-1)=0.0d0 -cd gcorr_loc(k-1)=0.0d0 -cd eel4=1.0d0 -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l, -cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cold ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i) - ggg1(ll)=eel4*g_contij(ll,1) - ggg2(ll)=eel4*g_contij(ll,2) - ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1) - gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) - gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1) - gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) -cold ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k) - ghalf=0.5d0*ggg2(ll) -cd ghalf=0.0d0 - gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2) - gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) - gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2) - gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) - enddo -cd goto 1112 - do m=i+1,j-1 - do ll=1,3 -cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i) - gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) - enddo - enddo - do m=k+1,l-1 - do ll=1,3 -cold gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k) - gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) - enddo - enddo -1112 continue - do m=i+2,j2 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) - enddo - enddo - do m=k+2,l2 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) - enddo - enddo -cd do iii=1,nres-3 -cd write (2,*) iii,gcorr_loc(iii) -cd enddo - endif - eello4=ekont*eel4 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello4',ekont*eel4 - return - end -C--------------------------------------------------------------------------- - double precision function eello5(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) - double precision ggg1(3),ggg2(3) -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel chains C -C C -C o o o o C -C /l\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j| o |l1 | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C Antiparallel chains C -C C -C o o o o C -C /j\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j1| o |l | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C o denotes a local interaction, vertical lines an electrostatic interaction. C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then -cd eello5=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - itk=itortyp(itype(k)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - eello5_1=0.0d0 - eello5_2=0.0d0 - eello5_3=0.0d0 - eello5_4=0.0d0 -cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, -cd & eel5_3_num,eel5_4_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l -cd goto 1111 -C Contribution from the graph I. -cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) -cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) - if (calc_grad) then -C Explicit gradient in virtual-dihedral angles. - if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - if (l.eq.j+1) then - if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - else - if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - endif -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) - enddo - enddo - enddo -c goto 1112 - endif -c1111 continue -C Contribution from graph II - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) - if (calc_grad) then -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - if (l.eq.j+1) then - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - else - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - endif -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) - enddo - enddo - enddo -cd goto 1112 - endif -cd1111 continue - if (l.eq.j+1) then -cd goto 1110 -C Parallel orientation -C Contribution from graph III - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) - if (calc_grad) then -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) - call transpose2(EUgder(1,1,l),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) - enddo - enddo - enddo -cd goto 1112 - endif -C Contribution from graph IV -cd1110 continue - call transpose2(EE(1,1,itl),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l)) - if (calc_grad) then -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l)) - enddo - enddo - enddo - endif - else -C Antiparallel orientation -C Contribution from graph III -c goto 1110 - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) - if (calc_grad) then -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) - call transpose2(EUgder(1,1,j),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) - enddo - enddo - enddo -cd goto 1112 - endif -C Contribution from graph IV -1110 continue - call transpose2(EE(1,1,itj),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) - if (calc_grad) then -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) - enddo - enddo - enddo - endif - endif -1112 continue - eel5=eello5_1+eello5_2+eello5_3+eello5_4 -cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then -cd write (2,*) 'ijkl',i,j,k,l -cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, -cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 -cd endif -cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num -cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num -cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num -cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num - if (calc_grad) then - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 -cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont - do ll=1,3 - ggg1(ll)=eel5*g_contij(ll,1) - ggg2(ll)=eel5*g_contij(ll,2) -cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) - ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1) - gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) - gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1) - gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) -cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) - ghalf=0.5d0*ggg2(ll) -cd ghalf=0.0d0 - gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) - gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) - gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) - gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) - enddo -cd goto 1112 - do m=i+1,j-1 - do ll=1,3 -cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) - gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) - enddo - enddo - do m=k+1,l-1 - do ll=1,3 -cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) - gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) - enddo - enddo -c1112 continue - do m=i+2,j2 - do ll=1,3 - gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) - enddo - enddo - do m=k+2,l2 - do ll=1,3 - gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) - enddo - enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr5_loc(iii) -cd enddo - endif - eello5=ekont*eel5 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello5',ekont*eel5 - return - end -c-------------------------------------------------------------------------- - double precision function eello6(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - eello6_1=0.0d0 - eello6_2=0.0d0 - eello6_3=0.0d0 - eello6_4=0.0d0 - eello6_5=0.0d0 - eello6_6=0.0d0 -cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, -cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - if (l.eq.j+1) then - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(j,i,l,k,2,.false.) - eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) - eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) - else - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(l,k,j,i,2,.true.) - eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - if (wturn6.eq.0.0d0 .or. j.ne.i+4) then - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) - else - eello6_5=0.0d0 - endif - eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) - endif -C If turn contributions are considered, they will be handled separately. - eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 -cd write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num -cd write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num -cd write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num -cd write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num -cd write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num -cd write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num -cd goto 1112 - if (calc_grad) then - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 - ggg1(ll)=eel6*g_contij(ll,1) - ggg2(ll)=eel6*g_contij(ll,2) -cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) - ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1) - gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) - gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1) - gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) - ghalf=0.5d0*ggg2(ll) -cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) -cd ghalf=0.0d0 - gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2) - gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) - gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2) - gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) - enddo -cd goto 1112 - do m=i+1,j-1 - do ll=1,3 -cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) - gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) - enddo - enddo - do m=k+1,l-1 - do ll=1,3 -cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) - gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) - enddo - enddo -1112 continue - do m=i+2,j2 - do ll=1,3 - gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) - enddo - enddo - do m=k+2,l2 - do ll=1,3 - gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) - enddo - enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr6_loc(iii) -cd enddo - endif - eello6=ekont*eel6 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello6',ekont*eel6 - return - end -c-------------------------------------------------------------------------- - double precision function eello6_graph1(i,j,k,l,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) - logical swap - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ /j\ C -C / \ / \ C -C /| o | | o |\ C -C \ j|/k\| / \ |/k\|l / C -C \ / \ / \ / \ / C -C o o o o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - itk=itortyp(itype(k)) - s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) - vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 - eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) - if (.not. calc_grad) return - if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) - & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) - & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) - & +scalar2(vv(1),Dtobr2der(1,i))) - call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) - vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) - if (l.eq.j+1) then - g_corr6_loc(l-1)=g_corr6_loc(l-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - endif - call transpose2(EUgCder(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) - & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) - & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) - do iii=1,2 - if (swap) then - ind=3-iii - else - ind=iii - endif - do kkk=1,5 - do lll=1,3 - s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) - & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) - vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) - & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) - derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph2(i,j,k,l,jj,kk,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - logical swap - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxvec2(2),auxmat1(2,2) - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C \ /l\ /j\ / C -C \ / \ / \ / C -C o| o | | o |o C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l -C AL 7/4/01 s1 would occur in the sixth-order moment, -C but not in a cluster cumulant -#ifdef MOMENT - s1=dip(1,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph2=-(s1+s2+s3+s4) -#else - eello6_graph2=-(s2+s3+s4) -#endif -c eello6_graph2=-s3 - if (.not. calc_grad) return -C Derivatives in gamma(i-1) - if (i.gt.1) then -#ifdef MOMENT - s1=dipderg(1,jj,i)*dip(1,kk,k) -#endif - s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) - call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) -#ifdef MOMENT - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) -#endif -c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 - endif -C Derivatives in gamma(k-1) -#ifdef MOMENT - s1=dip(1,jj,i)*dipderg(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif -c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 -C Derivatives in gamma(j-1) or gamma(l-1) - if (j.gt.1) then -#ifdef MOMENT - s1=dipderg(3,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) - call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - if (swap) then - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 - else - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 - endif -#endif - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) -c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 - endif -C Derivatives in gamma(l-1) or gamma(j-1) - if (l.gt.1) then -#ifdef MOMENT - s1=dip(1,jj,i)*dipderg(3,kk,k) -#endif - call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - if (swap) then - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 - else - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 - endif -#endif - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) -c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 - endif -C Cartesian derivatives. - if (lprn) then - write (2,*) 'In eello6_graph2' - do iii=1,2 - write (2,*) 'iii=',iii - do kkk=1,5 - write (2,*) 'kkk=',kkk - do jjj=1,2 - write (2,'(3(2f10.5),5x)') - & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) - enddo - enddo - enddo - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) - else - s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) - endif -#endif - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), - & auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), - & auxvec(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph3(i,j,k,l,jj,kk,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C j|/k\| / |/k\|l / C -C / \ / / \ / C -C / o / o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. - iti=itortyp(itype(i)) -c if (j.lt.nres-1) then - if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) -c if (l.lt.nres-1) then - if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -#ifdef MOMENT - s1=dip(4,jj,i)*dip(4,kk,k) -#endif - call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph3=-(s1+s2+s3+s4) -#else - eello6_graph3=-(s2+s3+s4) -#endif -c eello6_graph3=-s4 - if (.not. calc_grad) return -C Derivatives in gamma(k-1) - call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) -C Derivatives in gamma(l-1) - call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) -C Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) - else - s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif -c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxmat1(2,2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o \ o \ C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. -cd write (2,*) 'eello_graph4: wturn6',wturn6 - iti=itortyp(itype(i)) - itj=itortyp(itype(j)) -c if (j.lt.nres-1) then - if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) -c if (k.lt.nres-1) then - if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then - itk1=itortyp(itype(k+1)) - else - itk1=ntortyp+1 - endif - itl=itortyp(itype(l)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l -cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, -cd & ' itl',itl,' itl1',itl1 -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dip(3,kk,k) - else - s1=dip(2,jj,j)*dip(2,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph4=-(s1+s2+s3+s4) -#else - eello6_graph4=-(s2+s3+s4) -#endif - if (.not. calc_grad) return -C Derivatives in gamma(i-1) - if (i.gt.1) then -#ifdef MOMENT - if (imat.eq.1) then - s1=dipderg(2,jj,i)*dip(3,kk,k) - else - s1=dipderg(4,jj,j)*dip(2,kk,l) - endif -#endif - s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -cd write (2,*) 'turn6 derivatives' -#ifdef MOMENT - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) -#endif - endif - endif -C Derivatives in gamma(k-1) -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderg(2,kk,k) - else - s1=dip(2,jj,j)*dipderg(4,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif - endif -C Derivatives in gamma(j-1) or gamma(l-1) - if (l.eq.j+1 .and. l.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) - else if (j.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then - gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) - endif - endif -C Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - if (imat.eq.1) then - s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) - else - s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) - endif - else - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) - else - s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) - endif - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), - & auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), - & b1(1,itj1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) - else - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), - & b1(1,itl1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) - endif - call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (swap) then - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s1+s2+s4) -#else - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s2+s4) -#endif - derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 - else -#ifdef MOMENT - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) -#else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) -#endif - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - else -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (l.eq.j+1) then - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - endif - endif - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello_turn6(i,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'sizesclu.dat' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), - & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), - & ggg1(3),ggg2(3) - double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), - & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) -C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to -C the respective energy moment and not to the cluster cumulant. - eello_turn6=0.0d0 - j=i+4 - k=i+1 - l=i+3 - iti=itortyp(itype(i)) - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) -cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj -cd write (2,*) 'i',i,' k',k,' j',j,' l',l -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l -cd call checkint_turn6(i,jj,kk,eel_turn6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx_turn(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) -cd eello6_5=0.0d0 -cd write (2,*) 'eello6_5',eello6_5 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) - ss1=scalar2(Ub2(1,i+2),b1(1,itl)) - s1 = (auxmat(1,1)+auxmat(2,2))*ss1 -#else - s1 = 0.0d0 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) - s2 = scalar2(b1(1,itk),vtemp1(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atemp(1,1)) - call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) - call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) - s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#else - s8=0.0d0 -#endif - call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) - s12 = scalar2(Ub2(1,i+2),vtemp3(1)) -#ifdef MOMENT - call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) - call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) - call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) - ss13 = scalar2(b1(1,itk),vtemp4(1)) - s13 = (gtemp(1,1)+gtemp(2,2))*ss13 -#else - s13=0.0d0 -#endif -c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 -c s1=0.0d0 -c s2=0.0d0 -c s8=0.0d0 -c s12=0.0d0 -c s13=0.0d0 - eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) - if (calc_grad) then -C Derivatives in gamma(i+2) -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 - call transpose2(AEAderg(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#else - s8d=0.0d0 -#endif - call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 - gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) -C Derivatives in gamma(i+3) -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d -#else - s1d=0.0d0 -#endif - call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) - s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) -#endif - s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#else - s13d=0.0d0 -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) - & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) - & -0.5d0*ekont*(s2d+s12d) -#endif -C Derivatives in gamma(i+4) - call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#else - s13d = 0.0d0 -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -C s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) -#else - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) -#endif -C Derivatives in gamma(i+5) -#ifdef MOMENT - call transpose2(AEAderg(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#else - s1d = 0.0d0 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#else - s8d = 0.0d0 -#endif - call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d -#else - s13d = 0.0d0 -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) - & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) - & -0.5d0*ekont*(s2d+s12d) -#endif -C Cartesian derivatives - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#else - s1d = 0.0d0 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), - & vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))* - & scalar2(cc(1,1,itl),vtemp2(1)) -#else - s8d = 0.0d0 -#endif - call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), - & auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) - & - 0.5d0*(s1d+s2d) -#else - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) - & - 0.5d0*s2d -#endif -#ifdef MOMENT - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) - & - 0.5d0*(s8d+s12d) -#else - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) - & - 0.5d0*s12d -#endif - enddo - enddo - enddo -#ifdef MOMENT - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), - & achuj_tempd(1,1)) - call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d=(gtempd(1,1)+gtempd(2,2))*ss13 - derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), - & vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d - derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d - enddo - enddo -#endif -cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', -cd & 16*eel_turn6_num -cd goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 - ggg1(ll)=eel_turn6*g_contij(ll,1) - ggg2(ll)=eel_turn6*g_contij(ll,2) - ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf - & +ekont*derx_turn(ll,2,1) - gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) - gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf - & +ekont*derx_turn(ll,4,1) - gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) - ghalf=0.5d0*ggg2(ll) -cd ghalf=0.0d0 - gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf - & +ekont*derx_turn(ll,2,2) - gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) - gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf - & +ekont*derx_turn(ll,4,2) - gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) - enddo -cd goto 1112 - do m=i+1,j-1 - do ll=1,3 - gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) - enddo - enddo - do m=k+1,l-1 - do ll=1,3 - gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) - enddo - enddo -1112 continue - do m=i+2,j2 - do ll=1,3 - gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) - enddo - enddo - do m=k+2,l2 - do ll=1,3 - gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) - enddo - enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr6_loc(iii) -cd enddo - endif - eello_turn6=ekont*eel_turn6 -cd write (2,*) 'ekont',ekont -cd write (2,*) 'eel_turn6',ekont*eel_turn6 - return - end -crc------------------------------------------------- - SUBROUTINE MATVEC2(A1,V1,V2) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),V1(2),V2(2) -c DO 1 I=1,2 -c VI=0.0 -c DO 3 K=1,2 -c 3 VI=VI+A1(I,K)*V1(K) -c Vaux(I)=VI -c 1 CONTINUE - - vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) - vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) - - v2(1)=vaux1 - v2(2)=vaux2 - END -C--------------------------------------- - SUBROUTINE MATMAT2(A1,A2,A3) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),A2(2,2),A3(2,2) -c DIMENSION AI3(2,2) -c DO J=1,2 -c A3IJ=0.0 -c DO K=1,2 -c A3IJ=A3IJ+A1(I,K)*A2(K,J) -c enddo -c A3(I,J)=A3IJ -c enddo -c enddo - - ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) - ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) - ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) - ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) - - A3(1,1)=AI3_11 - A3(2,1)=AI3_21 - A3(1,2)=AI3_12 - A3(2,2)=AI3_22 - END - -c------------------------------------------------------------------------- - double precision function scalar2(u,v) - implicit none - double precision u(2),v(2) - double precision sc - integer i - scalar2=u(1)*v(1)+u(2)*v(2) - return - end - -C----------------------------------------------------------------------------- - - subroutine transpose2(a,at) - implicit none - double precision a(2,2),at(2,2) - at(1,1)=a(1,1) - at(1,2)=a(2,1) - at(2,1)=a(1,2) - at(2,2)=a(2,2) - return - end -c-------------------------------------------------------------------------- - subroutine transpose(n,a,at) - implicit none - integer n,i,j - double precision a(n,n),at(n,n) - do i=1,n - do j=1,n - at(j,i)=a(i,j) - enddo - enddo - return - end -C--------------------------------------------------------------------------- - subroutine prodmat3(a1,a2,kk,transp,prod) - implicit none - integer i,j - double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) - logical transp -crc double precision auxmat(2,2),prod_(2,2) - - if (transp) then -crc call transpose2(kk(1,1),auxmat(1,1)) -crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) - - else -crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) - - endif -c call transpose2(a2(1,1),a2t(1,1)) - -crc print *,transp -crc print *,((prod_(i,j),i=1,2),j=1,2) -crc print *,((prod(i,j),i=1,2),j=1,2) - - return - end -C----------------------------------------------------------------------------- - double precision function scalar(u,v) - implicit none - double precision u(3),v(3) - double precision sc - integer i - sc=0.0d0 - do i=1,3 - sc=sc+u(i)*v(i) - enddo - scalar=sc - return - end -C----------------------------------------------------------------------- - double precision function sscale(r) - double precision r,gamm - include "COMMON.SPLITELE" - if(r.lt.r_cut-rlamb) then - sscale=1.0d0 - else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then - gamm=(r-(r_cut-rlamb))/rlamb - sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0) - else - sscale=0d0 - endif - return - end -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - double precision function sscagrad(r) - double precision r,gamm - include "COMMON.SPLITELE" - if(r.lt.r_cut-rlamb) then - sscagrad=0.0d0 - else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then - gamm=(r-(r_cut-rlamb))/rlamb - sscagrad=gamm*(6*gamm-6.0d0)/rlamb - else - sscagrad=0.0d0 - endif - return - end -C----------------------------------------------------------------------- -C first for shielding is setting of function of side-chains - subroutine set_shield_fac2 - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.SHIELD' - include 'COMMON.INTERACT' -C this is the squar root 77 devided by 81 the epislion in lipid (in protein) - double precision div77_81/0.974996043d0/, - &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) - -C the vector between center of side_chain and peptide group - double precision pep_side(3),long,side_calf(3), - &pept_group(3),costhet_grad(3),cosphi_grad_long(3), - &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) -C the line belowe needs to be changed for FGPROC>1 - do i=1,nres-1 - if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle - ishield_list(i)=0 -Cif there two consequtive dummy atoms there is no peptide group between them -C the line below has to be changed for FGPROC>1 - VolumeTotal=0.0 - do k=1,nres - if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle - dist_pep_side=0.0 - dist_side_calf=0.0 - do j=1,3 -C first lets set vector conecting the ithe side-chain with kth side-chain - pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0 -C pep_side(j)=2.0d0 -C and vector conecting the side-chain with its proper calfa - side_calf(j)=c(j,k+nres)-c(j,k) -C side_calf(j)=2.0d0 - pept_group(j)=c(j,i)-c(j,i+1) -C lets have their lenght - dist_pep_side=pep_side(j)**2+dist_pep_side - dist_side_calf=dist_side_calf+side_calf(j)**2 - dist_pept_group=dist_pept_group+pept_group(j)**2 - enddo - dist_pep_side=dsqrt(dist_pep_side) - dist_pept_group=dsqrt(dist_pept_group) - dist_side_calf=dsqrt(dist_side_calf) - do j=1,3 - pep_side_norm(j)=pep_side(j)/dist_pep_side - side_calf_norm(j)=dist_side_calf - enddo -C now sscale fraction - sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield -C print *,buff_shield,"buff" -C now sscale - if (sh_frac_dist.le.0.0) cycle -C If we reach here it means that this side chain reaches the shielding sphere -C Lets add him to the list for gradient - ishield_list(i)=ishield_list(i)+1 -C ishield_list is a list of non 0 side-chain that contribute to factor gradient -C this list is essential otherwise problem would be O3 - shield_list(ishield_list(i),i)=k -C Lets have the sscale value - if (sh_frac_dist.gt.1.0) then - scale_fac_dist=1.0d0 - do j=1,3 - sh_frac_dist_grad(j)=0.0d0 - enddo - else - scale_fac_dist=-sh_frac_dist*sh_frac_dist - & *(2.0d0*sh_frac_dist-3.0d0) - fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) - & /dist_pep_side/buff_shield*0.5d0 -C remember for the final gradient multiply sh_frac_dist_grad(j) -C for side_chain by factor -2 ! - do j=1,3 - sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) -C sh_frac_dist_grad(j)=0.0d0 -C scale_fac_dist=1.0d0 -C print *,"jestem",scale_fac_dist,fac_help_scale, -C & sh_frac_dist_grad(j) - enddo - endif -C this is what is now we have the distance scaling now volume... - short=short_r_sidechain(itype(k)) - long=long_r_sidechain(itype(k)) - costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2) - sinthet=short/dist_pep_side*costhet -C now costhet_grad -C costhet=0.6d0 -C sinthet=0.8 - costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4 -C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet -C & -short/dist_pep_side**2/costhet) -C costhet_fac=0.0d0 - do j=1,3 - costhet_grad(j)=costhet_fac*pep_side(j) - enddo -C remember for the final gradient multiply costhet_grad(j) -C for side_chain by factor -2 ! -C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1 -C pep_side0pept_group is vector multiplication - pep_side0pept_group=0.0d0 - do j=1,3 - pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j) - enddo - cosalfa=(pep_side0pept_group/ - & (dist_pep_side*dist_side_calf)) - fac_alfa_sin=1.0d0-cosalfa**2 - fac_alfa_sin=dsqrt(fac_alfa_sin) - rkprim=fac_alfa_sin*(long-short)+short -C rkprim=short - -C now costhet_grad - cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2) -C cosphi=0.6 - cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4 - sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ - & dist_pep_side**2) -C sinphi=0.8 - do j=1,3 - cosphi_grad_long(j)=cosphi_fac*pep_side(j) - &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) - &*(long-short)/fac_alfa_sin*cosalfa/ - &((dist_pep_side*dist_side_calf))* - &((side_calf(j))-cosalfa* - &((pep_side(j)/dist_pep_side)*dist_side_calf)) -C cosphi_grad_long(j)=0.0d0 - cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) - &*(long-short)/fac_alfa_sin*cosalfa - &/((dist_pep_side*dist_side_calf))* - &(pep_side(j)- - &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side) -C cosphi_grad_loc(j)=0.0d0 - enddo -C print *,sinphi,sinthet - VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) - & /VSolvSphere_div -C & *wshield -C now the gradient... - do j=1,3 - grad_shield(j,i)=grad_shield(j,i) -C gradient po skalowaniu - & +(sh_frac_dist_grad(j)*VofOverlap -C gradient po costhet - & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* - &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( - & sinphi/sinthet*costhet*costhet_grad(j) - & +sinthet/sinphi*cosphi*cosphi_grad_long(j))) - & )*wshield -C grad_shield_side is Cbeta sidechain gradient - grad_shield_side(j,ishield_list(i),i)= - & (sh_frac_dist_grad(j)*-2.0d0 - & *VofOverlap - & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0* - &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( - & sinphi/sinthet*costhet*costhet_grad(j) - & +sinthet/sinphi*cosphi*cosphi_grad_long(j))) - & )*wshield - - grad_shield_loc(j,ishield_list(i),i)= - & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0* - &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*( - & sinthet/sinphi*cosphi*cosphi_grad_loc(j) - & )) - & *wshield - enddo - VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist - enddo - fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield) -C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i) - enddo - return - end -C first for shielding is setting of function of side-chains - subroutine set_shield_fac - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.SHIELD' - include 'COMMON.INTERACT' -C this is the squar root 77 devided by 81 the epislion in lipid (in protein) - double precision div77_81/0.974996043d0/, - &div4_81/0.2222222222d0/,sh_frac_dist_grad(3) - -C the vector between center of side_chain and peptide group - double precision pep_side(3),long,side_calf(3), - &pept_group(3),costhet_grad(3),cosphi_grad_long(3), - &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3) -C the line belowe needs to be changed for FGPROC>1 - do i=1,nres-1 - if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle - ishield_list(i)=0 -Cif there two consequtive dummy atoms there is no peptide group between them -C the line below has to be changed for FGPROC>1 - VolumeTotal=0.0 - do k=1,nres - if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle - dist_pep_side=0.0 - dist_side_calf=0.0 - do j=1,3 -C first lets set vector conecting the ithe side-chain with kth side-chain - pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0 -C pep_side(j)=2.0d0 -C and vector conecting the side-chain with its proper calfa - side_calf(j)=c(j,k+nres)-c(j,k) -C side_calf(j)=2.0d0 - pept_group(j)=c(j,i)-c(j,i+1) -C lets have their lenght - dist_pep_side=pep_side(j)**2+dist_pep_side - dist_side_calf=dist_side_calf+side_calf(j)**2 - dist_pept_group=dist_pept_group+pept_group(j)**2 - enddo - dist_pep_side=dsqrt(dist_pep_side) - dist_pept_group=dsqrt(dist_pept_group) - dist_side_calf=dsqrt(dist_side_calf) - do j=1,3 - pep_side_norm(j)=pep_side(j)/dist_pep_side - side_calf_norm(j)=dist_side_calf - enddo -C now sscale fraction - sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield -C print *,buff_shield,"buff" -C now sscale - if (sh_frac_dist.le.0.0) cycle -C If we reach here it means that this side chain reaches the shielding sphere -C Lets add him to the list for gradient - ishield_list(i)=ishield_list(i)+1 -C ishield_list is a list of non 0 side-chain that contribute to factor gradient -C this list is essential otherwise problem would be O3 - shield_list(ishield_list(i),i)=k -C Lets have the sscale value - if (sh_frac_dist.gt.1.0) then - scale_fac_dist=1.0d0 - do j=1,3 - sh_frac_dist_grad(j)=0.0d0 - enddo - else - scale_fac_dist=-sh_frac_dist*sh_frac_dist - & *(2.0*sh_frac_dist-3.0d0) - fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2) - & /dist_pep_side/buff_shield*0.5 -C remember for the final gradient multiply sh_frac_dist_grad(j) -C for side_chain by factor -2 ! - do j=1,3 - sh_frac_dist_grad(j)=fac_help_scale*pep_side(j) -C print *,"jestem",scale_fac_dist,fac_help_scale, -C & sh_frac_dist_grad(j) - enddo - endif -C if ((i.eq.3).and.(k.eq.2)) then -C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist -C & ,"TU" -C endif - -C this is what is now we have the distance scaling now volume... - short=short_r_sidechain(itype(k)) - long=long_r_sidechain(itype(k)) - costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2) -C now costhet_grad -C costhet=0.0d0 - costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4 -C costhet_fac=0.0d0 - do j=1,3 - costhet_grad(j)=costhet_fac*pep_side(j) - enddo -C remember for the final gradient multiply costhet_grad(j) -C for side_chain by factor -2 ! -C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1 -C pep_side0pept_group is vector multiplication - pep_side0pept_group=0.0 - do j=1,3 - pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j) - enddo - cosalfa=(pep_side0pept_group/ - & (dist_pep_side*dist_side_calf)) - fac_alfa_sin=1.0-cosalfa**2 - fac_alfa_sin=dsqrt(fac_alfa_sin) - rkprim=fac_alfa_sin*(long-short)+short -C now costhet_grad - cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2) - cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4 - - do j=1,3 - cosphi_grad_long(j)=cosphi_fac*pep_side(j) - &+cosphi**3*0.5/dist_pep_side**2*(-rkprim) - &*(long-short)/fac_alfa_sin*cosalfa/ - &((dist_pep_side*dist_side_calf))* - &((side_calf(j))-cosalfa* - &((pep_side(j)/dist_pep_side)*dist_side_calf)) - - cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim) - &*(long-short)/fac_alfa_sin*cosalfa - &/((dist_pep_side*dist_side_calf))* - &(pep_side(j)- - &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side) - enddo - - VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi) - & /VSolvSphere_div - & *wshield -C now the gradient... -C grad_shield is gradient of Calfa for peptide groups -C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist, -C & costhet,cosphi -C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group, -C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k) - do j=1,3 - grad_shield(j,i)=grad_shield(j,i) -C gradient po skalowaniu - & +(sh_frac_dist_grad(j) -C gradient po costhet - &-scale_fac_dist*costhet_grad(j)/(1.0-costhet) - &-scale_fac_dist*(cosphi_grad_long(j)) - &/(1.0-cosphi) )*div77_81 - &*VofOverlap -C grad_shield_side is Cbeta sidechain gradient - grad_shield_side(j,ishield_list(i),i)= - & (sh_frac_dist_grad(j)*-2.0d0 - & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet) - & +scale_fac_dist*(cosphi_grad_long(j)) - & *2.0d0/(1.0-cosphi)) - & *div77_81*VofOverlap - - grad_shield_loc(j,ishield_list(i),i)= - & scale_fac_dist*cosphi_grad_loc(j) - & *2.0d0/(1.0-cosphi) - & *div77_81*VofOverlap - enddo - VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist - enddo - fac_shield(i)=VolumeTotal*div77_81+div4_81 -C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i) - enddo - return - end -C-------------------------------------------------------------------------- -C----------------------------------------------------------------------- - double precision function sscalelip(r) - double precision r,gamm - include "COMMON.SPLITELE" -C if(r.lt.r_cut-rlamb) then -C sscale=1.0d0 -C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then -C gamm=(r-(r_cut-rlamb))/rlamb - sscalelip=1.0d0+r*r*(2*r-3.0d0) -C else -C sscale=0d0 -C endif - return - end -C----------------------------------------------------------------------- - double precision function sscagradlip(r) - double precision r,gamm - include "COMMON.SPLITELE" -C if(r.lt.r_cut-rlamb) then -C sscagrad=0.0d0 -C else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then -C gamm=(r-(r_cut-rlamb))/rlamb - sscagradlip=r*(6*r-6.0d0) -C else -C sscagrad=0.0d0 -C endif - return - end - -C----------------------------------------------------------------------- -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - subroutine Eliptransfer(eliptran) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.CALC' - include 'COMMON.CONTROL' - include 'COMMON.SPLITELE' - include 'COMMON.SBRIDGE' -C this is done by Adasko -C print *,"wchodze" -C structure of box: -C water -C--bordliptop-- buffore starts -C--bufliptop--- here true lipid starts -C lipid -C--buflipbot--- lipid ends buffore starts -C--bordlipbot--buffore ends - eliptran=0.0 - write(iout,*) "I am in?" - do i=1,nres -C do i=1,1 - if (itype(i).eq.ntyp1) cycle - - positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize)) - if (positi.le.0) positi=positi+boxzsize -C print *,i -C first for peptide groups -c for each residue check if it is in lipid or lipid water border area - if ((positi.gt.bordlipbot) - &.and.(positi.lt.bordliptop)) then -C the energy transfer exist - if (positi.lt.buflipbot) then -C what fraction I am in - fracinbuf=1.0d0- - & ((positi-bordlipbot)/lipbufthick) -C lipbufthick is thickenes of lipid buffore - sslip=sscalelip(fracinbuf) - ssgradlip=-sscagradlip(fracinbuf)/lipbufthick - eliptran=eliptran+sslip*pepliptran - gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 - gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 -C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran - elseif (positi.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) - sslip=sscalelip(fracinbuf) - ssgradlip=sscagradlip(fracinbuf)/lipbufthick - eliptran=eliptran+sslip*pepliptran - gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0 - gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0 -C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran -C print *, "doing sscalefor top part" -C print *,i,sslip,fracinbuf,ssgradlip - else - eliptran=eliptran+pepliptran -C print *,"I am in true lipid" - endif -C else -C eliptran=elpitran+0.0 ! I am in water - endif - enddo -C print *, "nic nie bylo w lipidzie?" -C now multiply all by the peptide group transfer factor -C eliptran=eliptran*pepliptran -C now the same for side chains -CV do i=1,1 - do i=1,nres - if (itype(i).eq.ntyp1) cycle - positi=(mod(c(3,i+nres),boxzsize)) - if (positi.le.0) positi=positi+boxzsize -C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop -c for each residue check if it is in lipid or lipid water border area -C respos=mod(c(3,i+nres),boxzsize) -C print *,positi,bordlipbot,buflipbot - if ((positi.gt.bordlipbot) - & .and.(positi.lt.bordliptop)) then -C the energy transfer exist - if (positi.lt.buflipbot) then - fracinbuf=1.0d0- - & ((positi-bordlipbot)/lipbufthick) -C lipbufthick is thickenes of lipid buffore - sslip=sscalelip(fracinbuf) - ssgradlip=-sscagradlip(fracinbuf)/lipbufthick - eliptran=eliptran+sslip*liptranene(itype(i)) - gliptranx(3,i)=gliptranx(3,i) - &+ssgradlip*liptranene(itype(i)) - gliptranc(3,i-1)= gliptranc(3,i-1) - &+ssgradlip*liptranene(itype(i)) -C print *,"doing sccale for lower part" - elseif (positi.gt.bufliptop) then - fracinbuf=1.0d0- - &((bordliptop-positi)/lipbufthick) - sslip=sscalelip(fracinbuf) - ssgradlip=sscagradlip(fracinbuf)/lipbufthick - eliptran=eliptran+sslip*liptranene(itype(i)) - gliptranx(3,i)=gliptranx(3,i) - &+ssgradlip*liptranene(itype(i)) - gliptranc(3,i-1)= gliptranc(3,i-1) - &+ssgradlip*liptranene(itype(i)) -C print *, "doing sscalefor top part",sslip,fracinbuf - else - eliptran=eliptran+liptranene(itype(i)) -C print *,"I am in true lipid" - endif - endif ! if in lipid or buffor -C else -C eliptran=elpitran+0.0 ! I am in water - enddo - return - end -C------------------------------------------------------------------------------------- diff --git a/source/cluster/wham/src-HCD-5D/log b/source/cluster/wham/src-HCD-5D/log deleted file mode 100644 index 61146b3..0000000 --- a/source/cluster/wham/src-HCD-5D/log +++ /dev/null @@ -1,24 +0,0 @@ -gfortran -O -c -I. -Iinclude_unres -I/users/software/mpich2-1.0.7/include readpdb.f -cc -o compinfo compinfo.c -./compinfo | true -gfortran -O -c -I. -Iinclude_unres -I/users/software/mpich2-1.0.7/include cinfo.f -gfortran -O main_clust.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o matmult.o readrtns.o pinorm.o rescode.o intcor.o timing.o misc.o geomout.o readpdb.o read_coords.o parmread.o probabl.o fitsq.o hc.o track.o wrtclust.o srtclust.o noyes.o contact.o printmat.o int_from_cart1.o energy_p_new.o icant.o proc_proc.o work_partition.o setup_var.o read_ref_str.o gnmr1.o permut.o -L/users/software/mpich2-1.0.7/lib -lmpich -lpthread xdrf/libxdrf.a -o ../../../../bin/cluster/unres_clustMD-mult_ifort_MPICH_NEWCORR.exe -readrtns.o: In function `molread_': -readrtns.F:(.text+0x498f): relocation truncated to fit: R_X86_64_PC32 against symbol `torcnstr_' defined in COMMON section in readrtns.o -readrtns.F:(.text+0x49c6): relocation truncated to fit: R_X86_64_PC32 against symbol `torcnstr_' defined in COMMON section in readrtns.o -readrtns.F:(.text+0x49e9): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o -readrtns.F:(.text+0x4a06): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o -readrtns.F:(.text+0x4a23): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o -readrtns.F:(.text+0x4a40): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o -readrtns.F:(.text+0x4ae2): relocation truncated to fit: R_X86_64_PC32 against symbol `torcnstr_' defined in COMMON section in readrtns.o -readrtns.F:(.text+0x4b40): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o -readrtns.F:(.text+0x4b5d): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o -readrtns.F:(.text+0x4b7a): relocation truncated to fit: R_X86_64_32S against symbol `torcnstr_' defined in COMMON section in readrtns.o -readrtns.F:(.text+0x4b97): additional relocation overflows omitted from the output -energy_p_new.o: In function `egb_': -energy_p_new.F:(.text+0xfc29): undefined reference to `dyn_ssbond_ene_' -energy_p_new.F:(.text+0xfca0): undefined reference to `triple_ssbond_ene_' -energy_p_new.o: In function `etotal_': -energy_p_new.F:(.text+0x118fd): undefined reference to `dyn_set_nss_' -collect2: ld returned 1 exit status -make: *** [NEWCORR] Error 1 diff --git a/source/cluster/wham/src-HCD-5D/parmread.F b/source/cluster/wham/src-HCD-5D/parmread.F index c557764..8895504 100644 --- a/source/cluster/wham/src-HCD-5D/parmread.F +++ b/source/cluster/wham/src-HCD-5D/parmread.F @@ -846,8 +846,8 @@ c Dtilde(2,2,i)=0.0d0 EEold(2,2,-i)=-b(10,i)+b(11,i) EEold(2,1,-i)=-b(12,i)+b(13,i) EEold(1,2,-i)=-b(12,i)-b(13,i) -c write(iout,*) "TU DOCHODZE" -c print *,"JESTEM" + write(iout,*) "TU DOCHODZE" + print *,"JESTEM" c ee(1,1,i)=1.0d0 c ee(2,2,i)=1.0d0 c ee(2,1,i)=0.0d0 diff --git a/source/cluster/wham/src-HCD-5D/read_constr_homology.F b/source/cluster/wham/src-HCD-5D/read_constr_homology.F index 9268e50..defd236 100644 --- a/source/cluster/wham/src-HCD-5D/read_constr_homology.F +++ b/source/cluster/wham/src-HCD-5D/read_constr_homology.F @@ -36,11 +36,9 @@ c & sigma_odl_temp(maxres,maxres,max_template) c c FP - Nov. 2014 Temporary specifications for new vars c - double precision rescore_tmp,x12,y12,z12,rescore2_tmp, - & rescore3_tmp + double precision rescore_tmp,x12,y12,z12,rescore2_tmp double precision, dimension (max_template,maxres) :: rescore double precision, dimension (max_template,maxres) :: rescore2 - double precision, dimension (max_template,maxres) :: rescore3 character*24 tpl_k_rescore c ----------------------------------------------------------------- c Reading multiple PDB ref structures and calculation of retraints @@ -183,15 +181,14 @@ c write(iout,*) "tpl_k_rescore - ",tpl_k_rescore do irec=nnt,nct ! loop for reading res sim if (read2sigma) then read (ientin,*,end=1401) i_tmp,rescore2_tmp,rescore_tmp, - & rescore3_tmp,idomain_tmp + & idomain_tmp i_tmp=i_tmp+nnt-1 idomain(k,i_tmp)=idomain_tmp rescore(k,i_tmp)=rescore_tmp rescore2(k,i_tmp)=rescore2_tmp - rescore3(k,i_tmp)=rescore3_tmp - write(iout,'(a7,i5,3f10.5,i5)') "rescore", + write(iout,'(a7,i5,2f10.5,i5)') "rescore", & i_tmp,rescore2_tmp,rescore_tmp, - & rescore3_tmp,idomain_tmp + & idomain_tmp else idomain(k,irec)=1 read (ientin,*,end=1401) rescore_tmp @@ -357,7 +354,7 @@ c write (iout,*) "xxtpl(",k,i,") =",xxtpl(k,i) c write (iout,*) "yytpl(",k,i,") =",yytpl(k,i) c write (iout,*) "zztpl(",k,i,") =",zztpl(k,i) c write(iout,*) "rescore(",k,i,") =",rescore(k,i) - sigma_d(k,i)=rescore3(k,i) ! right expression ? + sigma_d(k,i)=rescore(k,i) ! right expression ? if (sigma_d(k,i).ne.0) & sigma_d(k,i)=1.0d0/(sigma_d(k,i)*sigma_d(k,i)) diff --git a/source/unres/src-HCD-5D/COMMON.BANK b/source/unres/src-HCD-5D/COMMON.BANK index 5b0fb34..2b9cff9 100644 --- a/source/unres/src-HCD-5D/COMMON.BANK +++ b/source/unres/src-HCD-5D/COMMON.BANK @@ -1,9 +1,11 @@ - real*8 dihang,etot,bvar,bene,rene,rvar,avedif,difmin, - & ebmin,ebmax,ebmaxt,cutdif,dij,dihang_in + double precision dihang,etot,bvar,bene,rene,rvar,avedif,difmin, + & ebmin,ebmax,ebmaxt,cutdif,dij,dihang_in,difcut,dele,rmscut, + & pnccut,rmsn,pncn,brmsn,rrmsn,bpncn,rpncn,parent,dihang_in2 integer ibank,is,jbank,ibmin,ibmax,nbank,nconf,iuse,nstep,icycle, & iseed,ntbank,ntbankm,iref,nconf_in,indb,ilastnstep, - & bvar_nss,bvar_ss,bvar_ns,bvar_s, - & nss_in,iss_in,jss_in,nadd + & bvar_nss,bvar_ss,bvar_ns,bvar_s,movenx,movernx,nstatnx, + & nstatnx_tot,nss_in,iss_in,jss_in,nadd,nss_out,iss_out,jss_out, + & isend2,iff_in,idata common/varin/dihang_in(mxang,maxres,mxch,mxio),nss_in(mxio), & iss_in(maxss,mxio),jss_in(maxss,mxio) common/minvar/dihang(mxang,maxres,mxch,mxio),etot(mxio),rmsn(mxio) diff --git a/source/unres/src-HCD-5D/COMMON.CHAIN b/source/unres/src-HCD-5D/COMMON.CHAIN index c394c5e..ec15fdc 100644 --- a/source/unres/src-HCD-5D/COMMON.CHAIN +++ b/source/unres/src-HCD-5D/COMMON.CHAIN @@ -1,6 +1,6 @@ integer nres,nsup,nstart_sup,nz_start,nz_end,iz_sc, & nres0,nstart_seq,nchain,chain_length,chain_border,iprzes, - & ireschain,tabpermchain,npermchain,afmend,afmbeg + & chain_border1,ireschain,tabpermchain,npermchain,afmend,afmbeg double precision c,dc,dc_old,d_c_work,xloc,xrot,dc_norm,t,r, & prod,rt,dc_work,cref,crefjlee,dc_norm2,velAFMconst, & totTafm,chomo @@ -15,7 +15,7 @@ & nsup,nstart_sup,nstart_seq,iprzes, & chain_length(maxchain),npermchain,ireschain(maxres), & tabpermchain(maxchain,maxperm), - & chain_border(2,maxchain),nchain + & chain_border(2,maxchain),chain_border1(2,maxchain),nchain common /from_zscore/ nz_start,nz_end,iz_sc double precision boxxsize,boxysize,boxzsize,enecut,sscut, & sss,sssgrad, diff --git a/source/unres/src-HCD-5D/COMMON.CONTACTS b/source/unres/src-HCD-5D/COMMON.CONTACTS index 45c578b..d5c2d2e 100644 --- a/source/unres/src-HCD-5D/COMMON.CONTACTS +++ b/source/unres/src-HCD-5D/COMMON.CONTACTS @@ -1,84 +1,4 @@ -C Change 12/1/95 - common block CONTACTS1 included. integer ncont,ncont_ref,icont,icont_ref,num_cont,jcont double precision facont,gacont common /contacts/ ncont,ncont_ref,icont(2,maxcont), & icont_ref(2,maxcont) - common /contacts1/ facont(maxconts,maxres), - & gacont(3,maxconts,maxres), - & num_cont(maxres),jcont(maxconts,maxres) -C 12/26/95 - H-bonding contacts - common /contacts_hb/ - & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), - & gacontp_hb3(3,maxconts,maxres), - & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), - & gacontm_hb3(3,maxconts,maxres), - & gacont_hbr(3,maxconts,maxres), - & grij_hb_cont(3,maxconts,maxres), - & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), - & ees0m(maxconts,maxres),d_cont(maxconts,maxres), - & num_cont_hb(maxres),jcont_hb(maxconts,maxres) -C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole -C interactions -c 7/25/08 Commented out; not needed when cumulants used -C Interactions of pseudo-dipoles generated by loc-el interactions. -c double precision dip,dipderg,dipderx -c common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), -c & dipderx(3,5,4,maxconts,maxres) -C 10/30/99 Added other pre-computed vectors and matrices needed -C to calculate three - six-order el-loc correlation terms - double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, - & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,gmu,gUb2 - & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der, - & gtEug - common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), - & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), - & obrot_der(2,maxres),obrot2_der(2,maxres) -C This common block contains vectors and matrices dependent on a single -C amino-acid residue. - common /precomp1/ mu(2,maxres),muder(2,maxres),Ub2(2,maxres), - & gmu(2,maxres),gUb2(2,maxres), - & Ub2der(2,maxres),Ctobr(2,maxres),Ctobrder(2,maxres), - & Dtobr2(2,maxres),Dtobr2der(2,maxres), - & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), - & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), - & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),gtEUg(2,2,maxres) -C This common block contains vectors and matrices dependent on two -C consecutive amino-acid residues. - double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, - & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder - common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), - & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), - & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), - & DtUg2EUg(2,2,maxres),Ug2DtEUg(2,2,maxres), - & Ug2DtEUgder(2,2,2,maxres),DtUg2EUgder(2,2,2,maxres) - double precision costab,sintab,costab2,sintab2 - common /rotat_old/ costab(maxres),sintab(maxres), - & costab2(maxres),sintab2(maxres) -C This common block contains dipole-interaction matrices and their -C Cartesian derivatives. - double precision a_chuj,a_chuj_der - common /dipmat/ a_chuj(2,2,maxconts,maxres), - & a_chuj_der(2,2,3,5,maxconts,maxres) - double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, - & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, - & AEAb2,AEAb2derg,AEAb2derx,g_contij,ekont - common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), - & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), - & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), - & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), - & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), - & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), - & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), - & g_contij(3,2),ekont -C 12/13/2008 (again Poland-Jaruzel war anniversary) -C RE: Parallelization of 4th and higher order loc-el correlations - integer ncont_sent,ncont_recv,iint_sent,iisent_local, - & itask_cont_from,itask_cont_to,ntask_cont_from,ntask_cont_to, - & nat_sent,iat_sent,iturn3_sent,iturn4_sent,iturn3_sent_local, - & iturn4_sent_local - common /contdistrib/ ncont_sent(maxres),ncont_recv(maxres), - & iint_sent(4,maxres,maxres),iint_sent_local(4,maxres,maxres), - & iturn3_sent(4,maxres),iturn4_sent(4,maxres), - & iturn3_sent_local(4,maxres),iturn4_sent_local(4,maxres), - & nat_sent,iat_sent(maxres),itask_cont_from(0:max_fg_procs-1), - & itask_cont_to(0:max_fg_procs-1),ntask_cont_from,ntask_cont_to diff --git a/source/unres/src-HCD-5D/COMMON.CONTROL b/source/unres/src-HCD-5D/COMMON.CONTROL index 0a21e09..da8581a 100644 --- a/source/unres/src-HCD-5D/COMMON.CONTROL +++ b/source/unres/src-HCD-5D/COMMON.CONTROL @@ -1,32 +1,25 @@ +! This common block contains general variables controlling the calculations +! and output level. +!... energy_dec = .true. means print energy decomposition matrix integer modecalc,iscode,indpdb,indback,indphi,iranconf,icheckgrad, & inprint,i2ndstr,mucadyn,constr_dist,symetr,AFMlog,selfguide, & shield_mode,tor_mode,tubelog,constr_homology,homol_nset, - & nsaxs,saxs_mode,iprint + & iprint +!... minim = .true. means DO minimization. logical minim,refstr,pdbref,outpdb,outmol2,overlapsc,energy_dec, - & mremd_dec,sideadd,lsecondary,read_cart,unres_pdb, - & vdisulf,searchsc,lmuca,dccart,extconf,out1file, + & mremd_dec,sideadd,lsecondary,read_cart,unres_pdb,out_cart, + & out_int,vdisulf,searchsc,lmuca,dccart,extconf,out1file,gmatout, & gnorm_check,gradout,split_ene,with_theta_constr, & with_dihed_constr,read2sigma,start_from_model,read_homol_frag, - & out_template_coord,out_template_restr - real*8 Psaxs(maxsaxs),distsaxs(maxsaxs),CSAXS(3,maxsaxs),wsaxs0, - & scal_rad, saxs_cutoff - real*8 waga_homology - real*8 waga_dist, waga_angle, waga_theta, waga_d, dist_cut, - & dist2_cut + & out_template_coord,out_template_restr,usampl,loc_qlike,adaptive double precision aincr common /cntrl/ aincr,modecalc,iscode,indpdb,indback,indphi, & iranconf, & icheckgrad,minim,i2ndstr,refstr,pdbref,outpdb,outmol2,iprint, & overlapsc,energy_dec,mremd_dec,sideadd,lsecondary,read_cart, - & unres_pdb,vdisulf,searchsc,lmuca,dccart,mucadyn,extconf,out1file, - & selfguide,AFMlog,shield_mode,tor_mode,tubelog, - & constr_dist,gnorm_check,gradout,split_ene,with_theta_constr, - & with_dihed_constr,symetr, - & constr_homology,homol_nset,read2sigma,start_from_model, + & unres_pdb,out_cart,out_int,vdisulf,searchsc,lmuca,dccart,mucadyn, + & extconf,out1file,gmatout,selfguide,AFMlog,shield_mode,tor_mode, + & tubelog,constr_dist,gnorm_check,gradout,split_ene, + & with_theta_constr,with_dihed_constr,symetr,usampl,loc_qlike, + & adaptive,constr_homology,homol_nset,read2sigma,start_from_model, & read_homol_frag,out_template_coord,out_template_restr - common /homol/ waga_homology(maxprocs/20), - & waga_dist, waga_angle, waga_theta, waga_d, dist_cut,dist2_cut - common /saxsretr/Psaxs,distsaxs,csaxs,Wsaxs0,scal_rad,saxs_cutoff, - & nsaxs,saxs_mode -C... minim = .true. means DO minimization. -C... energy_dec = .true. means print energy decomposition matrix diff --git a/source/unres/src-HCD-5D/COMMON.CSA b/source/unres/src-HCD-5D/COMMON.CSA index 273a268..5cd0019 100644 --- a/source/unres/src-HCD-5D/COMMON.CSA +++ b/source/unres/src-HCD-5D/COMMON.CSA @@ -1,5 +1,7 @@ - integer ngroup,igroup,ntotgr,numch,irestart,ndiff - double precision diffcut + integer ngroup,igroup,ntotgr,numch,irestart,ndiff,nglob_csa, + & nmin_csa,n1,n2,n3,n4,n5,n6,n7,n8,n9,n14,n15,n16,n17,n18,n0, + & is1,is2,nseed,ntotal,icmax,nstmax,nran0,nran1,irr,jstart,jend + double precision diffcut,eglob_csa,estop,cut1,cut2,rdih_bias common/alphaa/ ngroup(mxgr),igroup(3,mxang,mxgr),ntotgr,numch common/csa_input/cut1,cut2,eglob_csa,estop,jstart,jend, & n1,n2,n3,n4,n5,n6,n7,n8,n9,n14,n15,n16,n17,n18,n0, diff --git a/source/unres/src-HCD-5D/COMMON.DBASE b/source/unres/src-HCD-5D/COMMON.DBASE index 4f07780..c821608 100644 --- a/source/unres/src-HCD-5D/COMMON.DBASE +++ b/source/unres/src-HCD-5D/COMMON.DBASE @@ -1,3 +1,5 @@ + character*8 str_nam + double precision cart_base + integer nres_base,nseq common /struct/ cart_base(3,maxres_base,maxseq),str_nam(maxseq), & nres_base(3,maxseq),nseq - character*8 str_nam diff --git a/source/unres/src-HCD-5D/COMMON.DERIV b/source/unres/src-HCD-5D/COMMON.DERIV index 217b76c..1c39ed1 100644 --- a/source/unres/src-HCD-5D/COMMON.DERIV +++ b/source/unres/src-HCD-5D/COMMON.DERIV @@ -13,7 +13,9 @@ & gshieldc_ll, gshieldc_loc_ll double precision gdfad,gdfat,gdfan,gdfab integer nfl,icg - common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), +c common /derivat/ dcdv(6,maxdim),dxdv(6,maxdim),dxds(6,maxres), +c 3/12/20 Adam: Arrays dcdv, dxdv, and dxds removed following recoding of gradient. + common /derivat/ & gradx(3,-1:maxres,2),gradc(3,-1:maxres,2),gvdwx(3,-1:maxres), & gvdwc(3,-1:maxres),gelc(3,-1:maxres),gelc_long(3,-1:maxres), & gvdwpp(3,-1:maxres),gvdwc_scpp(3,-1:maxres), diff --git a/source/unres/src-HCD-5D/COMMON.DISTFIT b/source/unres/src-HCD-5D/COMMON.DISTFIT index 044225b..9f2a302 100644 --- a/source/unres/src-HCD-5D/COMMON.DISTFIT +++ b/source/unres/src-HCD-5D/COMMON.DISTFIT @@ -1,14 +1,10 @@ + integer maxres22 c parameter (maxres22=maxres*(maxres+1)/2) parameter (maxres22=1) double precision w,d0,DRDG,DD,H,XX - integer nbfrag,bfrag,nhfrag,hfrag,bvar_frag,hvar_frag,nhpb0, - 1 lvar_frag,svar_frag,avar_frag - COMMON /c_frag/ nbfrag,bfrag(4,maxres/3),nhfrag,hfrag(2,maxres/3) - COMMON /frag/ bvar_frag(mxio,6),hvar_frag(mxio,3), - 1 lvar_frag(mxio,3),svar_frag(mxio,3), - 2 avar_frag(mxio,5) COMMON /WAGI/ w(MAXRES22),d0(MAXRES22) - COMMON /POCHODNE/ NX,NY,DRDG(MAXRES22,MAXRES),DD(MAXRES22), + integer nx,ny,mask + COMMON /POCHODNE/ NX,NY,DRDG(MAXRES22,MAXRES),DD(MAXRES22), 1 H(MAXRES,MAXRES),XX(MAXRES) COMMON /frozen/ mask(maxres) COMMON /store0/ nhpb0 diff --git a/source/unres/src-HCD-5D/COMMON.INFO b/source/unres/src-HCD-5D/COMMON.INFO index 4f63708..6976616 100644 --- a/source/unres/src-HCD-5D/COMMON.INFO +++ b/source/unres/src-HCD-5D/COMMON.INFO @@ -1,7 +1,7 @@ c NPROCS - total number of processors; c MyID - processor's ID; c MasterID - master processor's ID. - integer MyId,AllGrp,DontCare,MasterId,WhatsUp,ifinish + integer MyId,AllGrp,DontCare,MasterId,WhatsUp,ifinish,msglen_var logical koniec integer tag,status(MPI_STATUS_SIZE) common /info/ myid,masterid,allgrp,dontcare, diff --git a/source/unres/src-HCD-5D/COMMON.LANGEVIN b/source/unres/src-HCD-5D/COMMON.LANGEVIN index 6a703e2..976d17a 100644 --- a/source/unres/src-HCD-5D/COMMON.LANGEVIN +++ b/source/unres/src-HCD-5D/COMMON.LANGEVIN @@ -1,3 +1,13 @@ +! Langevin dynamics parameters + logical surfarea + integer reset_fricmat + double precision scal_fric,rwat,etawat,gamp, + & gamsc(ntyp1),stdfp,stdfsc(ntyp),stdforcp(MAXRES), + & stdforcsc(MAXRES),pstok,restok(ntyp+1),cPoise,Rb + common /langevin/ pstok,restok,gamp,gamsc, + & stdfp,stdfsc,stdforcp,stdforcsc,rwat,etawat,cPoise,Rb,surfarea, + & reset_fricmat +! Quantities used in Langevin dynamics calculations double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), & fricmat(MAXRES2,MAXRES2),fric_work(MAXRES6), & stoch_work(MAXRES6), diff --git a/source/unres/src-HCD-5D/COMMON.LANGEVIN.lang0 b/source/unres/src-HCD-5D/COMMON.LANGEVIN.lang0 index 354a0c4..36ff190 100644 --- a/source/unres/src-HCD-5D/COMMON.LANGEVIN.lang0 +++ b/source/unres/src-HCD-5D/COMMON.LANGEVIN.lang0 @@ -1,11 +1,16 @@ - double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), +! Basic Langevin dynamics parameters + logical surfarea + integer reset_fricmat + double precision scal_fric,rwat,etawat,gamp, + & gamsc(ntyp1),stdfp,stdfsc(ntyp),stdforcp(MAXRES), + & stdforcsc(MAXRES),pstok,restok(ntyp+1),cPoise,Rb + common /langevin/ pstok,restok,gamp,gamsc, + & stdfp,stdfsc,stdforcp,stdforcsc,rwat,etawat,scal_fric, + & cPoise,Rb,surfarea,reset_fricmat +! Variables used in Langevin dynamics calculations + double precision friction(3,0:MAXRES2),stochforc(3,0:MAXRES2), & fricmat(MAXRES2,MAXRES2),fric_work(MAXRES6), - & stoch_work(MAXRES6), - & fricgam(MAXRES6),fricvec(MAXRES2,MAXRES2) - logical flag_stoch(0:maxflag_stoch) - common /langforc/ friction,stochforc, - & fricmat,fric_work,fricgam,stoch_work,fricvec,vrand_mat1, - & vrand_mat2,prand_mat,vfric_mat,afric_mat,pfric_mat, - & pfric0_mat,afric0_mat,vfric0_mat,prand0_mat,vrand0_mat1, - & vrand0_mat2,flag_stoch - common /langmat/ mt1,mt2,mt3 + & stoch_work(MAXRES6),fricgam(MAXRES6),fricvec(MAXRES2,MAXRES2) + logical flag_stoch(0:maxflag_stoch) + common /langforc/ friction,stochforc,fricmat,fric_work,fricgam, + & stoch_work,fricvec,flag_stoch diff --git a/source/unres/src-HCD-5D/COMMON.MAP b/source/unres/src-HCD-5D/COMMON.MAP index 77e97e7..7aa3875 100644 --- a/source/unres/src-HCD-5D/COMMON.MAP +++ b/source/unres/src-HCD-5D/COMMON.MAP @@ -1,4 +1,4 @@ - integer nmap,res1,res2,nstep + integer nmap,res1,res2,nstep,kang double precision ang_from,ang_to common /mapp/ ang_from(maxvar),ang_to(maxvar),nmap,kang(maxvar), & res1(maxvar),res2(maxvar),nstep(maxvar) diff --git a/source/unres/src-HCD-5D/COMMON.MAXGRAD b/source/unres/src-HCD-5D/COMMON.MAXGRAD index 285241a..2d798e8 100644 --- a/source/unres/src-HCD-5D/COMMON.MAXGRAD +++ b/source/unres/src-HCD-5D/COMMON.MAXGRAD @@ -1,12 +1,12 @@ double precision & gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,gradb_max,ghpbc_max, & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, + & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max, & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max + & gsccorrx_max,gsclocx_max common /maxgrad/ & gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,gradb_max,ghpbc_max, & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, + & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max, & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max + & gsccorrx_max,gsclocx_max diff --git a/source/unres/src-HCD-5D/COMMON.MCE b/source/unres/src-HCD-5D/COMMON.MCE index 2d79184..90b8fd0 100644 --- a/source/unres/src-HCD-5D/COMMON.MCE +++ b/source/unres/src-HCD-5D/COMMON.MCE @@ -1,6 +1,7 @@ double precision entropy(-max_ene-4:max_ene),nminima(maxsave), - & nhist(-max_ene:max_ene) + & nhist(-max_ene:max_ene),emin,emax logical ent_read,multican + integer indminn,indmaxx common /mce/ entropy,emin,emax,nhist,nminima,ent_read,multican, & indminn,indmaxx integer npool diff --git a/source/unres/src-HCD-5D/COMMON.MCM b/source/unres/src-HCD-5D/COMMON.MCM index 576f912..b95f0ec 100644 --- a/source/unres/src-HCD-5D/COMMON.MCM +++ b/source/unres/src-HCD-5D/COMMON.MCM @@ -2,10 +2,10 @@ C... Following COMMON block contains general variables controlling the MC/MCM C... procedure c----------------------------------------------------------------------------- double precision Tcur,Tmin,Tmax,TstepH,TstepC,RanFract, - & overlap_cut,e_up,delte + & overlap_cut,e_up,delte,Rbol,betbol integer nstepH,nstepC,maxacc,maxgen,maxtrial,maxtrial_iter, & maxrepm,ngen,ntrial,ntherm,nrepm,neneval,nsave,maxoverlap, - & nsave_part,max_mcm_it,nsweep,print_mc + & nsave_part,max_mcm_it,nsweep,print_mc,nbond_move,nbond_acc logical print_stat,print_int common /mcm/ Tcur,Tmin,Tmax,TstepH,TstepC,Rbol,betbol,RanFract, & overlap_cut,e_up,delte, diff --git a/source/unres/src-HCD-5D/COMMON.MD b/source/unres/src-HCD-5D/COMMON.MD index 8e3203e..6988bd8 100644 --- a/source/unres/src-HCD-5D/COMMON.MD +++ b/source/unres/src-HCD-5D/COMMON.MD @@ -1,97 +1,30 @@ - double precision gcart, gxcart, gradcag,gradxag - common /mdgrad/ gcart(3,0:MAXRES), gxcart(3,0:MAXRES), - & gradcag(3,MAXRES),gradxag(3,MAXRES) - integer dimen,dimen1, dimen3, ifrag(2,50,maxprocs/20), - & ipair(2,100,maxprocs/20),iset, - & mset(maxprocs/20),nset - logical loc_qlike,adaptive - double precision IP,ISC(ntyp+1),mp, - & msc(ntyp+1),d_t_work(MAXRES6), - & d_t_work_new(MAXRES6),d_t(3,0:MAXRES2),d_t_new(3,0:MAXRES2), - & d_af_work(MAXRES6),d_as_work(MAXRES6), - & d_t_old(3,0:MAXRES2),d_a_old(3,0:MAXRES2),d_a_short(3,0:MAXRES2), - & Gmat(MAXRES2,MAXRES2),Ginv(MAXRES2,MAXRES2),A(MAXRES2,MAXRES2), - & d_a(3,0:MAXRES2),d_a_work(6*MAXRES),kinetic_force(MAXRES6), - & Gsqrp(MAXRES2,MAXRES2),Gsqrm(MAXRES2,MAXRES2), - & vtot(MAXRES2),Gvec(maxres2,maxres2),Geigen(maxres2) - - real*8 odl(max_template,maxdim),sigma_odl(max_template,maxdim), - & dih(max_template,maxres),sigma_dih(max_template,maxres), - & sigma_odlir(max_template,maxdim) -c -c Specification of new variables used in subroutine e_modeller -c modified by FP (Nov.,2014) - real*8 xxtpl(max_template,maxres),yytpl(max_template,maxres), - & zztpl(max_template,maxres),thetatpl(max_template,maxres), - & sigma_theta(max_template,maxres), - & sigma_d(max_template,maxres) -c - - integer ires_homo(maxdim), - & jres_homo(maxdim),idomain(max_template,maxres) - - double precision v_ini,d_time,d_time0,t_bath,tau_bath, - & EK,potE,potEcomp(0:n_ene+8),totE,totT,amax,kinetic_T,dvmax,damax, - & edriftmax, - & eq_time,wfrag(50,maxprocs/20),wpair(100,maxprocs/20), - & qfrag(50),qpair(100), - & qinfrag(50,maxprocs/20),qinpair(100,maxprocs/20), - & Ucdfrag,Ucdpair,dUdconst(3,0:MAXRES),Uconst, - & dUdxconst(3,0:MAXRES),dqwol(3,0:MAXRES),dxqwol(3,0:MAXRES), - & utheta(maxfrag_back),ugamma(maxfrag_back),uscdiff(maxfrag_back), - & dutheta(maxres),dugamma(maxres),duscdiff(3,maxres), - & duscdiffx(3,maxres),wfrag_back(3,maxfrag_back,maxprocs/20), - & qloc(3,maxfrag_back), - & qin_back(3,maxfrag_back,maxprocs/20), - & uconst_back +! General MD parameters + double precision v_ini,d_time,d_time0,t_bath,tau_bath, + & dvmax,damax,edriftmax integer n_timestep,ntwx,ntwe,lang,count_reset_moment, - & count_reset_vel,reset_fricmat,nfrag,npair,nfrag_back, - & ifrag_back(3,maxfrag_back,maxprocs/20),ntime_split,ntime_split0, - & maxtime_split,lim_odl,lim_dih,link_start_homo,link_end_homo, - & idihconstr_start_homo,idihconstr_end_homo + & count_reset_vel,ntime_split,ntime_split0, + & maxtime_split logical large,print_compon,tbf,rest,reset_moment,reset_vel, - & surfarea,rattle,usampl,mdpdb,RESPA,preminim, - & l_homo(max_template,maxdim) - integer igmult_start,igmult_end,my_ng_count,ng_start,ng_counts, - & nginv_start,nginv_counts,myginv_ng_count - common /back_constr/ uconst_back,utheta,ugamma,uscdiff, - & dutheta,dugamma,duscdiff,duscdiffx, - & qin_back,qloc,wfrag_back,nfrag_back,ifrag_back - - common /homrestr/ odl,dih,sigma_dih,sigma_odl, - & lim_odl,lim_dih,ires_homo,jres_homo,link_start_homo, - & link_end_homo,idihconstr_start_homo,idihconstr_end_homo, - & idomain,l_homo -c -c FP (30/10/2014,04/03/2015) -c - common /homrestr_double/ - & xxtpl,yytpl,zztpl,thetatpl,sigma_theta,sigma_d,sigma_odlir -c - common /qmeas/ qfrag,qpair,qinfrag,qinpair,wfrag,wpair,eq_time, - & Ucdfrag,Ucdpair,dUdconst,dUdxconst,dqwol,dxqwol,Uconst, - & iset,mset,nset,usampl,ifrag,ipair,npair,nfrag,loc_qlike,adaptive - common /mdpar/ v_ini,d_time,d_time0,scal_fric, - & t_bath,tau_bath,dvmax,damax,n_timestep,mdpdb, + & rattle,mdpdb,RESPA,preminim + common /mdpar/ v_ini,d_time,d_time0,t_bath, + & tau_bath,dvmax,damax,n_timestep,mdpdb, & ntime_split,ntime_split0,maxtime_split, - & ntwx,ntwe,large,print_compon,tbf,rest,preminim - common /MDcalc/ totT,totE,potE,potEcomp,EK,amax,edriftmax, - & kinetic_T - common /lagrange/ d_t,d_t_old,d_t_new,d_t_work, - & d_t_work_new,d_a,d_a_old,d_a_work,d_af_work,d_as_work,d_a_short, - & kinetic_force, - & A,Ginv,Gmat,Gvec,Geigen,Gsqrp,Gsqrm, - & vtot,dimen,dimen1,dimen3,lang, + & ntwx,ntwe,lang,large,print_compon,tbf,rest,preminim, & reset_moment,reset_vel,count_reset_moment,count_reset_vel, & rattle,RESPA - common /inertia/ IP,ISC,mp,MSC - double precision scal_fric,rwat,etawat,gamp, - & gamsc(ntyp1),stdfp,stdfsc(ntyp),stdforcp(MAXRES), - & stdforcsc(MAXRES),pstok,restok(ntyp+1),cPoise,Rb - common /langevin/ pstok,restok,gamp,gamsc, - & stdfp,stdfsc,stdforcp,stdforcsc,rwat,etawat,cPoise,Rb,surfarea, - & reset_fricmat +! Basic quantities + double precision EK,potE,potEcomp(0:n_ene+8),totE,totT,amax, + & kinetic_T + common /MDcalc/ totT,totE,potE,potEcomp,EK,amax,edriftmax, + & kinetic_T +! Parameters of distributed calculations of accelerations from forces + integer igmult_start,igmult_end,my_ng_count,ng_start,ng_counts, + & nginv_start,nginv_counts,myginv_ng_count common /mdpmpi/ igmult_start,igmult_end,my_ng_count, & myginv_ng_count, & ng_start(0:MaxProcs-1),ng_counts(0:MaxProcs-1), & nginv_start(0:MaxProcs),nginv_counts(0:MaxProcs-1) +! Gradient components + double precision gcart, gxcart, gradcag,gradxag + common /mdgrad/ gcart(3,0:MAXRES), gxcart(3,0:MAXRES), + & gradcag(3,MAXRES),gradxag(3,MAXRES) diff --git a/source/unres/src-HCD-5D/COMMON.SHIELD b/source/unres/src-HCD-5D/COMMON.SHIELD index a8110d5..aead071 100644 --- a/source/unres/src-HCD-5D/COMMON.SHIELD +++ b/source/unres/src-HCD-5D/COMMON.SHIELD @@ -1,6 +1,6 @@ double precision VSolvSphere,VSolvSphere_div,long_r_sidechain, & short_r_sidechain,fac_shield,grad_shield_side,grad_shield, - & buff_shield,wshield + & grad_shield_loc,buff_shield,wshield integer ishield_list,shield_list,ees0plist common /shield/ VSolvSphere,VSolvSphere_div,buff_shield, & long_r_sidechain(ntyp), diff --git a/source/unres/src-HCD-5D/COMMON.SPLITELE b/source/unres/src-HCD-5D/COMMON.SPLITELE index a2f0447..5e88fef 100644 --- a/source/unres/src-HCD-5D/COMMON.SPLITELE +++ b/source/unres/src-HCD-5D/COMMON.SPLITELE @@ -1,2 +1,2 @@ - double precision r_cut,rlamb - common /splitele/ r_cut,rlamb + double precision r_cut_int,r_cut_respa,rlamb + common /splitele/ r_cut_int,r_cut_respa,rlamb diff --git a/source/unres/src-HCD-5D/COMMON.VAR b/source/unres/src-HCD-5D/COMMON.VAR index 1ab0a16..d061411 100644 --- a/source/unres/src-HCD-5D/COMMON.VAR +++ b/source/unres/src-HCD-5D/COMMON.VAR @@ -17,6 +17,6 @@ C in MCM). common /oldgeo/ varsave(maxvar,maxsave),esave(maxsave), & Origin(maxsave),nstore C freeze some variables - logical mask_r - common /restr/ varall(maxvar),mask_r,mask_theta(maxres), + logical mask_r,sideonly + common /restr/ varall(maxvar),mask_r,sideonly,mask_theta(maxres), & mask_phi(maxres),mask_side(maxres) diff --git a/source/unres/src-HCD-5D/COMMON.VECTORS b/source/unres/src-HCD-5D/COMMON.VECTORS index d880c24..04e9847 100644 --- a/source/unres/src-HCD-5D/COMMON.VECTORS +++ b/source/unres/src-HCD-5D/COMMON.VECTORS @@ -1,3 +1,4 @@ + double precision uy,uz,uygrad,uzgrad common /vectors/ uy(3,maxres),uz(3,maxres), & uygrad(3,3,2,maxres),uzgrad(3,3,2,maxres) diff --git a/source/unres/src-HCD-5D/DIMENSIONS b/source/unres/src-HCD-5D/DIMENSIONS index 0ef9173..113d3d2 100644 --- a/source/unres/src-HCD-5D/DIMENSIONS +++ b/source/unres/src-HCD-5D/DIMENSIONS @@ -16,12 +16,16 @@ C Max. number of coarse-grain processors parameter (max_cg_procs=maxprocs) C Max. number of AA residues integer maxres -c parameter (maxres=3300) - parameter (maxres=1200) + parameter (maxres=3300) +C Max. number of AA residues per chain + integer maxres_chain + parameter (maxres_chain=1200) C Appr. max. number of interaction sites - integer maxres2,maxres6,mmaxres2 + integer maxres2,maxres6,maxres2_chain,mmaxres2,mmaxres2_chain parameter (maxres2=2*maxres,maxres6=6*maxres) parameter (mmaxres2=(maxres2*(maxres2+1)/2)) + parameter (maxres2_chain=2*maxres_chain, + & mmaxres2_chain=maxres2_chain*(maxres2_chain+1)/2) C Max number of symetric chains integer maxchain parameter (maxchain=50) @@ -36,7 +40,7 @@ C Max. number of groups of interactions that a given SC is involved in C Max. number of derivatives of virtual-bond and side-chain vectors in theta C or phi. integer maxdim - parameter (maxdim=(maxres-1)*(maxres-2)/2) + parameter (maxdim=(maxres_chain-1)*(maxres_chain-2)/2) C Max. number of SC contacts integer maxcont parameter (maxcont=12*maxres) diff --git a/source/unres/src-HCD-5D/MD_A-MTS.F b/source/unres/src-HCD-5D/MD_A-MTS.F index a8efa20..ca52aaa 100644 --- a/source/unres/src-HCD-5D/MD_A-MTS.F +++ b/source/unres/src-HCD-5D/MD_A-MTS.F @@ -2,7 +2,7 @@ c------------------------------------------------ c The driver for molecular dynamics subroutines c------------------------------------------------ - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include "mpif.h" @@ -12,11 +12,20 @@ c------------------------------------------------ include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -36,6 +45,10 @@ c------------------------------------------------ common /gucio/ cm integer itime logical ovrtim + integer i,j,icount_scale,itime_scal + integer nharp,iharp(4,maxres/3) + double precision scalfac + double precision tt0 c #ifdef MPI if (ilen(tmpdir).gt.0) @@ -45,6 +58,7 @@ c if (ilen(tmpdir).gt.0) & call copy_to_tmp(pref_orig(:ilen(pref_orig))//"_"//'.rst') #endif + write (iout,*) "MD lang",lang t_MDsetup=0.0d0 t_langsetup=0.0d0 t_MD=0.0d0 @@ -288,21 +302,30 @@ c------------------------------------------------------------------------------- c Perform a single velocity Verlet step; the time step can be rescaled if c increments in accelerations exceed the threshold c------------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' - integer ierror,ierrcode + integer ierror,ierrcode,errcode #endif include 'COMMON.SETUP' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -321,8 +344,10 @@ c------------------------------------------------------------------------------- common /gucio/ cm double precision stochforcvec(MAXRES6) common /stochcalc/ stochforcvec - integer itime + integer itime,icount_scale,itime_scal,ifac_time,i,j,itt logical scale + double precision epdrift,fac_time + double precision tt0 c scale=.true. icount_scale=0 @@ -403,7 +428,7 @@ c Calculate energy and forces call zerograd call etotal(potEcomp) ! AL 4/17/17: Reduce the steps if NaNs occurred. - if (potEcomp(0).gt.0.99e20 .or. isnan(potEcomp(0))) then + if (potEcomp(0).gt.0.99e20 .or. isnan(potEcomp(0)).gt.0) then d_time=d_time/2 cycle endif @@ -588,7 +613,7 @@ c------------------------------------------------------------------------------- c------------------------------------------------------------------------------- c Perform a single RESPA step. c------------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -598,11 +623,20 @@ c------------------------------------------------------------------------------- include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -618,6 +652,8 @@ c------------------------------------------------------------------------------- double precision cm(3),L(3),vcm(3),incr(3) double precision dc_old0(3,0:maxres2),d_t_old0(3,0:maxres2), & d_a_old0(3,0:maxres2) + integer i,j + double precision fac_time logical PRINT_AMTS_MSG /.false./ integer ilen,count,rstcount external ilen @@ -628,7 +664,11 @@ c------------------------------------------------------------------------------- common /stochcalc/ stochforcvec integer itime logical scale + integer itt common /cipiszcze/ itt + integer itsplit + double precision epdrift,epdriftmax + double precision tt0 itt=itime if (ntwe.ne.0) then if (large.and. mod(itime,ntwe).eq.0) then @@ -944,7 +984,7 @@ c Compute accelerations from long-range forces write (iout,*) "Cartesian and internal coordinates: step 2" c call cartprint call pdbout(0.0d0, - & cipiszcze ,iout) + & 'cipiszcze ',iout) call intout write (iout,*) "Accelerations from long-range forces" do i=0,nres @@ -969,7 +1009,7 @@ c Compute the complete potential energy if (ntwe.ne.0) then if (large.and. mod(itime,ntwe).eq.0) then call enerprint(potEcomp) - write (iout,*) "potE",potD + write (iout,*) "potE",potE endif endif c potE=energia_short(0)+energia_long(0) @@ -999,11 +1039,16 @@ c--------------------------------------------------------------------- subroutine RESPA_vel c First and last RESPA step (incrementing velocities using long-range c forces). - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -1011,6 +1056,7 @@ c forces). include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.NAMES' + integer i,j,inres do j=1,3 d_t(j,0)=d_t(j,0)+0.5d0*d_a(j,0)*d_time enddo @@ -1032,11 +1078,16 @@ c forces). c----------------------------------------------------------------- subroutine verlet1 c Applying velocity Verlet algorithm - step 1 to coordinates - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -1045,7 +1096,7 @@ c Applying velocity Verlet algorithm - step 1 to coordinates include 'COMMON.IOUNITS' include 'COMMON.NAMES' double precision adt,adt2 - + integer i,j,inres #ifdef DEBUG write (iout,*) "VELVERLET1 START: DC" do i=0,nres @@ -1060,9 +1111,12 @@ c Applying velocity Verlet algorithm - step 1 to coordinates d_t_new(j,0)=d_t_old(j,0)+adt2 d_t(j,0)=d_t_old(j,0)+adt enddo - do i=nnt,nct-1 + do i=nnt,nct-1 C SPYTAC ADAMA C do i=0,nres +#ifdef DEBUG + write (iout,*) "i",i," d_a_old",(d_a_old(j,i),j=1,3) +#endif do j=1,3 adt=d_a_old(j,i)*d_time adt2=0.5d0*adt @@ -1096,11 +1150,16 @@ C do i=0,nres c--------------------------------------------------------------------- subroutine verlet2 c Step 2 of the velocity Verlet algorithm: update velocities - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -1108,6 +1167,7 @@ c Step 2 of the velocity Verlet algorithm: update velocities include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.NAMES' + integer i,j,inres do j=1,3 d_t(j,0)=d_t_new(j,0)+0.5d0*d_a(j,0)*d_time enddo @@ -1129,7 +1189,7 @@ c Step 2 of the velocity Verlet algorithm: update velocities c----------------------------------------------------------------- subroutine sddir_precalc c Applying velocity Verlet algorithm - step 1 to coordinates - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -1137,11 +1197,20 @@ c Applying velocity Verlet algorithm - step 1 to coordinates include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -1150,8 +1219,10 @@ c Applying velocity Verlet algorithm - step 1 to coordinates include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.TIME1' + double precision time00 double precision stochforcvec(MAXRES6) common /stochcalc/ stochforcvec + integer i c c Compute friction and stochastic forces c @@ -1161,6 +1232,7 @@ c time00=tcpu() #endif call friction_force +c write (iout,*) "After friction_force" #ifdef MPI time_fric=time_fric+MPI_Wtime()-time00 time00=MPI_Wtime() @@ -1169,6 +1241,7 @@ c time00=tcpu() #endif call stochastic_force(stochforcvec) +c write (iout,*) "After stochastic_force" #ifdef MPI time_stoch=time_stoch+MPI_Wtime()-time00 #else @@ -1178,23 +1251,46 @@ c c Compute the acceleration due to friction forces (d_af_work) and stochastic c forces (d_as_work) c +#ifdef FIVEDIAG +c write (iout,*) "friction accelerations" + call fivediaginv_mult(dimen,fric_work, d_af_work) +c write (iout,*) "stochastic acceleratios" + call fivediaginv_mult(dimen,stochforcvec, d_as_work) +c write (iout,*) "Leaving sddir_precalc" +#else call ginv_mult(fric_work, d_af_work) call ginv_mult(stochforcvec, d_as_work) +#endif +#ifdef DEBUG + write (iout,*) "d_af_work" + write (iout,'(3f10.5)') (d_af_work(i),i=1,dimen3) + write (iout,*) "d_as_work" + write (iout,'(3f10.5)') (d_as_work(i),i=1,dimen3) +#endif return end c--------------------------------------------------------------------- subroutine sddir_verlet1 c Applying velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -1206,6 +1302,7 @@ c Revised 3/31/05 AL: correlation between random contributions to c position and velocity increments included. double precision sqrt13 /0.57735026918962576451d0/ ! 1/sqrt(3) double precision adt,adt2 + integer i,j,ind,inres c c Add the contribution from BOTH friction and stochastic force to the c coordinates, but ONLY the contribution from the friction forces to velocities @@ -1218,7 +1315,7 @@ c d_t(j,0)=d_t_old(j,0)+adt enddo ind=3 - do i=nnt,nct-1 + do i=nnt,nct-1 do j=1,3 adt=(d_a_old(j,i)+d_af_work(ind+j))*d_time adt2=0.5d0*adt+sqrt13*d_as_work(ind+j)*d_time @@ -1246,16 +1343,25 @@ c c--------------------------------------------------------------------- subroutine sddir_verlet2 c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -1265,6 +1371,7 @@ c Calculating the adjusted velocities for accelerations include 'COMMON.NAMES' double precision stochforcvec(MAXRES6),d_as_work1(MAXRES6) double precision cos60 /0.5d0/, sin60 /0.86602540378443864676d0/ + integer i,j,inres,ind c Revised 3/31/05 AL: correlation between random contributions to c position and velocity increments included. c The correlation coefficients are calculated at low-friction limit. @@ -1276,8 +1383,11 @@ c c Compute the acceleration due to friction forces (d_af_work) and stochastic c forces (d_as_work) c +#ifdef FIVEDIAG + call fivediaginv_mult(maxres6,stochforcvec, d_as_work1) +#else call ginv_mult(stochforcvec, d_as_work1) - +#endif c c Update velocities c @@ -1312,17 +1422,23 @@ c c Find the maximum difference in the accelerations of the the sites c at the beginning and the end of the time step. c - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.IOUNITS' + integer i,j double precision aux(3),accel(3),accel_old(3),dacc do j=1,3 c aux(j)=d_a(j,0)-d_a_old(j,0) @@ -1388,11 +1504,16 @@ c--------------------------------------------------------------------- c c Predict the drift of the potential energy c - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -1401,6 +1522,7 @@ c include 'COMMON.IOUNITS' include 'COMMON.MUCA' double precision epdrift,epdriftij + integer i,j c Drift of the potential energy epdrift=0.0d0 do i=nnt,nct @@ -1433,11 +1555,25 @@ c----------------------------------------------------------------------- c c Coupling to the thermostat by using the Berendsen algorithm c - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -1446,7 +1582,7 @@ c include 'COMMON.IOUNITS' include 'COMMON.NAMES' double precision T_half,fact -c + integer i,j ,inres T_half=2.0d0/(dimen3*Rb)*EK fact=dsqrt(1.0d0+(d_time/tau_bath)*(t_bath/T_half-1.0d0)) c write(iout,*) "T_half", T_half @@ -1473,22 +1609,36 @@ c write(iout,*) "fact", fact c--------------------------------------------------------- subroutine init_MD c Set up the initial conditions of a MD simulation - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MP include 'mpif.h' character*16 form - integer IERROR,ERRCODE + integer IERROR,ERRCODE,error_msg,ierr,ierrcode #endif include 'COMMON.SETUP' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif + include 'COMMON.QRESTR' #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -1497,6 +1647,14 @@ c Set up the initial conditions of a MD simulation include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.REMD' + include 'COMMON.TIME1' +#ifdef LBFGS + character*9 status + integer niter + common /lbfgstat/ status,niter,nfun +#endif + integer n_model_try,list_model_try(max_template),k + double precision tt0 real*8 energia_long(0:n_ene), & energia_short(0:n_ene),vcm(3),incr(3) double precision cm(3),L(3),xv,sigv,lowb,highb @@ -1507,6 +1665,11 @@ c Set up the initial conditions of a MD simulation character*50 tytul logical file_exist common /gucio/ cm + integer i,ipos,iq,iw,j,iranmin,nft_sc,iretcode,nfun,itrial,itmp, + & i_model,itime + integer iran_num + double precision etot + logical fail write (iout,*) "init_MD INDPDB",indpdb d_time0=d_time c write(iout,*) "d_time", d_time @@ -1669,7 +1832,8 @@ c Removing the velocity of the center of mass endif call flush(iout) write (iout,*) "init_MD before initial structure REST ",rest - if (.not.rest) then + if (.not.rest) then + 122 continue if (iranconf.ne.0) then c 8/22/17 AL Loop to produce a low-energy random conformation do iranmin=1,10 @@ -1747,64 +1911,105 @@ c 8/22/17 AL Loop to produce a low-energy random conformation 44 continue else if (preminim) then if (start_from_model) then - i_model=iran_num(1,constr_homology) - write (iout,*) 'starting from model ',i_model - do i=1,2*nres - do j=1,3 - c(j,i)=chomo(j,i,i_model) + n_model_try=0 + do while (fail .and. n_model_try.lt.constr_homology) + do + i_model=iran_num(1,constr_homology) + do k=1,n_model_try + if (i_model.eq.list_model_try(k)) exit + enddo + if (k.gt.n_model_try) exit enddo - enddo - call int_from_cart(.true.,.false.) - call sc_loc_geom(.false.) - do i=1,nres-1 - do j=1,3 - dc(j,i)=c(j,i+1)-c(j,i) - dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + n_model_try=n_model_try+1 + list_model_try(n_model_try)=i_model + write (iout,*) 'starting from model ',i_model + do i=1,2*nres + do j=1,3 + c(j,i)=chomo(j,i,i_model) + enddo enddo - enddo - do i=2,nres-1 - do j=1,3 - dc(j,i+nres)=c(j,i+nres)-c(j,i) - dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + call int_from_cart(.true.,.false.) + call sc_loc_geom(.false.) + do i=1,nres-1 + do j=1,3 + dc(j,i)=c(j,i+1)-c(j,i) + dc_norm(j,i)=dc(j,i)*vbld_inv(i+1) + enddo enddo - enddo - endif + do i=2,nres-1 + do j=1,3 + dc(j,i+nres)=c(j,i+nres)-c(j,i) + dc_norm(j,i+nres)=dc(j,i+nres)*vbld_inv(i+nres) + enddo + enddo + if (me.eq.king.or..not.out1file) then + write (iout,*) "Energies before removing overlaps" + call etotal(energia(0)) + call enerprint(energia(0)) + endif ! Remove SC overlaps if requested - if (overlapsc) then - write (iout,*) 'Calling OVERLAP_SC' - call overlap_sc(fail) - endif + if (overlapsc) then + write (iout,*) 'Calling OVERLAP_SC' + call overlap_sc(fail) + if (fail) then + write (iout,*) + & "Failed to remove overlap from model",i_model + cycle + endif + endif +#ifdef SEARCHSC + if (me.eq.king.or..not.out1file) then + write (iout,*) "Energies after removing overlaps" + call etotal(energia(0)) + call enerprint(energia(0)) + endif ! Search for better SC rotamers if requested - if (searchsc) then - call sc_move(2,nres-1,10,1d10,nft_sc,etot) - print *,'SC_move',nft_sc,etot - if (me.eq.king.or..not.out1file) - & write(iout,*) 'SC_move',nft_sc,etot + if (searchsc) then + call sc_move(2,nres-1,10,1d10,nft_sc,etot) + print *,'SC_move',nft_sc,etot + if (me.eq.king.or..not.out1file) + & write(iout,*) 'SC_move',nft_sc,etot + endif + call etotal(energia(0)) +#endif + enddo + if (n_model_try.gt.constr_homology) then + write (iout,*) + & "All models have irreparable overlaps. Trying randoms starts." + iranconf=1 + goto 122 + endif endif - call etotal(energia(0)) C 8/22/17 AL Minimize initial structure if (dccart) then if (me.eq.king.or..not.out1file) write(iout,*) - & 'Minimizing initial PDB structure: Calling MINIM_DC' + & 'Minimizing initial PDB structure: Calling MINIM_DC' call minim_dc(etot,iretcode,nfun) else call geom_to_var(nvar,varia) if(me.eq.king.or..not.out1file) write (iout,*) - & 'Minimizing initial PDB structure: Calling MINIMIZE.' + & 'Minimizing initial PDB structure: Calling MINIMIZE.' call minimize(etot,varia,iretcode,nfun) call var_to_geom(nvar,varia) - endif - if (me.eq.king.or..not.out1file) +#ifdef LBFGS + if (me.eq.king.or..not.out1file) + & write(iout,*) 'LBFGS return code is ',status,' eval ',nfun + if(me.eq.king.or..not.out1file) + & write(iout,*) 'LBFGS return code is ',status,' eval ',nfun +#else + if (me.eq.king.or..not.out1file) & write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun - if(me.eq.king.or..not.out1file) + if(me.eq.king.or..not.out1file) & write(iout,*) 'SUMSL return code is',iretcode,' eval ',nfun +#endif + endif endif - endif + endif ! .not. rest call chainbuild_cart call kinetic(EK) if (tbf) then call verlet_bath - endif + endif kinetic_T=2.0d0/(dimen3*Rb)*EK if(me.eq.king.or..not.out1file)then call cartprint @@ -1952,16 +2157,25 @@ C 7/2/2009 Copy accelerations due to short-lange forces to an auxiliary array end c----------------------------------------------------------- subroutine random_vel - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -1970,11 +2184,272 @@ c----------------------------------------------------------- include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.TIME1' - double precision xv,sigv,lowb,highb,vec_afm(3) + double precision xv,sigv,lowb,highb,vec_afm(3),Ek1,Ek2,Ek3,aux + integer i,ii,j,k,l,ind + double precision anorm_distr + logical lprn /.true./ +#ifdef FIVEDIAG + integer ichain,n,innt,inct,ibeg,ierr + double precision work(8*maxres6) + integer iwork(maxres6) + double precision Ghalf(mmaxres2_chain),Geigen(maxres2_chain), + & Gvec(maxres2_chain,maxres2_chain) + common /przechowalnia/Ghalf,Geigen,Gvec +#ifdef DEBUG + double precision inertia(maxres2_chain,maxres2_chain) +#endif c Generate random velocities from Gaussian distribution of mean 0 and std of KT/m c First generate velocities in the eigenspace of the G matrix c write (iout,*) "Calling random_vel dimen dimen3",dimen,dimen3 c call flush(iout) +#ifdef DEBUG + write (iout,*) "Random_vel, fivediag" +#endif + d_t=0.0d0 + Ek2=0.0d0 + EK=0.0d0 + Ek3=0.0d0 + do ichain=1,nchain + ind=0 + ghalf=0.0d0 + n=dimen_chain(ichain) + innt=iposd_chain(ichain) + inct=innt+n-1 +#ifdef DEBUG + write (iout,*) "Chain",ichain," n",n," start",innt + do i=innt,inct + if (i.lt.inct-1) then + write (iout,'(2i3,3f10.5)') i,i-innt+1,DMorig(i),DU1orig(i), + & DU2orig(i) + else if (i.eq.inct-1) then + write (iout,'(2i3,3f10.5)') i,i-innt+1,DMorig(i),DU1orig(i) + else + write (iout,'(2i3,3f10.5)') i,i-innt+1,DMorig(i) + endif + enddo +#endif + ghalf(ind+1)=dmorig(innt) + ghalf(ind+2)=du1orig(innt) + ghalf(ind+3)=dmorig(innt+1) + ind=ind+3 + do i=3,n + ind=ind+i-3 +c write (iout,*) "i",i," ind",ind," indu2",innt+i-2, +c & " indu1",innt+i-1," indm",innt+i + ghalf(ind+1)=du2orig(innt-1+i-2) + ghalf(ind+2)=du1orig(innt-1+i-1) + ghalf(ind+3)=dmorig(innt-1+i) +c write (iout,'(3(a,i2,1x))') "DU2",innt-1+i-2, +c & "DU1",innt-1+i-1,"DM ",innt-1+i + ind=ind+3 + enddo +#ifdef DEBUG + ind=0 + do i=1,n + do j=1,i + ind=ind+1 + inertia(i,j)=ghalf(ind) + inertia(j,i)=ghalf(ind) + enddo + enddo +#endif +#ifdef DEBUG + write (iout,*) "Chain ",ichain," ind",ind," dim",n*(n+1)/2 + write (iout,*) "Five-diagonal inertia matrix, lower triangle" + call matoutr(n,ghalf) +#endif + call gldiag(maxres2_chain,n,n,Ghalf,work,Geigen,Gvec,ierr,iwork) + if (large) then + write (iout,'(//a,i3)') + & "Eigenvectors and eigenvalues of the G matrix chain",ichain + call eigout(n,n,maxres2_chain,maxres2_chain,Gvec,Geigen) + endif +#ifdef DIAGCHECK +c check diagonalization + do i=1,n + do j=1,n + aux=0.0d0 + do k=1,n + do l=1,n + aux=aux+gvec(k,i)*gvec(l,j)*inertia(k,l) + enddo + enddo + if (i.eq.j) then + write (iout,*) i,j,aux,geigen(i) + else + write (iout,*) i,j,aux + endif + enddo + enddo +#endif + xv=0.0d0 + ii=0 + do i=1,n + do k=1,3 + ii=ii+1 + sigv=dsqrt((Rb*t_bath)/geigen(i)) + lowb=-5*sigv + highb=5*sigv + d_t_work_new(ii)=anorm_distr(xv,sigv,lowb,highb) + EK=EK+0.5d0*geigen(i)*d_t_work_new(ii)**2 +c write (iout,*) "i",i," ii",ii," geigen",geigen(i), +c & " d_t_work_new",d_t_work_new(ii) + enddo + enddo + do k=1,3 + do i=1,n + ind=(i-1)*3+k + d_t_work(ind)=0.0d0 + do j=1,n + d_t_work(ind)=d_t_work(ind) + & +Gvec(i,j)*d_t_work_new((j-1)*3+k) + enddo +c write (iout,*) "i",i," ind",ind," d_t_work",d_t_work(ind) +c call flush(iout) + enddo + enddo +#ifdef DEBUG + aux=0.0d0 + do k=1,3 + do i=1,n + do j=1,n + aux=aux+inertia(i,j)*d_t_work(3*(i-1)+k)*d_t_work(3*(j-1)+k) + enddo + enddo + enddo + Ek3=Ek3+aux/2 +#endif +c Transfer to the d_t vector + innt=chain_border(1,ichain) + inct=chain_border(2,ichain) + ind=0 +c write (iout,*) "ichain",ichain," innt",innt," inct",inct + do i=innt,inct + do j=1,3 + ind=ind+1 + d_t(j,i)=d_t_work(ind) + enddo + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + ind=ind+1 + d_t(j,i+nres)=d_t_work(ind) + enddo + endif + enddo + enddo + if (large) then + write (iout,*) + write (iout,*) "Random velocities in the Calpha,SC space" + do i=1,nres + write (iout,'(a3,1h(,i5,1h),3f10.5,3x,3f10.5)') + & restyp(itype(i)),i,(d_t(j,i),j=1,3),(d_t(j,i+nres),j=1,3) + enddo + endif + call kinetic_CASC(Ek1) +! +! Transform the velocities to virtual-bond space +! +#define WLOS +#ifdef WLOS + do i=1,nres + if (itype(i).eq.10 .or. itype(i).eq.ntyp1) then + do j=1,3 + d_t(j,i)=d_t(j,i+1)-d_t(j,i) + enddo + else + do j=1,3 + d_t(j,i+nres)=d_t(j,i+nres)-d_t(j,i) + d_t(j,i)=d_t(j,i+1)-d_t(j,i) + enddo + end if + enddo + d_t(:,nct)=0.0d0 +c d_a(:,0)=d_a(:,1) +c d_a(:,1)=0.0d0 +c write (iout,*) "Shifting accelerations" + do ichain=1,nchain +c write (iout,*) "ichain",chain_border1(1,ichain)-1, +c & chain_border1(1,ichain) + d_t(:,chain_border1(1,ichain)-1)=d_t(:,chain_border1(1,ichain)) + d_t(:,chain_border1(1,ichain))=0.0d0 + enddo +c write (iout,*) "Adding accelerations" + do ichain=2,nchain +c write (iout,*) "chain",ichain,chain_border1(1,ichain)-1, +c & chain_border(2,ichain-1) + d_t(:,chain_border1(1,ichain)-1)= + & d_t(:,chain_border1(1,ichain)-1)+d_t(:,chain_border(2,ichain-1)) + d_t(:,chain_border(2,ichain-1))=0.0d0 + enddo + do ichain=2,nchain + write (iout,*) "chain",ichain,chain_border1(1,ichain)-1, + & chain_border(2,ichain-1) + d_t(:,chain_border1(1,ichain)-1)= + & d_t(:,chain_border1(1,ichain)-1)+d_t(:,chain_border(2,ichain-1)) + d_t(:,chain_border(2,ichain-1))=0.0d0 + enddo +#else + ibeg=0 +c do j=1,3 +c d_t(j,0)=d_t(j,nnt) +c enddo + do ichain=1,nchain + innt=chain_border(1,ichain) + inct=chain_border(2,ichain) +c write (iout,*) "ichain",ichain," innt",innt," inct",inct +c write (iout,*) "ibeg",ibeg + do j=1,3 + d_t(j,ibeg)=d_t(j,innt) + enddo + ibeg=inct+1 + do i=innt,inct + if (iabs(itype(i).eq.10)) then +c write (iout,*) "i",i,(d_t(j,i),j=1,3),(d_t(j,i+1),j=1,3) + do j=1,3 + d_t(j,i)=d_t(j,i+1)-d_t(j,i) + enddo + else + do j=1,3 + d_t(j,i+nres)=d_t(j,i+nres)-d_t(j,i) + d_t(j,i)=d_t(j,i+1)-d_t(j,i) + enddo + end if + enddo + enddo +#endif + if (large) then + write (iout,*) + write (iout,*) + & "Random velocities in the virtual-bond-vector space" + write (iout,'(3hORG,1h(,i5,1h),3f10.5)') 0,(d_t(j,0),j=1,3) + do i=1,nres + write (iout,'(a3,1h(,i5,1h),3f10.5,3x,3f10.5)') + & restyp(itype(i)),i,(d_t(j,i),j=1,3),(d_t(j,i+nres),j=1,3) + enddo + write (iout,*) + write (iout,*) "Kinetic energy from inertia matrix eigenvalues", + & Ek + write (iout,*) + & "Kinetic temperatures from inertia matrix eigenvalues", + & 2*Ek/(3*dimen*Rb) +#ifdef DEBUG + write (iout,*) "Kinetic energy from inertia matrix",Ek3 + write (iout,*) "Kinetic temperatures from inertia", + & 2*Ek3/(3*dimen*Rb) +#endif + write (iout,*) "Kinetic energy from velocities in CA-SC space", + & Ek1 + write (iout,*) + & "Kinetic temperatures from velovities in CA-SC space", + & 2*Ek1/(3*dimen*Rb) + call kinetic(Ek1) + write (iout,*) + & "Kinetic energy from virtual-bond-vector velocities",Ek1 + write (iout,*) + & "Kinetic temperature from virtual-bond-vector velocities ", + & 2*Ek1/(dimen3*Rb) + endif +#else xv=0.0d0 ii=0 do i=1,dimen @@ -2052,13 +2527,14 @@ c call kinetic(EK) c write (iout,*) "Kinetic energy",Ek,EK1," kinetic temperature", c & 2.0d0/(dimen3*Rb)*EK,2.0d0/(dimen3*Rb)*EK1 c call flush(iout) +#endif return end #ifndef LANG0 c----------------------------------------------------------- subroutine sd_verlet_p_setup c Sets up the parameters of stochastic Verlet algorithm - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -2069,8 +2545,12 @@ c Sets up the parameters of stochastic Verlet algorithm #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -2179,14 +2659,12 @@ c c c Transform from the eigenspace of mass-scaled friction matrix to UNRES variables c -#ifndef LANG0 call eigtransf(dimen,maxres2,mt3,mt2,pfric_vec,pfric_mat) call eigtransf(dimen,maxres2,mt3,mt2,vfric_vec,vfric_mat) call eigtransf(dimen,maxres2,mt3,mt2,afric_vec,afric_mat) call eigtransf(dimen,maxres2,mt3,mt1,prand_vec,prand_mat) call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec1,vrand_mat1) call eigtransf(dimen,maxres2,mt3,mt1,vrand_vec2,vrand_mat2) -#endif #ifdef MPI t_sdsetup=t_sdsetup+MPI_Wtime() #else @@ -2229,16 +2707,25 @@ c------------------------------------------------------------- c------------------------------------------------------------- subroutine sd_verlet1 c Applying stochastic velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -2249,6 +2736,7 @@ c Applying stochastic velocity Verlet algorithm - step 1 to velocities double precision stochforcvec(MAXRES6) common /stochcalc/ stochforcvec logical lprn /.false./ + integer i,j,ind,inres c write (iout,*) "dc_old" c do i=0,nres @@ -2332,16 +2820,25 @@ c enddo c-------------------------------------------------------------------------- subroutine sd_verlet2 c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -2351,6 +2848,7 @@ c Calculating the adjusted velocities for accelerations include 'COMMON.NAMES' double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) common /stochcalc/ stochforcvec + integer i,j,ind,inres c c Compute the stochastic forces which contribute to velocity change c @@ -2393,7 +2891,7 @@ c----------------------------------------------------------- subroutine sd_verlet_ciccotti_setup c Sets up the parameters of stochastic velocity Verlet algorithmi; Ciccotti's c version - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -2401,11 +2899,12 @@ c version include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' #else - include 'COMMON.LANGEVIN.lang0' + include 'COMMON.LAGRANGE' #endif + include 'COMMON.LANGEVIN' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -2422,6 +2921,7 @@ c version logical lprn /.false./ double precision zero /1.0d-8/, gdt_radius /0.05d0/ double precision ktm + integer i #ifdef MPI tt0 = MPI_Wtime() #else @@ -2492,7 +2992,7 @@ c c------------------------------------------------------------- subroutine sd_verlet1_ciccotti c Applying stochastic velocity Verlet algorithm - step 1 to velocities - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -2500,11 +3000,12 @@ c Applying stochastic velocity Verlet algorithm - step 1 to velocities include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' #else - include 'COMMON.LANGEVIN.lang0' + include 'COMMON.LAGRANGE' #endif + include 'COMMON.LANGEVIN' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -2515,6 +3016,7 @@ c Applying stochastic velocity Verlet algorithm - step 1 to velocities double precision stochforcvec(MAXRES6) common /stochcalc/ stochforcvec logical lprn /.false./ + integer i,j c write (iout,*) "dc_old" c do i=0,nres @@ -2599,16 +3101,17 @@ c enddo c-------------------------------------------------------------------------- subroutine sd_verlet2_ciccotti c Calculating the adjusted velocities for accelerations - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' -#ifndef LANG0 - include 'COMMON.LANGEVIN' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' #else - include 'COMMON.LANGEVIN.lang0' + include 'COMMON.LAGRANGE' #endif + include 'COMMON.LANGEVIN' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -2618,6 +3121,7 @@ c Calculating the adjusted velocities for accelerations include 'COMMON.NAMES' double precision stochforcvec(MAXRES6),stochforcvecV(MAXRES6) common /stochcalc/ stochforcvec + integer i,j c c Compute the stochastic forces which contribute to velocity change c diff --git a/source/unres/src-HCD-5D/MREMD.F b/source/unres/src-HCD-5D/MREMD.F index 087b9be..78a7404 100644 --- a/source/unres/src-HCD-5D/MREMD.F +++ b/source/unres/src-HCD-5D/MREMD.F @@ -1,15 +1,25 @@ subroutine MREMD - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'mpif.h' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif + include 'COMMON.QRESTR' #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -22,7 +32,12 @@ include 'COMMON.SETUP' include 'COMMON.MUCA' include 'COMMON.HAIRPIN' - integer ERRCODE + double precision time00,time01,time02,time03,time04,time05, + & time06,time07,time08,time001,tt0 + double precision scalfac + integer i,j,k,il,il1,ii,iex,itmp,i_temp,i_mult,i_iset,i_mset, + & i_dir,i_temp1,i_mult1,i_mset1 + integer ERRCODE,ierr,ierror double precision cm(3),L(3),vcm(3) double precision energia(0:n_ene) double precision remd_t_bath(maxprocs) @@ -36,12 +51,17 @@ external ilen character*50 tytul common /gucio/ cm - integer itime + integer itime,i_set_temp,itt,itime_master,irr,i_iset1 + integer nharp,iharp(4,maxres/3) cold integer nup(0:maxprocs),ndown(0:maxprocs) integer rep2i(0:maxprocs),ireqi(maxprocs) integer icache_all(maxprocs) integer status(MPI_STATUS_SIZE),statusi(MPI_STATUS_SIZE,maxprocs) logical synflag,end_of_run,file_exist /.false./,ovrtim + double precision t_bath_temp,delta,ene_iex_iex,ene_i_i,ene_iex_i, + & ene_i_iex,xxx,tmp,econstr_temp_iex,econstr_temp_i + integer iran_num + double precision ran_number cdeb imin_itime_old=0 ntwx_cache=0 @@ -1306,10 +1326,17 @@ cd end c----------------------------------------------------------------------- subroutine write1rst(i_index) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'mpif.h' + include 'COMMON.CONTROL' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif + include 'COMMON.QRESTR' include 'COMMON.IOUNITS' include 'COMMON.REMD' include 'COMMON.SETUP' @@ -1324,6 +1351,8 @@ c----------------------------------------------------------------------- integer*2 i_index & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) common /przechowalnia/ d_restart1,d_restart2 + integer i,j,il1,il,ixdrf + integer ierr t5_restart1(1)=totT t5_restart1(2)=EK @@ -1483,10 +1512,11 @@ c----------------------------------------------------------------------- subroutine write1traj - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'mpif.h' include 'COMMON.MD' + include 'COMMON.QRESTR' include 'COMMON.IOUNITS' include 'COMMON.REMD' include 'COMMON.SETUP' @@ -1504,6 +1534,8 @@ c----------------------------------------------------------------------- & p_uscdiff(100*maxprocs) real p_c(3,(maxres2+2)*maxprocs),r_c(3,maxres2+2) common /przechowalnia/ p_c + integer ii,i,il,j,ixdrf + integer ierr call mpi_bcast(ii_write,1,mpi_integer, & king,CG_COMM,ierr) @@ -1706,10 +1738,17 @@ c end debugging subroutine read1restart(i_index) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'mpif.h' + include 'COMMON.CONTROL' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif + include 'COMMON.QRESTR' include 'COMMON.IOUNITS' include 'COMMON.REMD' include 'COMMON.SETUP' @@ -1721,6 +1760,8 @@ c end debugging integer*2 i_index & (maxprocs/4,maxprocs/20,maxprocs/200,maxprocs/200) common /przechowalnia/ d_restart1 + integer i,j,il,il1,ixdrf,iret,itmp + integer ierr write (*,*) "Processor",me," called read1restart" if(me.eq.king)then @@ -1896,10 +1937,15 @@ c & CG_COMM,ierr) end subroutine read1restart_old - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'mpif.h' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif include 'COMMON.IOUNITS' include 'COMMON.REMD' include 'COMMON.SETUP' @@ -1909,6 +1955,8 @@ c & CG_COMM,ierr) real d_restart1(3,2*maxres*maxprocs),r_d(3,2*maxres), & t5_restart1(5) common /przechowalnia/ d_restart1 + integer i,j,il,itmp + integer ierr if(me.eq.king)then open(irest2,file=mremd_rst_name,status='unknown') read (irest2,*) (i2rep(i),i=0,nodes-1) diff --git a/source/unres/src-HCD-5D/Makefile_MPICH_ifort-okeanos b/source/unres/src-HCD-5D/Makefile_MPICH_ifort-okeanos index 4b51933..a7ea506 100644 --- a/source/unres/src-HCD-5D/Makefile_MPICH_ifort-okeanos +++ b/source/unres/src-HCD-5D/Makefile_MPICH_ifort-okeanos @@ -4,11 +4,11 @@ FC = ftn -OPT = -O3 -ip -mcmodel=medium -shared-intel -dynamic -#OPT = -g -CA -CB -mcmodel=medium -shared-intel -dynamic +#OPT = -O3 -ip -mcmodel=medium -shared-intel -dynamic +OPT = -g -CA -CB -mcmodel=medium -shared-intel -dynamic OPT2 = -g -O0 -mcmodel=medium -shared-intel -dynamic -OPTE = -c -O3 -ipo -mcmodel=medium -shared-intel -dynamic -#OPTE = ${OPT} -c +#OPTE = -c -O3 -ipo -mcmodel=medium -shared-intel -dynamic +OPTE = ${OPT} -c FFLAGS = -c ${OPT} -I$(INSTALL_DIR)/include #FFLAGS1 = -c -g -CA -CB -I$(INSTALL_DIR)/include @@ -36,15 +36,16 @@ all: no_option object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ matmult.o readrtns_CSA.o parmread.o gen_rand_conf.o printmat.o map.o \ - pinorm.o randgens.o rescode.o intcor.o timing.o misc.o intlocal.o \ - cartder.o checkder_p.o econstr_local.o econstr_qlike.o econstrq-PMF.o PMFprocess.o energy_p_new_barrier.o \ + pinorm.o randgens.o rescode.o intcor.o timing.o misc.o \ + cart2intgrad.o checkder_p.o contact_cp econstr_local.o econstr_qlike.o \ + econstrq-PMF.o PMFprocess.o energy_p_new_barrier.o \ energy_p_new-sep_barrier.o gradient_p.o minimize_p.o sumsld.o \ cored.o rmdd.o geomout.o readpdb.o regularize.o thread.o fitsq.o mcm.o \ mc.o bond_move.o refsys.o check_sc_distr.o check_bond.o contact.o \ eigen.o blas.o add.o entmcm.o minim_mcmf.o \ together.o csa.o minim_jlee.o shift.o diff12.o bank.o newconf.o ran.o \ indexx.o MP.o compare_s1.o prng_32.o \ - test.o banach.o distfit.o rmsd.o rmscalc.o elecont.o dihed_cons.o \ + banach.o distfit.o rmsd.o rmscalc.o elecont.o dihed_cons.o \ sc_move.o local_move.o djacob.o \ intcartderiv.o lagrangian_lesyng.o\ chain_symmetry.o permut.o seq2chains.o iperm.o\ @@ -52,11 +53,13 @@ object = unres.o arcos.o cartprint.o chainbuild.o convert.o initialize_p.o \ surfatom.o sort.o muca_md.o MREMD.o rattle.o gauss.o energy_split-sep.o \ q_measure.o gnmr1.o mygauss.o ssMD.o +object_lbfgs = inform.o iounit.o keys.o linmin.o math.o minima.o scales.o output.o lbfgs.o search.o optsave_dum.o + no_option: GAB: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -GAB: BIN = ~/bin/unres-mult-symetr_KCC_ifort_MPICH-okeanos_GAB-SAXS-homology.exe + -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DFOURBODY +GAB: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_GAB-HCD.exe GAB: ${object} xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true @@ -64,8 +67,8 @@ GAB: ${object} xdrf/libxdrf.a ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} 4P: CPPFLAGS = -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -4P: BIN = ~/bin/unres-mult-symetr_KCC_ifort_MPICH-okeanos_4P-SAXS-homology.exe + -DSPLITELE -DLANG0 -DCRYST_BOND -DCRYST_THETA -DCRYST_SC -DFOURBODY +4P: BIN = ~/bin/unres-ms_KCC_ifort_MPICH-okeanos_4P-HCD.exe 4P: ${object} xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true @@ -73,8 +76,8 @@ GAB: ${object} xdrf/libxdrf.a ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} E0LL2Y: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -E0LL2Y: BIN = ~/bin/unres-mult-symetr_KCC_ifort_MPICH-okeanos_E0LL2Y-SAXS-homology.exe + -DSPLITELE -DLANG0 -DFOURBODY +E0LL2Y: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_E0LL2Y-HCD.exe E0LL2Y: ${object} xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true @@ -82,22 +85,40 @@ E0LL2Y: ${object} xdrf/libxdrf.a ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} NEWCORR: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ - -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD #-DMYGAUSS #-DTIMING -NEWCORR: BIN = ~/bin/unres-mult-symetr_KCC_ifort_MPICH-okeanos_NEWCORR-SAXS-homology.exe + -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD #-DFOURBODY #-DMYGAUSS #-DTIMING +NEWCORR: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_SC-HCD.exe NEWCORR: ${object} xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + ${FC} ${OPT} ${object} cinfo.o ${LIBS} -o ${BIN} + +NEWCORR5D: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD -DFIVEDIAG -DLBFGS #-DMYGAUSS #-DTIMING +NEWCORR5D: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_SC-HCD5-40.exe +NEWCORR5D: ${object_lbfgs} ${object} fdisy.o fdiag.o machpd.o kinetic_CASC.o xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object} ${object_lbfgs} fdisy.o fdiag.o machpd.o kinetic_CASC.o cinfo.o ${LIBS} -o ${BIN} NEWCORR_DFA: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD -DDFA #-DMYGAUSS #-DTIMING -NEWCORR_DFA: BIN = ~/bin/unres-mult-symetr_KCC_ifort_MPICH-okeanos_NEWCORR-SAXS-homology-DFA-D.exe +NEWCORR_DFA: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_SC-HCD-DFA.exe NEWCORR_DFA: ${object} dfa.o xdrf/libxdrf.a gcc -o compinfo compinfo.c ./compinfo | true ${FC} ${FFLAGS} cinfo.f - ${FC} ${OPT} ${object} dfa.o cinfo.o ${LIBS} -o ${BIN} + ${FC} ${OPT} ${object} dfa.o cinfo.o ${LIBS} -o ${BIN} + +NEWCORR5D_DFA: CPPFLAGS = -DPROCOR -DLINUX -DPGI -DAMD64 -DUNRES -DISNAN -DMP -DMPI \ + -DSPLITELE -DLANG0 -DNEWCORR -DCORRCD -DFIVEDIAG -DLBFGS -DDFA #-DMYGAUSS #-DTIMING +NEWCORR5D_DFA: BIN = ~/bin/unres-ms_ifort_MPICH-okeanos_SC-HCD5-DFA.exe +NEWCORR5D_DFA: ${object_lbfgs} ${object} dfa.o fdisy.o fdiag.o machpd.o kinetic_CASC.o xdrf/libxdrf.a + gcc -o compinfo compinfo.c + ./compinfo | true + ${FC} ${FFLAGS} cinfo.f + ${FC} ${OPT} ${object_lbfgs} ${object} fdisy.o fdiag.o machpd.o dfa.o kinetic_CASC.o cinfo.o ${LIBS} -o ${BIN} xdrf/libxdrf.a: cd xdrf && make diff --git a/source/unres/src-HCD-5D/PMFprocess.F b/source/unres/src-HCD-5D/PMFprocess.F index d9bc65e..4fbe701 100644 --- a/source/unres/src-HCD-5D/PMFprocess.F +++ b/source/unres/src-HCD-5D/PMFprocess.F @@ -5,6 +5,16 @@ c Read the PMFs from wham include 'DIMENSIONS.PMF' include 'COMMON.IOUNITS' include 'COMMON.MD' +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif + include 'COMMON.QRESTR' include 'COMMON.PMF' include 'COMMON.REMD' integer i,iumb,iiset,j,t,nbin @@ -68,6 +78,7 @@ c Caution! Only ONE q is handled, no multi-D q-restraints available! #endif include 'COMMON.IOUNITS' include 'COMMON.MD' + include 'COMMON.QRESTR' include 'COMMON.REMD' include 'COMMON.PMF' integer i,iqmin,iqmax,irep diff --git a/source/unres/src-HCD-5D/TAU b/source/unres/src-HCD-5D/TAU deleted file mode 100644 index 231a93e..0000000 --- a/source/unres/src-HCD-5D/TAU +++ /dev/null @@ -1,6 +0,0 @@ -module load tau/tau-2.17 -#with preprocessor -setenv TAU_OPTIONS '-optPreProcess -optVerbose' -setenv TAU_THROTTLE 1 -setenv TAU_THROTTLE_NUMCALLS 400000 -setenv TAU_THROTTLE_PERCALL 3000 diff --git a/source/unres/src-HCD-5D/arcos.f b/source/unres/src-HCD-5D/arcos.f index 1e355ec..4b6a8ef 100644 --- a/source/unres/src-HCD-5D/arcos.f +++ b/source/unres/src-HCD-5D/arcos.f @@ -1,5 +1,6 @@ double precision FUNCTION ARCOS(X) - implicit real*8 (a-h,o-z) + implicit none + double precision x include 'COMMON.GEO' IF (DABS(X).LT.1.0D0) GOTO 1 ARCOS=PIPOL*(1.0d0-DSIGN(1.0D0,X)) diff --git a/source/unres/src-HCD-5D/brown_step.F b/source/unres/src-HCD-5D/brown_step.F index 8bab9c0..fa1a505 100644 --- a/source/unres/src-HCD-5D/brown_step.F +++ b/source/unres/src-HCD-5D/brown_step.F @@ -11,11 +11,20 @@ c------------------------------------------------ include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' diff --git a/source/unres/src-HCD-5D/cartder.F b/source/unres/src-HCD-5D/cartder.F index dd2b3f1..36b4e63 100644 --- a/source/unres/src-HCD-5D/cartder.F +++ b/source/unres/src-HCD-5D/cartder.F @@ -35,22 +35,33 @@ * * Version of March '95, based on an early version of November '91. * +* 03/11/20 Adam. Array fromto eliminated, computed on the fly +* Fixed the problem with vbld indices, which caused errors in +* derivatives when the backbone virtual bond lengths were not equal. *********************************************************************** - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' + include 'COMMON.IOUNITS' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.INTERACT' - dimension drt(3,3,maxres),rdt(3,3,maxres),dp(3,3),temp(3,3), - & fromto(3,3,maxdim),prordt(3,3,maxres),prodrt(3,3,maxres) - dimension xx(3),xx1(3) - common /przechowalnia/ fromto + double precision drt(3,3,maxres),rdt(3,3,maxres),dp(3,3), + &temp(3,3),prordt(3,3,maxres),prodrt(3,3,maxres) + double precision xx(3),xx1(3),alphi,omegi,xj,dpjk,yp,xp,xxp,yyp + double precision cosalphi,sinalphi,cosomegi,sinomegi,theta2, + & cost2,sint2,rj,dxoiij,tempkl,dxoijk,dsci,zzp,dj,dpkl + double precision fromto(3,3) + integer i,ii,j,jjj,k,l,m,indi,ind,ind1 * get the position of the jth ijth fragment of the chain coordinate system * in the fromto array. + integer indmat indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 + call chainbuild_extconf + call cartprint + call intout * * calculate the derivatives of transformation matrix elements in theta * @@ -80,48 +91,18 @@ drt(3,3,i)=-rt(2,3,i) enddo * -* generate the matrix products of type r(i)t(i)...r(j)t(j) -* - do i=2,nres-2 - ind=indmat(i,i+1) - do k=1,3 - do l=1,3 - temp(k,l)=rt(k,l,i) - enddo - enddo - do k=1,3 - do l=1,3 - fromto(k,l,ind)=temp(k,l) - enddo - enddo - do j=i+1,nres-2 - ind=indmat(i,j+1) - do k=1,3 - do l=1,3 - dpkl=0.0d0 - do m=1,3 - dpkl=dpkl+temp(k,m)*rt(m,l,j) - enddo - dp(k,l)=dpkl - fromto(k,l,ind)=dpkl - enddo - enddo - do k=1,3 - do l=1,3 - temp(k,l)=dp(k,l) - enddo - enddo - enddo - enddo -* * Calculate derivatives. * ind1=0 do i=1,nres-2 - ind1=ind1+1 + ind1=ind1+1 * * Derivatives of DC(i+1) in theta(i+2) * +c write (iout,*) "theta i",i +c write(iout,'(7hprod 9f10.5)')((prod(k,l,i),l=1,3),k=1,3) +c write(iout,'(7hrdt 9f10.5)')((rdt(k,l,i),l=1,3),k=1,3) +c write(iout,*) "vbld",vbld(i+2) do j=1,3 do k=1,2 dpjk=0.0D0 @@ -132,8 +113,10 @@ prordt(j,k,i)=dp(j,k) enddo dp(j,3)=0.0D0 - dcdv(j,ind1)=vbld(i+1)*dp(j,1) +c dcdv(j,ind1)=vbld(i+1)*dp(j,1) + dcdv(j,ind1)=vbld(i+2)*dp(j,1) enddo +c write(iout,'(7hdcdv 3f10.5)')(dcdv(k,ind1),k=1,3) * * Derivatives of SC(i+1) in theta(i+2) * @@ -153,6 +136,7 @@ enddo dxdv(j,ind1)=rj enddo +c write (iout,*) "dxdv",(dxdv(j,ind1),j=1,3) * * Derivatives of SC(i+1) in theta(i+3). The have to be handled differently * than the other off-diagonal derivatives. @@ -164,7 +148,7 @@ enddo dxdv(j,ind1+1)=dxoiij enddo -cd print *,ind1+1,(dxdv(j,ind1+1),j=1,3) +c write(iout,*)ind1+1,(dxdv(j,ind1+1),j=1,3) * * Derivatives of DC(i+1) in phi(i+2) * @@ -177,7 +161,8 @@ cd print *,ind1+1,(dxdv(j,ind1+1),j=1,3) dp(j,k)=dpjk prodrt(j,k,i)=dp(j,k) enddo - dcdv(j+3,ind1)=vbld(i+1)*dp(j,1) +c dcdv(j+3,ind1)=vbld(i+1)*dp(j,1) + dcdv(j+3,ind1)=vbld(i+2)*dp(j,1) enddo * * Derivatives of SC(i+1) in phi(i+2) @@ -207,26 +192,29 @@ cd print *,ind1+1,(dxdv(j,ind1+1),j=1,3) * theta(nres) and phi(i+3) thru phi(nres). * do j=i+1,nres-2 - ind1=ind1+1 - ind=indmat(i+1,j+1) -cd print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 + ind1=ind1+1 + ind=indmat(i+1,j+1) +c write(iout,*)'i=',i,' j=',j,' ind=',ind,' ind1=',ind1 + call build_fromto(i+1,j+1,fromto) +c write(iout,'(7hfromto 9f10.5)')((fromto(k,l),l=1,3),k=1,3) do k=1,3 do l=1,3 tempkl=0.0D0 do m=1,2 - tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind) + tempkl=tempkl+prordt(k,m,i)*fromto(m,l) enddo temp(k,l)=tempkl enddo enddo -cd print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3) -cd print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3) -cd print '(9f8.3)',((temp(k,l),l=1,3),k=1,3) +c write(iout,'(7hfromto 9f10.5)')((fromto(k,l,ind),l=1,3),k=1,3) +c write(iout,'(7hprod 9f10.5)')((prod(k,l,i),l=1,3),k=1,3) +c write(iout,'(7htemp 9f10.5)')((temp(k,l),l=1,3),k=1,3) * Derivatives of virtual-bond vectors in theta do k=1,3 - dcdv(k,ind1)=vbld(i+1)*temp(k,1) +c dcdv(k,ind1)=vbld(i+1)*temp(k,1) + dcdv(k,ind1)=vbld(j+2)*temp(k,1) enddo -cd print '(3f8.3)',(dcdv(k,ind1),k=1,3) +c write(iout,'(7hdcdv 3f10.5)')(dcdv(k,ind1),k=1,3) * Derivatives of SC vectors in theta do k=1,3 dxoijk=0.0D0 @@ -235,9 +223,21 @@ cd print '(3f8.3)',(dcdv(k,ind1),k=1,3) enddo dxdv(k,ind1+1)=dxoijk enddo +c write(iout,'(7htheta 3f10.5)')(dxdv(k,ind1),k=1,3) * *--- Calculate the derivatives in phi * +#ifdef FIVEDIAG + do k=1,3 + do l=1,3 + tempkl=0.0D0 + do m=1,3 + tempkl=tempkl+prodrt(k,m,i)*fromto(m,l) + enddo + temp(k,l)=tempkl + enddo + enddo +#else do k=1,3 do l=1,3 tempkl=0.0D0 @@ -247,9 +247,11 @@ cd print '(3f8.3)',(dcdv(k,ind1),k=1,3) temp(k,l)=tempkl enddo enddo +#endif do k=1,3 - dcdv(k+3,ind1)=vbld(i+1)*temp(k,1) - enddo +c dcdv(k+3,ind1)=vbld(i+1)*temp(k,1) + dcdv(k+3,ind1)=vbld(j+2)*temp(k,1) + enddo do k=1,3 dxoijk=0.0D0 do l=1,3 @@ -259,6 +261,46 @@ cd print '(3f8.3)',(dcdv(k,ind1),k=1,3) enddo enddo enddo +#ifdef DEBUG + write (iout,*) + write (iout,'(a)') '****************** ddc/dtheta' + write (iout,*) + do i=1,nres-2 + do j=i+1,nres-1 + ii = indmat(i,j) + write (iout,'(2i4,3e14.6)') i,j,(dcdv(k,ii),k=1,3) + enddo + enddo + write (iout,*) + write (iout,'(a)') '******************* ddc/dphi' + write (iout,*) + do i=1,nres-3 + do j=i+2,nres-1 + ii = indmat(i+1,j) + write (iout,'(2i4,3e14.6)') i,j,(dcdv(k+3,ii),k=1,3) + write (iout,'(a)') + enddo + enddo + write (iout,'(a)') + write (iout,'(a)') '**************** dx/dtheta' + write (iout,'(a)') + do i=3,nres + do j=i-1,nres-1 + ii = indmat(i-2,j) + write (iout,'(2i4,3e14.6)') i,j,(dxdv(k,ii),k=1,3) + enddo + enddo + write (iout,'(a)') + write (iout,'(a)') '***************** dx/dphi' + write (iout,'(a)') + do i=4,nres + do j=i-1,nres-1 + ii = indmat(i-2,j) + write (iout,'(2i4,3e14.6)') i,j,(dxdv(k+3,ii),k=1,3) + write(iout,'(a)') + enddo + enddo +#endif * * Derivatives in alpha and omega: * @@ -271,44 +313,43 @@ c dsci=dsc(itype(i)) if(alphi.ne.alphi) alphi=100.0 if(omegi.ne.omegi) omegi=-100.0 #else - alphi=alph(i) - omegi=omeg(i) + alphi=alph(i) + omegi=omeg(i) #endif cd print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi - cosalphi=dcos(alphi) - sinalphi=dsin(alphi) - cosomegi=dcos(omegi) - sinomegi=dsin(omegi) - temp(1,1)=-dsci*sinalphi - temp(2,1)= dsci*cosalphi*cosomegi - temp(3,1)=-dsci*cosalphi*sinomegi - temp(1,2)=0.0D0 - temp(2,2)=-dsci*sinalphi*sinomegi - temp(3,2)=-dsci*sinalphi*cosomegi - theta2=pi-0.5D0*theta(i+1) - cost2=dcos(theta2) - sint2=dsin(theta2) - jjj=0 + cosalphi=dcos(alphi) + sinalphi=dsin(alphi) + cosomegi=dcos(omegi) + sinomegi=dsin(omegi) + temp(1,1)=-dsci*sinalphi + temp(2,1)= dsci*cosalphi*cosomegi + temp(3,1)=-dsci*cosalphi*sinomegi + temp(1,2)=0.0D0 + temp(2,2)=-dsci*sinalphi*sinomegi + temp(3,2)=-dsci*sinalphi*cosomegi + theta2=pi-0.5D0*theta(i+1) + cost2=dcos(theta2) + sint2=dsin(theta2) + jjj=0 cd print *,((temp(l,k),l=1,3),k=1,2) do j=1,2 - xp=temp(1,j) - yp=temp(2,j) - xxp= xp*cost2+yp*sint2 - yyp=-xp*sint2+yp*cost2 - zzp=temp(3,j) - xx(1)=xxp - xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1) - xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1) - do k=1,3 - dj=0.0D0 - do l=1,3 - dj=dj+prod(k,l,i-1)*xx(l) + xp=temp(1,j) + yp=temp(2,j) + xxp= xp*cost2+yp*sint2 + yyp=-xp*sint2+yp*cost2 + zzp=temp(3,j) + xx(1)=xxp + xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1) + xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1) + do k=1,3 + dj=0.0D0 + do l=1,3 + dj=dj+prod(k,l,i-1)*xx(l) enddo - dxds(jjj+k,i)=dj + dxds(jjj+k,i)=dj enddo - jjj=jjj+3 - enddo + jjj=jjj+3 + enddo enddo return end - diff --git a/source/unres/src-HCD-5D/cartprint.f b/source/unres/src-HCD-5D/cartprint.f index d79409e..9f7eacb 100644 --- a/source/unres/src-HCD-5D/cartprint.f +++ b/source/unres/src-HCD-5D/cartprint.f @@ -1,5 +1,6 @@ subroutine cartprint - implicit real*8 (a-h,o-z) + implicit none + integer i include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.INTERACT' diff --git a/source/unres/src-HCD-5D/chainbuild.F b/source/unres/src-HCD-5D/chainbuild.F index 9f7e4ac..51419ef 100644 --- a/source/unres/src-HCD-5D/chainbuild.F +++ b/source/unres/src-HCD-5D/chainbuild.F @@ -3,7 +3,7 @@ C C Build the virtual polypeptide chain. Side-chain centroids are moveable. C As of 2/17/95. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.LOCAL' @@ -30,7 +30,7 @@ C C Build the virtual polypeptide chain. Side-chain centroids are moveable. C As of 2/17/95. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.LOCAL' @@ -39,7 +39,11 @@ C include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.INTERACT' + integer i,j double precision e1(3),e2(3),e3(3) + double precision be,be1,alfai + double precision xp,yp,zp,cost2,sint2,cosomegi,sinomegi + double precision dist,alpha,beta logical lprn,perbox,fail lprn=.false. @@ -94,7 +98,9 @@ C C Define the origin and orientation of the coordinate system and locate C the first three atoms. C - implicit real*8 (a-h,o-z) + implicit none + integer i,j + double precision cost,sint include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.LOCAL' @@ -163,7 +169,9 @@ c----------------------------------------------------------------------------- C C Locate CA(i) and SC(i-1) C - implicit real*8 (a-h,o-z) + implicit none + integer i,j + double precision theti,phii,cost,sint,cosphi,sinphi include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.LOCAL' @@ -236,7 +244,7 @@ c----------------------------------------------------------------------------- C C Locate the side-chain centroid i, 1 < i < NRES. Put in C(*,NRES+i). C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.LOCAL' @@ -245,7 +253,10 @@ C include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.INTERACT' - dimension xx(3) + integer i,j,k + double precision xx(3) + double precision dsci,dsci_inv,alphi,omegi,cosalphi,sinalphi, + & cosomegi,sinomegi,xp,yp,zp,theta2,cost2,sint2,rj c dsci=dsc(itype(i)) c dsci_inv=dsc_inv(itype(i)) @@ -310,8 +321,12 @@ c------------------------------------------ #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -326,6 +341,7 @@ c------------------------------------------ include 'COMMON.HAIRPIN' C change suggested by Ana - begin integer allareout + integer i,j C change suggested by Ana - end j=1 chain_beg=1 diff --git a/source/unres/src-HCD-5D/check_bond.f b/source/unres/src-HCD-5D/check_bond.f index c8a4ad1..1c46326 100644 --- a/source/unres/src-HCD-5D/check_bond.f +++ b/source/unres/src-HCD-5D/check_bond.f @@ -1,4 +1,6 @@ subroutine check_bond + implicit none + integer i,it C Subroutine is checking if the fitted function which describs sc_rot_pot C is correct, printing, alpha,beta, energy, data - for some known theta. C theta angle is read from the input file. Sc_rot_pot are printed diff --git a/source/unres/src-HCD-5D/checkder_p.F b/source/unres/src-HCD-5D/checkder_p.F index 03df287..48eedda 100644 --- a/source/unres/src-HCD-5D/checkder_p.F +++ b/source/unres/src-HCD-5D/checkder_p.F @@ -1,181 +1,7 @@ - subroutine check_cartgrad -C Check the gradient of Cartesian coordinates in internal coordinates. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.DERIV' - dimension temp(6,maxres),xx(3),gg(3) - indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1 -* -* Check the gradient of the virtual-bond and SC vectors in the internal -* coordinates. -* - print '("Calling CHECK_ECART",1pd12.3)',aincr - write (iout,'("Calling CHECK_ECART",1pd12.3)') aincr - aincr2=0.5d0*aincr - call cartder - write (iout,'(a)') '**************** dx/dalpha' - write (iout,'(a)') - do i=2,nres-1 - alphi=alph(i) - alph(i)=alph(i)+aincr - do k=1,3 - temp(k,i)=dc(k,nres+i) - enddo - call chainbuild - do k=1,3 - gg(k)=(dc(k,nres+i)-temp(k,i))/aincr - xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr)) - enddo - write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') - & i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - alph(i)=alphi - call chainbuild - enddo - write (iout,'(a)') - write (iout,'(a)') '**************** dx/domega' - write (iout,'(a)') - do i=2,nres-1 - omegi=omeg(i) - omeg(i)=omeg(i)+aincr - do k=1,3 - temp(k,i)=dc(k,nres+i) - enddo - call chainbuild - do k=1,3 - gg(k)=(dc(k,nres+i)-temp(k,i))/aincr - xx(k)=dabs((gg(k)-dxds(k+3,i))/ - & (aincr*dabs(dxds(k+3,i))+aincr)) - enddo - write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') - & i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - omeg(i)=omegi - call chainbuild - enddo - write (iout,'(a)') - write (iout,'(a)') '**************** dx/dtheta' - write (iout,'(a)') - do i=3,nres - theti=theta(i) - theta(i)=theta(i)+aincr - do j=i-1,nres-1 - do k=1,3 - temp(k,j)=dc(k,nres+j) - enddo - enddo - call chainbuild - do j=i-1,nres-1 - ii = indmat(i-2,j) -c print *,'i=',i-2,' j=',j-1,' ii=',ii - do k=1,3 - gg(k)=(dc(k,nres+j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dxdv(k,ii))/ - & (aincr*dabs(dxdv(k,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3) - write(iout,'(a)') - enddo - write (iout,'(a)') - theta(i)=theti - call chainbuild - enddo - write (iout,'(a)') '***************** dx/dphi' - write (iout,'(a)') - do i=4,nres - phi(i)=phi(i)+aincr - do j=i-1,nres-1 - do k=1,3 - temp(k,j)=dc(k,nres+j) - enddo - enddo - call chainbuild - do j=i-1,nres-1 - ii = indmat(i-2,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,nres+j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ - & (aincr*dabs(dxdv(k+3,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3) - write(iout,'(a)') - enddo - phi(i)=phi(i)-aincr - call chainbuild - enddo - write (iout,'(a)') '****************** ddc/dtheta' - do i=1,nres-2 - thet=theta(i+2) - theta(i+2)=thet+aincr - do j=i,nres - do k=1,3 - temp(k,j)=dc(k,j) - enddo - enddo - call chainbuild - do j=i+1,nres-1 - ii = indmat(i,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dcdv(k,ii))/ - & (aincr*dabs(dcdv(k,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - enddo - do j=1,nres - do k=1,3 - dc(k,j)=temp(k,j) - enddo - enddo - theta(i+2)=thet - enddo - write (iout,'(a)') '******************* ddc/dphi' - do i=1,nres-3 - phii=phi(i+3) - phi(i+3)=phii+aincr - do j=1,nres - do k=1,3 - temp(k,j)=dc(k,j) - enddo - enddo - call chainbuild - do j=i+2,nres-1 - ii = indmat(i+1,j) -c print *,'ii=',ii - do k=1,3 - gg(k)=(dc(k,j)-temp(k,j))/aincr - xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ - & (aincr*dabs(dcdv(k+3,ii))+aincr)) - enddo - write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') - & i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3) - write (iout,'(a)') - enddo - do j=1,nres - do k=1,3 - dc(k,j)=temp(k,j) - enddo - enddo - phi(i+3)=phii - enddo - return - end C---------------------------------------------------------------------------- subroutine check_ecart C Check the gradient of the energy in Cartesian coordinates. - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.CHAIN' @@ -183,12 +9,20 @@ C Check the gradient of the energy in Cartesian coordinates. include 'COMMON.IOUNITS' include 'COMMON.VAR' include 'COMMON.CONTACTS' + integer i,j,k + integer icall common /srutu/ icall - dimension ggg(6),cc(3),xx(3),ddc(3),ddx(3),x(maxvar),g(maxvar) - dimension grad_s(6,maxres) + double precision ggg(6),cc(3),xx(3),ddc(3),ddx(3),x(maxvar), + & g(maxvar),grad_s(6,maxres) double precision energia(0:n_ene),energia1(0:n_ene) + double precision aincr2,etot,etot1,etot2 + double precision dist,alpha,beta + double precision funcgrad,ff + external funcgrad + integer nf integer uiparm(1) double precision urparm(1) + double precision fdum external fdum icg=1 nf=0 @@ -202,7 +36,11 @@ C Check the gradient of the energy in Cartesian coordinates. call etotal(energia(0)) etot=energia(0) call enerprint(energia(0)) +#ifdef LBFGS + ff=funcgrad(x,g) +#else call gradient(nvar,x,nf,g,uiparm,urparm,fdum) +#endif icall =1 do i=1,nres write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3) @@ -253,7 +91,7 @@ C Check the gradient of the energy in Cartesian coordinates. c---------------------------------------------------------------------------- subroutine check_ecartint C Check the gradient of the energy in Cartesian coordinates. - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.CHAIN' @@ -264,23 +102,27 @@ C Check the gradient of the energy in Cartesian coordinates. include 'COMMON.MD' include 'COMMON.LOCAL' include 'COMMON.SPLITELE' + integer icall common /srutu/ icall - dimension ggg(6),ggg1(6),cc(3),xx(3),ddc(3),ddx(3),x(maxvar), - & g(maxvar) - dimension dcnorm_safe(3),dxnorm_safe(3) - dimension grad_s(6,0:maxres),grad_s1(6,0:maxres) + double precision ggg(6),ggg1(6),cc(3),xx(3),ddc(3),ddx(3), + & x(maxvar),g(maxvar) + double precision dcnorm_safe(3),dxnorm_safe(3) + double precision grad_s(6,0:maxres),grad_s1(6,0:maxres) double precision phi_temp(maxres),theta_temp(maxres), & alph_temp(maxres),omeg_temp(maxres) double precision energia(0:n_ene),energia1(0:n_ene) integer uiparm(1) double precision urparm(1) external fdum + integer i,j,k,nf + double precision etot,etot1,etot2,etot11,etot12,etot21,etot22 + double precision dist,alpha,beta c r_cut=2.0d0 c rlambd=0.3d0 icg=1 nf=0 nfl=0 - print *,"ATU 3" +c print *,"ATU 3" call int_from_cart1(.false.) call intout c call intcartderiv @@ -325,15 +167,15 @@ c call flush(iout) call etotal_long(energia(0)) call enerprint(energia(0)) call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) +c write (iout,*) "enter cartgrad" +c call flush(iout) call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) +c write (iout,*) "exit cartgrad" +c call flush(iout) icall =1 write (iout,*) "longrange grad" do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + write (iout,'(i4,3e12.4,3x,3e12.4)') i,(gcart(j,i),j=1,3), & (gxcart(j,i),j=1,3) enddo do j=1,3 @@ -349,15 +191,15 @@ c call flush(iout) call etotal_short(energia(0)) call enerprint(energia(0)) call flush(iout) - write (iout,*) "enter cartgrad" - call flush(iout) +c write (iout,*) "enter cartgrad" +c call flush(iout) call cartgrad - write (iout,*) "exit cartgrad" - call flush(iout) +c write (iout,*) "exit cartgrad" +c call flush(iout) icall =1 write (iout,*) "shortrange grad" do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + write (iout,'(i4,3e12.4,3x,3e12.4)') i,(gcart(j,i),j=1,3), & (gxcart(j,i),j=1,3) enddo do j=1,3 @@ -493,7 +335,7 @@ c write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2 end c------------------------------------------------------------------------- subroutine int_from_cart1(lprn) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -509,6 +351,10 @@ c------------------------------------------------------------------------- include 'COMMON.SETUP' include 'COMMON.TIME1' logical lprn + integer i,j + double precision dnorm1,dnorm2,be + double precision time00 + double precision dist,alpha,beta if (lprn) write (iout,'(/a)') 'Recalculated internal coordinates' #ifdef TIMING time01=MPI_Wtime() @@ -635,7 +481,7 @@ cd call flush(iout) c---------------------------------------------------------------------------- subroutine check_eint C Check the gradient of energy in internal coordinates. - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.CHAIN' @@ -643,14 +489,20 @@ C Check the gradient of energy in internal coordinates. include 'COMMON.IOUNITS' include 'COMMON.VAR' include 'COMMON.GEO' + integer icall common /srutu/ icall - dimension x(maxvar),gana(maxvar),gg(maxvar) + double precision x(maxvar),gana(maxvar),gg(maxvar) integer uiparm(1) double precision urparm(1) double precision energia(0:n_ene),energia1(0:n_ene), & energia2(0:n_ene) character*6 key + double precision fdum external fdum + double precision funcgrad,ff + external funcgrad + integer i,ii,nf + double precision xi,etot,etot1,etot2 call zerograd c aincr=1.0D-7 print '("Calling CHECK_INT",1pd12.3)',aincr @@ -678,7 +530,15 @@ c aincr=1.0D-7 nf=1 nfl=3 cd write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar) +c write (iout,*) "Before gradient" +c call flush(iout) +#ifdef LBFGS + ff=funcgrad(x,gana) +#else call gradient(nvar,x,nf,gana,uiparm,urparm,fdum) +#endif +c write (iout,*) "After gradient" +c call flush(iout) cd write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar) icall=1 do i=1,nvar @@ -694,7 +554,7 @@ cd write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar) call etotal(energia2(0)) etot2=energia2(0) gg(i)=(etot2-etot1)/aincr - write (iout,*) i,etot1,etot2 +c write (iout,*) i,etot1,etot2 x(i)=xi enddo write (iout,'(/2a)')' Variable Numerical Analytical', diff --git a/source/unres/src-HCD-5D/contact.f b/source/unres/src-HCD-5D/contact.f index cc4e0b7..695446f 100644 --- a/source/unres/src-HCD-5D/contact.f +++ b/source/unres/src-HCD-5D/contact.f @@ -114,11 +114,13 @@ c---------------------------------------------------------------------------- kkk=0 c print *,'nnt=',nnt,' nct=',nct do i=nnt,nct-3 + if (itype(i).eq.ntyp1) cycle do k=1,3 c(k,2*nres+1)=0.5d0*(c(k,i)+c(k,i+1)) enddo do j=i+2,nct-1 do k=1,3 + if (itype(j).eq.ntyp1) cycle c(k,2*nres+2)=0.5d0*(c(k,j)+c(k,j+1)) enddo if (dist(2*nres+1,2*nres+2).lt.rcomp) then diff --git a/source/unres/src-HCD-5D/convert.f b/source/unres/src-HCD-5D/convert.f index dc0cccd..7d992fa 100644 --- a/source/unres/src-HCD-5D/convert.f +++ b/source/unres/src-HCD-5D/convert.f @@ -9,11 +9,12 @@ C 2*nres-4+nside C 4. The torsional angles omega of SC orientation: 2*nres-4+nside+1 C thru 2*nre-4+2*nside C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.CHAIN' + integer n,i double precision x(n) cd print *,'nres',nres,' nphi',nphi,' ntheta',ntheta,' nvar',nvar do i=4,nres @@ -40,14 +41,17 @@ C-------------------------------------------------------------------- C C Update geometry parameters according to the variable array. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.GEO' include 'COMMON.IOUNITS' - dimension x(n) + integer n + integer i,ii + double precision x(n) logical change,reduce + double precision pinorm change=reduce(x) if (n.gt.nphi+ntheta) then do i=1,nside @@ -87,13 +91,15 @@ c------------------------------------------------------------------------- C C Apply periodic restrictions to variables. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.GEO' logical zm,zmiana,convert_side - dimension x(nvar) + integer i,ii,iii + double precision x(nvar) + double precision thetnorm,pinorm zmiana=.false. do i=4,nres x(i-3)=pinorm(x(i-3)) @@ -167,14 +173,16 @@ C-------------------------------------------------------------------- C C Update geometry parameters according to the variable array. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.GEO' include 'COMMON.IOUNITS' - dimension x(maxvar),xx(maxvar) + integer n,i,ii + double precision x(maxvar),xx(maxvar) logical change,reduce + double precision pinorm call xx2x(x,xx) change=reduce(x) diff --git a/source/unres/src-HCD-5D/deconstrq_num.F b/source/unres/src-HCD-5D/deconstrq_num.F deleted file mode 100644 index faaa4e8..0000000 --- a/source/unres/src-HCD-5D/deconstrq_num.F +++ /dev/null @@ -1,125 +0,0 @@ - subroutine dEconstrQ_num -c Calculating numerical dUconst/ddc and dUconst/ddx - 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' - include 'COMMON.TIME1' - double precision uzap1,uzap2 - double precision dUcartan(3,0:MAXRES) - & ,dUxcartan(3,0:MAXRES),cdummy(3,0:MAXRES) - integer kstart,kend,lstart,lend,idummy - double precision delta /1.0d-7/ -c For the backbone - do i=0,nres-1 - do j=1,3 - dUcartan(j,i)=0.0d0 - cdummy(j,i)=dc(j,i) - dc(j,i)=dc(j,i)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true. - & ,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii), - & qinpair(ii,iset)) - enddo - dc(j,i)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true. - & ,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii), - & qinpair(ii,iset)) - enddo - ducartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo -c Calculating numerical gradients for dU/ddx - do i=0,nres-1 - duxcartan(j,i)=0.0d0 - do j=1,3 - cdummy(j,i)=dc(j,i+nres) - dc(j,i+nres)=dc(j,i+nres)+delta - call chainbuild_cart - uzap2=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true. - & ,idummy,idummy) - uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii), - & qinpair(ii,iset)) - enddo - dc(j,i+nres)=cdummy(j,i) - call chainbuild_cart - uzap1=0.0d0 - do ii=1,nfrag - qfrag(ii)=qwolynes(ifrag(1,ii,iset), - & ifrag(2,ii,iset),.true.,idummy,idummy) - uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii), - & qinfrag(ii,iset)) - enddo - do ii=1,npair - kstart=ifrag(1,ipair(1,ii,iset),iset) - kend=ifrag(2,ipair(1,ii,iset),iset) - lstart=ifrag(1,ipair(2,ii,iset),iset) - lend=ifrag(2,ipair(2,ii,iset),iset) - qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend) - uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii), - & qinpair(ii,iset)) - enddo - duxcartan(j,i)=(uzap2-uzap1)/(delta) - enddo - enddo - write(iout,*) "Numerical dUconst/ddc backbone " - do ii=0,nres - write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3) - enddo -c write(iout,*) "Numerical dUconst/ddx side-chain " -c do ii=1,nres -c write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3) -c enddo - return - end -c--------------------------------------------------------------------------- - diff --git a/source/unres/src-HCD-5D/econstr_local.F b/source/unres/src-HCD-5D/econstr_local.F index f11acfb..64f5e35 100644 --- a/source/unres/src-HCD-5D/econstr_local.F +++ b/source/unres/src-HCD-5D/econstr_local.F @@ -1,15 +1,20 @@ subroutine Econstr_back c MD with umbrella_sampling using Wolyne's distance measure as a constraint - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' + include 'COMMON.QRESTR' #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -18,6 +23,9 @@ c MD with umbrella_sampling using Wolyne's distance measure as a constraint include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.TIME1' + integer i,j,ii,k + double precision utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz + double precision pinorm Uconst_back=0.0d0 do i=1,nres dutheta(i)=0.0d0 diff --git a/source/unres/src-HCD-5D/econstr_qlike.F b/source/unres/src-HCD-5D/econstr_qlike.F index 9086093..1190ebf 100644 --- a/source/unres/src-HCD-5D/econstr_qlike.F +++ b/source/unres/src-HCD-5D/econstr_qlike.F @@ -1,15 +1,20 @@ subroutine Econstr_back_qlike c MD with umbrella_sampling using Wolyne's distance measure as a constraint - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' + include 'COMMON.QRESTR' #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -18,10 +23,14 @@ c MD with umbrella_sampling using Wolyne's distance measure as a constraint include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.TIME1' + integer i,ii,j,k + double precision utheta_i,dtheta_i,expthet,ugamma_i,dgamma_i, + & expgam,usc_i,dxx,dyy,dzz,expsc double precision sigmaang/0.1d0/,sigmadih /0.1d0/,sigmasc /0.1d0/ c double precision sigmaang/0.2d0/,sigmadih /0.4d0/,sigmasc /0.5d0/ double precision auxvec(maxres),auxtab(3,maxres), & auxtab1(3,maxres),auxtabx(3,maxres) + double precision pinorm Uconst_back=0.0d0 do i=1,nres dutheta(i)=0.0d0 diff --git a/source/unres/src-HCD-5D/econstrq-PMF.F b/source/unres/src-HCD-5D/econstrq-PMF.F index 58d89b4..a5d1d78 100644 --- a/source/unres/src-HCD-5D/econstrq-PMF.F +++ b/source/unres/src-HCD-5D/econstrq-PMF.F @@ -1,6 +1,6 @@ subroutine EconstrQ c MD with umbrella_sampling using Wolyne's distance measure as a constraint - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -8,12 +8,17 @@ c MD with umbrella_sampling using Wolyne's distance measure as a constraint #endif include 'COMMON.CONTROL' include 'COMMON.VAR' - include 'COMMON.MD' +c include 'COMMON.MD' + include 'COMMON.QRESTR' #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -28,6 +33,9 @@ c MD with umbrella_sampling using Wolyne's distance measure as a constraint & duconst(3,0:MAXRES),duxconst(3,0:MAXRES) integer kstart,kend,lstart,lend,idummy double precision delta /1.0d-7/ + integer i,ii,j,k + double precision qwolynes,harmonic,harmonicprim + double precision ePMF,ePMF_q do i=0,nres do j=1,3 duconst(j,i)=0.0d0 @@ -83,9 +91,6 @@ c Calculating the derivatives of Q with respect to cartesian coordinates write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) enddo #endif -c Calculating numerical gradients of dU/dQi and dQi/dxi -c call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true. -c & ,idummy,idummy) c The gradients of Uconst in Cs do ii=0,nres do j=1,3 @@ -120,9 +125,6 @@ c write(iout,*) "dxqwol " c do ii=1,nres c write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) c enddo -c Calculating numerical gradients -c call qwol_num(kstart,kend,.false. -c & ,lstart,lend) c The gradients of Uconst in Cs do ii=0,nres do j=1,3 @@ -156,7 +158,5 @@ c Transforming the gradients from Cs to dCs for the side chains write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) enddo #endif -c Calculating numerical gradients of dUconst/ddc and dUconst/ddx -c call dEconstrQ_num return end diff --git a/source/unres/src-HCD-5D/econstrq.F b/source/unres/src-HCD-5D/econstrq.F index e8dadcc..152fbb6 100644 --- a/source/unres/src-HCD-5D/econstrq.F +++ b/source/unres/src-HCD-5D/econstrq.F @@ -5,11 +5,16 @@ c MD with umbrella_sampling using Wolyne's distance measure as a constraint include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' + include 'COMMON.QRESTR' #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -62,9 +67,6 @@ c write(iout,*) "dxqwol " c do ii=1,nres c write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) c enddo -c Calculating numerical gradients of dU/dQi and dQi/dxi -c call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true. -c & ,idummy,idummy) c The gradients of Uconst in Cs do ii=0,nres do j=1,3 @@ -99,9 +101,6 @@ c write(iout,*) "dxqwol " c do ii=1,nres c write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3) c enddo -c Calculating numerical gradients -c call qwol_num(kstart,kend,.false. -c & ,lstart,lend) c The gradients of Uconst in Cs do ii=0,nres do j=1,3 @@ -133,7 +132,5 @@ c write(iout,*) "dU/ddX side chain " c do ii=1,nres c write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3) c enddo -c Calculating numerical gradients of dUconst/ddc and dUconst/ddx -c call dEconstrQ_num return end diff --git a/source/unres/src-HCD-5D/elecont.f b/source/unres/src-HCD-5D/elecont.f index 73325f2..690fd44 100644 --- a/source/unres/src-HCD-5D/elecont.f +++ b/source/unres/src-HCD-5D/elecont.f @@ -12,6 +12,7 @@ double precision app_(2,2),bpp_(2,2),rpp_(2,2) integer ncont,icont(2,maxcont) double precision econt(maxcont) + integer xshift,yshift,zshift * * Load the constants of peptide bond - peptide bond interactions. * Type 1 - ordinary peptide bond, type 2 - alkylated peptide bond (e.g. @@ -52,13 +53,16 @@ c data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/ xmedi=xi+0.5*dxi ymedi=yi+0.5*dyi zmedi=zi+0.5*dzi +c write (iout,*) "i",xmedi,ymedi,zmedi xmedi=mod(xmedi,boxxsize) if (xmedi.lt.0) xmedi=xmedi+boxxsize ymedi=mod(ymedi,boxysize) if (ymedi.lt.0) ymedi=ymedi+boxysize zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize +c write (iout,*) "i",xmedi,ymedi,zmedi do 4 j=i+2,nct-1 +c write (iout,*) "i",i," j",j if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) goto 4 ind=ind+1 iteli=itel(i) @@ -75,13 +79,16 @@ c data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/ xj=c(1,j)+0.5*dxj yj=c(2,j)+0.5*dyj zj=c(3,j)+0.5*dzj +c write (iout,*) "j",xj,yj,zj xj=mod(xj,boxxsize) if (xj.lt.0) xj=xj+boxxsize yj=mod(yj,boxysize) if (yj.lt.0) yj=yj+boxysize zj=mod(zj,boxzsize) if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 +c write (iout,*) "j",xj,yj,zj + dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 +c write (iout,*) "dist",dsqrt(dist_init) xj_safe=xj yj_safe=yj zj_safe=zj @@ -92,7 +99,9 @@ c data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/ xj=xj_safe+xshift*boxxsize yj=yj_safe+yshift*boxysize zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 +c write (iout,*) "shift",xshift,yshift,zshift," dist_temp", +c & dist_temp," dist_init",dist_init if(dist_temp.lt.dist_init) then dist_init=dist_temp xj_temp=xj @@ -113,8 +122,6 @@ c data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/ zj=zj_safe-zmedi endif rij=xj*xj+yj*yj+zj*zj - sss=sscale(sqrt(rij)) - sssgrad=sscagrad(sqrt(rij)) rrmij=1.0/(xj*xj+yj*yj+zj*zj) rmij=sqrt(rrmij) r3ij=rrmij*rmij @@ -140,7 +147,7 @@ c data epp / 0.3045d0, 0.3649d0, 0.3649d0, 0.5743d0/ econt(ncont)=eesij endif ees=ees+eesij - evdw=evdw+evdwij*sss +c write (iout,*) "i"," j",j," rij",dsqrt(rij)," eesij",eesij 4 continue 1 continue if (lprint) then @@ -251,7 +258,7 @@ c-------------------------------------------- include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.CONTROL' diff --git a/source/unres/src-HCD-5D/energy_p_new-sep_barrier.F b/source/unres/src-HCD-5D/energy_p_new-sep_barrier.F index 1f00b2b..93fe9ab 100644 --- a/source/unres/src-HCD-5D/energy_p_new-sep_barrier.F +++ b/source/unres/src-HCD-5D/energy_p_new-sep_barrier.F @@ -1,5 +1,6 @@ C----------------------------------------------------------------------- double precision function sscalelip(r) + implicit none double precision r,gamm include "COMMON.SPLITELE" C if(r.lt.r_cut-rlamb) then @@ -14,6 +15,7 @@ C endif end C----------------------------------------------------------------------- double precision function sscagradlip(r) + implicit none double precision r,gamm include "COMMON.SPLITELE" C if(r.lt.r_cut-rlamb) then @@ -28,8 +30,9 @@ C endif end C----------------------------------------------------------------------- - double precision function sscale(r) - double precision r,gamm + double precision function sscale(r,r_cut) + implicit none + double precision r,r_cut,gamm include "COMMON.SPLITELE" if(r.lt.r_cut-rlamb) then sscale=1.0d0 @@ -42,9 +45,9 @@ C----------------------------------------------------------------------- return end C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - double precision function sscagrad(r) - double precision r,gamm + double precision function sscagrad(r,r_cut) + implicit none + double precision r,r_cut,gamm include "COMMON.SPLITELE" if(r.lt.r_cut-rlamb) then sscagrad=0.0d0 @@ -62,9 +65,8 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the LJ potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' - parameter (accur=1.0d-10) include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.LOCAL' @@ -75,14 +77,20 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) + include "COMMON.SPLITELE" +c include 'COMMON.CONTACTS' + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj,itypi1,num_conti,iint + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij, + & sigij,r0ij,rcut,sss1,sssgrad1,sqrij + double precision sscale,sscagrad c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -93,25 +101,33 @@ C cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), cd & 'iend=',iend(i,iint) do j=istart(i,iint),iend(i,iint) - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi rij=xj*xj+yj*yj+zj*zj - sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) + sqrij=dsqrt(rrij) + eps0ij=eps(itypi,itypj) + sss1=sscale(sqrij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(sqrij,r_cut_int) + sssgrad= + & sscagrad(sqrij/sigma(itypi,itypj),r_cut_respa) + sss=sscale(sqrij/sigma(itypi,itypj),r_cut_respa) if (sss.lt.1.0d0) then rrij=1.0D0/rij - eps0ij=eps(itypi,itypj) fac=rrij**expon2 e1=fac*fac*aa e2=fac*bb evdwij=e1+e2 - evdw=evdw+(1.0d0-sss)*evdwij + evdw=evdw+(1.0d0-sss)*sss1*evdwij/sqrij/expon C C Calculate the components of the gradient in DC and X C - fac=-rrij*(e1+evdwij)*(1.0d0-sss) + fac=-rrij*(e1+evdwij)*(1.0d0-sss)*sss1 + & +evdwij*(-sss1*sssgrad/sigma(itypi,itypj) + & +(1.0d0-sss)*sssgrad1)/sqrij gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -148,9 +164,8 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the LJ potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' - parameter (accur=1.0d-10) include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.LOCAL' @@ -161,14 +176,20 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) + include "COMMON.SPLITELE" +c include 'COMMON.CONTACTS' + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj,itypi1,num_conti,iint + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij, + & sigij,r0ij,rcut,sqrij,sss1,sssgrad1 + double precision sscale,sscagrad c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -181,15 +202,18 @@ C cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), cd & 'iend=',iend(i,iint) do j=istart(i,iint),iend(i,iint) - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi zj=c(3,nres+j)-zi C Change 12/1/95 to calculate four-body interactions rij=xj*xj+yj*yj+zj*zj - sss=sscale(dsqrt(rij)/sigma(itypi,itypj)) + sqrij=dsqrt(rij) + sss=sscale(sqrij/sigma(itypi,itypj),r_cut_respa) if (sss.gt.0.0d0) then + sssgrad= + & sscagrad(sqrij/sigma(itypi,itypj),r_cut_respa) rrij=1.0D0/rij eps0ij=eps(itypi,itypj) fac=rrij**expon2 @@ -200,7 +224,7 @@ C Change 12/1/95 to calculate four-body interactions C C Calculate the components of the gradient in DC and X C - fac=-rrij*(e1+evdwij)*sss + fac=-rrij*(e1+evdwij)*sss+evdwij*sssgrad/sqrij/expon gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -237,7 +261,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the LJK potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -247,14 +271,20 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.NAMES' - dimension gg(3) + include "COMMON.SPLITELE" + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj,itypi1,iint + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij, + & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1 logical scheck + double precision sscale,sscagrad c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -263,7 +293,7 @@ C Calculate SC interaction energy. C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi @@ -273,8 +303,13 @@ C e_augm=augm(itypi,itypj)*fac_augm r_inv_ij=dsqrt(rrij) rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) + sss1=sscale(rij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(rij,r_cut_int) + sss=sscale(rij/sigma(itypi,itypj),r_cut_respa) if (sss.lt.1.0d0) then + sssgrad= + & sscagrad(rij/sigma(itypi,itypj),r_cut_respa) r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) fac=r_shift_inv**expon e1=fac*fac*aa @@ -287,12 +322,14 @@ cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+(1.0d0-sss)*evdwij + evdw=evdw+(1.0d0-sss)*sss1*evdwij C C Calculate the components of the gradient in DC and X C fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) - fac=fac*(1.0d0-sss) + fac=fac*(1.0d0-sss)*sss1 + & +evdwij*(-sss1*sssgrad/sigma(itypi,itypj) + & +(1.0d0-sss)*sssgrad1)*r_inv_ij/expon gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -330,14 +367,20 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.NAMES' - dimension gg(3) + include "COMMON.SPLITELE" + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj,itypi1,iint + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij, + & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1 logical scheck + double precision sscale,sscagrad c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -346,7 +389,7 @@ C Calculate SC interaction energy. C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle xj=c(1,nres+j)-xi yj=c(2,nres+j)-yi @@ -356,7 +399,7 @@ C e_augm=augm(itypi,itypj)*fac_augm r_inv_ij=dsqrt(rrij) rij=1.0D0/r_inv_ij - sss=sscale(rij/sigma(itypi,itypj)) + sss=sscale(rij/sigma(itypi,itypj),r_cut_respa) if (sss.gt.0.0d0) then r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) fac=r_shift_inv**expon @@ -375,6 +418,7 @@ C C Calculate the components of the gradient in DC and X C fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) + & +evdwij*sssgrad/sigma(itypi,itypj)*r_inv_ij/expon fac=fac*sss gg(1)=xj*fac gg(2)=yj*fac @@ -403,7 +447,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Berne-Pechukas potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -414,7 +458,14 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' + include "COMMON.SPLITELE" + integer icall common /srutu/ icall + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi + double precision sss1,sssgrad1 + double precision sscale,sscagrad c double precision rrsave(maxdim) logical lprn evdw=0.0D0 @@ -427,9 +478,9 @@ c else c endif ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -444,7 +495,7 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle c dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) @@ -465,10 +516,13 @@ c dscj_inv=dsc_inv(itypj) dzj=dc_norm(3,nres+j) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - + sss1=sscale(1.0d0/rij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)),r_cut_respa) if (sss.lt.1.0d0) then - + sssgrad= + & sscagrad(1.0d0/(rij*sigmaii(itypi,itypj)),r_cut_respa) + sssgrad1=sscagrad(1.0d0/rij,r_cut_int) C Calculate the angle-dependent terms of energy & contributions to derivatives. call sc_angular C Calculate whole angle-dependent part of epsilon and contributions @@ -480,7 +534,7 @@ C to its derivatives eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*(1.0d0-sss) + evdw=evdw+evdwij*(1.0d0-sss)*sss1 if (lprn) then sigm=dabs(aa/bb)**(1.0D0/6.0D0) epsi=bb**2/aa @@ -495,14 +549,15 @@ C Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 fac=-expon*(e1+evdwij) sigder=fac/sigsq - fac=rrij*fac + fac=(fac+evdwij*(sss1/(1.0d0-sss)*sssgrad/ + & sigmaii(itypi,itypj)+(1.0d0-sss)/sss1*sssgrad1))*rij C Calculate radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac C Calculate the angular part of the gradient and sum add the contributions C to the appropriate components of the Cartesian gradient. - call sc_grad_scale(1.0d0-sss) + call sc_grad_scale((1.0d0-sss)*sss1) endif enddo ! j enddo ! iint @@ -527,7 +582,13 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' + include "COMMON.SPLITELE" + integer icall common /srutu/ icall + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi + double precision sscale,sscagrad c double precision rrsave(maxdim) logical lprn evdw=0.0D0 @@ -540,9 +601,9 @@ c else c endif ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -557,7 +618,7 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle c dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) @@ -578,7 +639,7 @@ c dscj_inv=dsc_inv(itypj) dzj=dc_norm(3,nres+j) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)),r_cut_respa) if (sss.gt.0.0d0) then @@ -608,7 +669,7 @@ C Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 fac=-expon*(e1+evdwij) sigder=fac/sigsq - fac=rrij*fac + fac=(fac+evdwij*sssgrad/sss/sigmaii(itypi,itypj))*rrij C Calculate radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac @@ -629,7 +690,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Gay-Berne potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -641,8 +702,17 @@ C include 'COMMON.IOUNITS' include 'COMMON.CALC' include 'COMMON.CONTROL' + include "COMMON.SPLITELE" logical lprn integer xshift,yshift,zshift + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi + double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij, + & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip + double precision dist,sscale,sscagrad,sscagradlip,sscalelip + double precision subchap,sss1,sssgrad1 evdw=0.0D0 ccccc energy_dec=.false. c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon @@ -651,9 +721,9 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon c if (icall.eq.0) lprn=.false. ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -676,7 +746,7 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle c dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) @@ -696,81 +766,81 @@ c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) xj=c(1,nres+j) yj=c(2,nres+j) zj=c(3,nres+j) - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - if ((zj.gt.bordlipbot) - &.and.(zj.lt.bordliptop)) then + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + if ((zj.gt.bordlipbot).and.(zj.lt.bordliptop)) then C the energy transfer exist - if (zj.lt.buflipbot) then + if (zj.lt.buflipbot) then C what fraction I am in - fracinbuf=1.0d0- - & ((positi-bordlipbot)/lipbufthick) + fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick) C lipbufthick is thickenes of lipid buffore - sslipj=sscalelip(fracinbuf) - ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick - elseif (zi.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) - sslipj=sscalelip(fracinbuf) - ssgradlipj=sscagradlip(fracinbuf)/lipbufthick - else - sslipj=1.0d0 - ssgradlipj=0.0 - endif - else - sslipj=0.0d0 - ssgradlipj=0.0 - endif - aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 - & +aa_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 - bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 - & +bb_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 - - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - sssgrad=sscagrad((1.0d0/rij)/sigmaii(itypi,itypj)) - if (sss.lt.1.0d0) then - + sslipj=sscalelip(fracinbuf) + ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick + else if (zi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick) + sslipj=sscalelip(fracinbuf) + ssgradlipj=sscagradlip(fracinbuf)/lipbufthick + else + sslipj=1.0d0 + ssgradlipj=0.0 + endif + else + sslipj=0.0d0 + ssgradlipj=0.0 + endif + aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +aa_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 + bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +bb_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + if (dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + subchap=1 + endif + enddo + enddo + enddo + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif + dxj=dc_norm(1,nres+j) + dyj=dc_norm(2,nres+j) + dzj=dc_norm(3,nres+j) + rrij=1.0D0/(xj*xj+yj*yj+zj*zj) + rij=dsqrt(rrij) + sss1=sscale(1.0d0/rij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)),r_cut_respa) + if (sss.lt.1.0d0) then C Calculate angle-dependent terms of energy and contributions to their C derivatives. + sssgrad= + & sscagrad((1.0d0/rij)/sigmaii(itypi,itypj),r_cut_respa) + sssgrad1=sscagrad(1.0d0/rij,r_cut_int) call sc_angular sigsq=1.0D0/sigsq sig=sig0ij*dsqrt(sigsq) @@ -797,7 +867,7 @@ c--------------------------------------------------------------- c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt, c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij*(1.0d0-sss) + evdw=evdw+evdwij*(1.0d0-sss)*sss1 if (lprn) then sigm=dabs(aa/bb)**(1.0D0/6.0D0) epsi=bb**2/aa @@ -809,15 +879,15 @@ c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 & evdwij endif - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij + if (energy_dec) write (iout,'(a6,2i5,4f10.5)') + & 'evdw',i,j,rij,sss,sss1,evdwij C Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder - fac=rij*fac - fac=fac+evdwij/(1.0-sss)*(-sssgrad)/sigmaii(itypi,itypj)*rij + fac=(fac+evdwij*(-sss1*sssgrad/(1.0d0-sss) + & /sigmaii(itypi,itypj)+(1.0d0-sss)*sssgrad1/sss1))*rij c fac=0.0d0 C Calculate the radial part of the gradient gg(1)=xj*fac @@ -826,7 +896,7 @@ C Calculate the radial part of the gradient gg_lipi(3)=ssgradlipi*evdwij gg_lipj(3)=ssgradlipj*evdwij C Calculate angular part of the gradient. - call sc_grad_scale(1.0d0-sss) + call sc_grad_scale((1.0d0-sss)*sss1) endif enddo ! j enddo ! iint @@ -841,7 +911,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Gay-Berne potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -853,8 +923,17 @@ C include 'COMMON.IOUNITS' include 'COMMON.CALC' include 'COMMON.CONTROL' + include "COMMON.SPLITELE" logical lprn integer xshift,yshift,zshift + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi + double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij, + & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip + double precision dist,sscale,sscagrad,sscagradlip,sscalelip + double precision subchap evdw=0.0D0 ccccc energy_dec=.false. c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon @@ -863,9 +942,9 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon c if (icall.eq.0) lprn=.false. ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -888,7 +967,7 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle c dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) @@ -908,76 +987,74 @@ c write (iout,*) "i",i," j", j," itype",itype(i),itype(j) xj=c(1,nres+j) yj=c(2,nres+j) zj=c(3,nres+j) - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize - if ((zj.gt.bordlipbot) - &.and.(zj.lt.bordliptop)) then + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize + if ((zj.gt.bordlipbot).and.(zj.lt.bordliptop)) then C the energy transfer exist - if (zj.lt.buflipbot) then + if (zj.lt.buflipbot) then C what fraction I am in - fracinbuf=1.0d0- - & ((positi-bordlipbot)/lipbufthick) + fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick) C lipbufthick is thickenes of lipid buffore - sslipj=sscalelip(fracinbuf) - ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick - elseif (zi.gt.bufliptop) then - fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick) - sslipj=sscalelip(fracinbuf) - ssgradlipj=sscagradlip(fracinbuf)/lipbufthick - else - sslipj=1.0d0 - ssgradlipj=0.0 - endif - else - sslipj=0.0d0 - ssgradlipj=0.0 - endif - aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 - & +aa_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 - bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 - & +bb_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - subchap=1 - endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif + sslipj=sscalelip(fracinbuf) + ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick + elseif (zi.gt.bufliptop) then + fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick) + sslipj=sscalelip(fracinbuf) + ssgradlipj=sscagradlip(fracinbuf)/lipbufthick + else + sslipj=1.0d0 + ssgradlipj=0.0 + endif + else + sslipj=0.0d0 + ssgradlipj=0.0 + endif + aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +aa_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 + bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 + & +bb_aq(itypi,itypj)*(2.0d0-sslipi+sslipj)/2.0d0 + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + subchap=1 + endif + enddo + enddo + enddo + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif dxj=dc_norm(1,nres+j) dyj=dc_norm(2,nres+j) dzj=dc_norm(3,nres+j) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) - sssgrad=sscagrad((1.0d0/rij)/sigmaii(itypi,itypj)) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)),r_cut_respa) + sssgrad=sscagrad((1.0d0/rij)/sigmaii(itypi,itypj),r_cut_respa) if (sss.gt.0.0d0) then C Calculate angle-dependent terms of energy and contributions to their @@ -1027,8 +1104,7 @@ C Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder - fac=rij*fac - fac=fac+evdwij/sss*sssgrad/sigmaii(itypi,itypj)*rij + fac=(fac+evdwij*sssgrad/sss/sigmaii(itypi,itypj))*rij c fac=0.0d0 C Calculate the radial part of the gradient gg(1)=xj*fac @@ -1063,8 +1139,18 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' + include "COMMON.SPLITELE" + integer icall common /srutu/ icall logical lprn + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij, + & xi,yi,zi,fac_augm,e_augm + double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij, + & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip + double precision dist,sscale,sscagrad,sscagradlip,sscalelip + double precision sss1,sssgrad1 evdw=0.0D0 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 @@ -1072,9 +1158,9 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon c if (icall.eq.0) lprn=.true. ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -1089,7 +1175,7 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle c dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) @@ -1113,9 +1199,13 @@ c dscj_inv=dsc_inv(itypj) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + sss1=sscale(1.0d0/rij,r_cut_int) + if (sss1.eq.0.0d0) cycle if (sss.lt.1.0d0) then + sssgrad= + & sscagrad((1.0d0/rij)/sigmaii(itypi,itypj),r_cut_respa) + sssgrad1=sscagrad(1.0d0/rij,r_cut_int) C Calculate angle-dependent terms of energy and contributions to their C derivatives. @@ -1140,7 +1230,7 @@ c--------------------------------------------------------------- fac_augm=rrij**expon e_augm=augm(itypi,itypj)*fac_augm evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+(evdwij+e_augm)*(1.0d0-sss) + evdw=evdw+(evdwij+e_augm)*sss1*(1.0d0-sss) if (lprn) then sigm=dabs(aa/bb)**(1.0D0/6.0D0) epsi=bb**2/aa @@ -1157,12 +1247,15 @@ C Calculate gradient components. fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac-2*expon*rrij*e_augm + fac=fac+(evdwij+e_augm)* + & (-sss1*sssgrad/(1.0d0-sss)/sigmaii(itypi,itypj) + & +(1.0d0-sss)*sssgrad1/sss1)*rij C Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac C Calculate angular part of the gradient. - call sc_grad_scale(1.0d0-sss) + call sc_grad_scale((1.0d0-sss)*sss1) endif enddo ! j enddo ! iint @@ -1174,7 +1267,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Gay-Berne-Vorobjev potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -1185,8 +1278,18 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' + include "COMMON.SPLITELE" + integer icall common /srutu/ icall logical lprn + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij, + & xi,yi,zi,fac_augm,e_augm + double precision evdw + double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij, + & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip + double precision dist,sscale,sscagrad,sscagradlip,sscalelip evdw=0.0D0 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 @@ -1194,9 +1297,9 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon c if (icall.eq.0) lprn=.true. ind=0 do i=iatsc_s,iatsc_e - itypi=itype(i) + itypi=iabs(itype(i)) if (itypi.eq.ntyp1) cycle - itypi1=itype(i+1) + itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) zi=c(3,nres+i) @@ -1211,7 +1314,7 @@ C do iint=1,nint_gr(i) do j=istart(i,iint),iend(i,iint) ind=ind+1 - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle c dscj_inv=dsc_inv(itypj) dscj_inv=vbld_inv(j+nres) @@ -1235,7 +1338,7 @@ c dscj_inv=dsc_inv(itypj) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) - sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj))) + sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)),r_cut_respa) if (sss.gt.0.0d0) then @@ -1278,7 +1381,8 @@ C Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder - fac=rij*fac-2*expon*rrij*e_augm + fac=rij*fac-2*expon*rrij*e_augm+ + & (evdwij+e_augm)*sssgrad/sigmaii(itypi,itypj)/sss*rij C Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac @@ -1298,6 +1402,7 @@ C---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.CALC' include 'COMMON.IOUNITS' + include "COMMON.SPLITELE" double precision dcosom1(3),dcosom2(3) double precision scalfac eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 @@ -1365,12 +1470,17 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' include 'COMMON.TIME1' include 'COMMON.SHIELD' + include "COMMON.SPLITELE" dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), @@ -1439,9 +1549,11 @@ cd enddo eello_turn3=0.0d0 eello_turn4=0.0d0 ind=0 +#ifdef FOURBODY do i=1,nres num_cont_hb(i)=0 enddo +#endif cd print '(a)','Enter EELEC' cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e do i=1,nres @@ -1478,7 +1590,9 @@ C & .or. itype(i+4).eq.ntyp1 num_conti=0 call eelecij_scale(i,i+2,ees,evdw1,eel_loc) if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo do i=iturn4_start,iturn4_end if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1 @@ -1502,11 +1616,15 @@ C & .or. itype(i-1).eq.ntyp1 if (ymedi.lt.0) ymedi=ymedi+boxysize zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif call eelecij_scale(i,i+3,ees,evdw1,eel_loc) if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) & call eturn4(i,eello_turn4) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i c c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3 @@ -1531,8 +1649,10 @@ C & .or. itype(i-1).eq.ntyp1 if (ymedi.lt.0) ymedi=ymedi+boxysize zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize -c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) +c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif do j=ielstart(i),ielend(i) if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1 C & .or.itype(j+2).eq.ntyp1 @@ -1540,7 +1660,9 @@ C & .or.itype(j-1).eq.ntyp1 &) cycle call eelecij_scale(i,j,ees,evdw1,eel_loc) enddo ! j +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i c write (iout,*) "Number of loop steps in EELEC:",ind cd do i=1,nres @@ -1554,7 +1676,7 @@ cd print *,"Processor",fg_rank," t_eelecij",t_eelecij end C------------------------------------------------------------------------------- subroutine eelecij_scale(i,j,ees,evdw1,eel_loc) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include "mpif.h" @@ -1567,21 +1689,48 @@ C------------------------------------------------------------------------------- include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' include 'COMMON.TIME1' include 'COMMON.SHIELD' + include "COMMON.SPLITELE" integer xshift,yshift,zshift - dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), + double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4), & gmuij2(4),gmuji2(4) + integer j1,j2,num_conti common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, & num_conti,j1,j2 + integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ind,itypi,itypj + integer ilist,iresshield + double precision rlocshield + double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp + double precision ees,evdw1,eel_loc,aaa,bbb,ael3i + double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj, + & rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4, + & evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa, + & ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der, + & a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij, + & ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp, + & ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp, + & ecosgp,ecosam,ecosbm,ecosgm,ghalf,geel_loc_ij,geel_loc_ji, + & dxi,dyi,dzi,a22,a23,a32,a33 + double precision dist_init,xmedi,ymedi,zmedi,xj_safe,yj_safe, + & zj_safe,xj_temp,yj_temp,zj_temp,dist_temp,dx_normi,dy_normi, + & dz_normi,aux + double precision sss1,sssgrad1 + double precision sscale,sscagrad + double precision scalar + c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions #ifdef MOMENT double precision scal_el /1.0d0/ @@ -1596,29 +1745,29 @@ C 13-go grudnia roku pamietnego... c time00=MPI_Wtime() cd write (iout,*) "eelecij",i,j C print *,"WCHODZE2" - ind=ind+1 - iteli=itel(i) - itelj=itel(j) - if (j.eq.i+2 .and. itelj.eq.2) iteli=2 - aaa=app(iteli,itelj) - bbb=bpp(iteli,itelj) - ael6i=ael6(iteli,itelj) - ael3i=ael3(iteli,itelj) - dxj=dc(1,j) - dyj=dc(2,j) - dzj=dc(3,j) - dx_normj=dc_norm(1,j) - dy_normj=dc_norm(2,j) - dz_normj=dc_norm(3,j) - xj=c(1,j)+0.5D0*dxj - yj=c(2,j)+0.5D0*dyj - zj=c(3,j)+0.5D0*dzj - xj=mod(xj,boxxsize) - if (xj.lt.0) xj=xj+boxxsize - yj=mod(yj,boxysize) - if (yj.lt.0) yj=yj+boxysize - zj=mod(zj,boxzsize) - if (zj.lt.0) zj=zj+boxzsize + ind=ind+1 + iteli=itel(i) + itelj=itel(j) + if (j.eq.i+2 .and. itelj.eq.2) iteli=2 + aaa=app(iteli,itelj) + bbb=bpp(iteli,itelj) + ael6i=ael6(iteli,itelj) + ael3i=ael3(iteli,itelj) + dxj=dc(1,j) + dyj=dc(2,j) + dzj=dc(3,j) + dx_normj=dc_norm(1,j) + dy_normj=dc_norm(2,j) + dz_normj=dc_norm(3,j) + xj=c(1,j)+0.5D0*dxj + yj=c(2,j)+0.5D0*dyj + zj=c(3,j)+0.5D0*dzj + xj=mod(xj,boxxsize) + if (xj.lt.0) xj=xj+boxxsize + yj=mod(yj,boxysize) + if (yj.lt.0) yj=yj+boxysize + zj=mod(zj,boxzsize) + if (zj.lt.0) zj=zj+boxzsize dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 xj_safe=xj yj_safe=yj @@ -1638,89 +1787,101 @@ C print *,"WCHODZE2" zj_temp=zj isubchap=1 endif - enddo - enddo - enddo - if (isubchap.eq.1) then - xj=xj_temp-xmedi - yj=yj_temp-ymedi - zj=zj_temp-zmedi - else - xj=xj_safe-xmedi - yj=yj_safe-ymedi - zj=zj_safe-zmedi - endif + enddo + enddo + enddo + if (isubchap.eq.1) then + xj=xj_temp-xmedi + yj=yj_temp-ymedi + zj=zj_temp-zmedi + else + xj=xj_safe-xmedi + yj=yj_safe-ymedi + zj=zj_safe-zmedi + endif - rij=xj*xj+yj*yj+zj*zj - rrmij=1.0D0/rij - rij=dsqrt(rij) - rmij=1.0D0/rij + rij=xj*xj+yj*yj+zj*zj + rrmij=1.0D0/rij + rij=dsqrt(rij) + rmij=1.0D0/rij c For extracting the short-range part of Evdwpp - sss=sscale(rij/rpp(iteli,itelj)) - sssgrad=sscagrad(rij/rpp(iteli,itelj)) - r3ij=rrmij*rmij - r6ij=r3ij*r3ij - cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj - cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij - cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij - fac=cosa-3.0D0*cosb*cosg - ev1=aaa*r6ij*r6ij + sss1=sscale(rij,r_cut_int) + if (sss1.eq.0.0d0) return + sss=sscale(rij/rpp(iteli,itelj),r_cut_respa) + sssgrad=sscagrad(rij/rpp(iteli,itelj),r_cut_respa) + sssgrad1=sscagrad(rij,r_cut_int) + r3ij=rrmij*rmij + r6ij=r3ij*r3ij + cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj + cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij + cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij + fac=cosa-3.0D0*cosb*cosg + ev1=aaa*r6ij*r6ij c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions - if (j.eq.i+2) ev1=scal_el*ev1 - ev2=bbb*r6ij - fac3=ael6i*r6ij - fac4=ael3i*r3ij - evdwij=ev1+ev2 - if (shield_mode.eq.0) then - fac_shield(i)=1.0 - fac_shield(j)=1.0 - endif - el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) - el2=fac4*fac - el1=el1*fac_shield(i)**2*fac_shield(j)**2 - el2=el2*fac_shield(i)**2*fac_shield(j)**2 - eesij=el1+el2 + if (j.eq.i+2) ev1=scal_el*ev1 + ev2=bbb*r6ij + fac3=ael6i*r6ij + fac4=ael3i*r3ij + evdwij=ev1+ev2 + if (shield_mode.eq.0) then + fac_shield(i)=1.0 + fac_shield(j)=1.0 + endif + el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)) + el2=fac4*fac + el1=el1*fac_shield(i)**2*fac_shield(j)**2 + el2=el2*fac_shield(i)**2*fac_shield(j)**2 + eesij=el1+el2 C 12/26/95 - for the evaluation of multi-body H-bonding interactions - ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) - ees=ees+eesij - evdw1=evdw1+evdwij*(1.0d0-sss) + ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg) + ees=ees+eesij*sss1 + evdw1=evdw1+evdwij*(1.0d0-sss)*sss1 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i, cd & 1.0D0/dsqrt(rrmij),evdwij,eesij, cd & xmedi,ymedi,zmedi,xj,yj,zj - if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss - write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij - endif + if (energy_dec) then + write (iout,'(a6,2i5,0pf7.3,2f7.3)') + & 'evdw1',i,j,evdwij,sss,sss1 + write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij + endif C C Calculate contributions to the Cartesian gradient. C #ifdef SPLITELE - facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss) - facel=-3*rrmij*(el1+eesij) - fac1=fac - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij + facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + facel=-3*rrmij*(el1+eesij)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + fac1=fac + erij(1)=xj*rmij + erij(2)=yj*rmij + erij(3)=zj*rmij * * Radial derivatives. First process both termini of the fragment (i,j) * - ggg(1)=facel*xj - ggg(2)=facel*yj - ggg(3)=facel*zj - if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. + aux=facel+sssgrad1*(1.0d0-sss)*eesij*rmij +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + ggg(1)=aux*xj + ggg(2)=aux*yj + ggg(3)=aux*zj +c ggg(1)=facel*xj +c ggg(2)=facel*yj +c ggg(3)=facel*zj + if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. & (shield_mode.gt.0)) then C print *,i,j - do ilist=1,ishield_list(i) - iresshield=shield_list(ilist,i) - do k=1,3 - rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i) - & *2.0 + do ilist=1,ishield_list(i) + iresshield=shield_list(ilist,i) + do k=1,3 + rlocshield=grad_shield_side(k,ilist,i)*eesij*sss1 + & /fac_shield(i)*2.0*sss1 gshieldx(k,iresshield)=gshieldx(k,iresshield)+ & rlocshield - & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 + & +grad_shield_loc(k,ilist,i)*eesij*sss1/fac_shield(i)*2.0 + & *sss1 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield) C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i) @@ -1737,32 +1898,32 @@ C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i) C C enddo C endif - enddo enddo - do ilist=1,ishield_list(j) - iresshield=shield_list(ilist,j) - do k=1,3 + enddo + do ilist=1,ishield_list(j) + iresshield=shield_list(ilist,j) + do k=1,3 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) - & *2.0 + & *2.0*sss1 gshieldx(k,iresshield)=gshieldx(k,iresshield)+ - & rlocshield - & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 + & rlocshield + & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss1 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield - enddo enddo + enddo - do k=1,3 - gshieldc(k,i)=gshieldc(k,i)+ - & grad_shield(k,i)*eesij/fac_shield(i)*2.0 - gshieldc(k,j)=gshieldc(k,j)+ - & grad_shield(k,j)*eesij/fac_shield(j)*2.0 - gshieldc(k,i-1)=gshieldc(k,i-1)+ - & grad_shield(k,i)*eesij/fac_shield(i)*2.0 - gshieldc(k,j-1)=gshieldc(k,j-1)+ - & grad_shield(k,j)*eesij/fac_shield(j)*2.0 + do k=1,3 + gshieldc(k,i)=gshieldc(k,i)+ + & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss1 + gshieldc(k,j)=gshieldc(k,j)+ + & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss1 + gshieldc(k,i-1)=gshieldc(k,i-1)+ + & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss1 + gshieldc(k,j-1)=gshieldc(k,j-1)+ + & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss1 - enddo - endif + enddo + endif c do k=1,3 c ghalf=0.5D0*ggg(k) @@ -1770,10 +1931,12 @@ c gelc(k,i)=gelc(k,i)+ghalf c gelc(k,j)=gelc(k,j)+ghalf c enddo c 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gelc_long(k,j)=gelc_long(k,j)+ggg(k) - gelc_long(k,i)=gelc_long(k,i)-ggg(k) - enddo + do k=1,3 + gelc_long(k,j)=gelc_long(k,j)+ggg(k) + gelc_long(k,i)=gelc_long(k,i)-ggg(k) + enddo +c gelc_long(3,i)=gelc_long(3,i)+ +c ssgradlipi*eesij/2.0d0*lipscale**2*sss1 * * Loop over residues i+1 thru j-1. * @@ -1782,19 +1945,22 @@ cgrad do l=1,3 cgrad gelc(l,k)=gelc(l,k)+ggg(l) cgrad enddo cgrad enddo - ggg(1)=facvdw*xj-sssgrad*rmij*evdwij*xj/rpp(iteli,itelj) - ggg(2)=facvdw*yj-sssgrad*rmij*evdwij*yj/rpp(iteli,itelj) - ggg(3)=facvdw*zj-sssgrad*rmij*evdwij*zj/rpp(iteli,itelj) + facvdw=facvdw+ + & (-sss1*sssgrad/rpp(iteli,itelj)+(1.0d0-sss)*sssgrad1)*rmij*evdwij +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj c do k=1,3 c ghalf=0.5D0*ggg(k) c gvdwpp(k,i)=gvdwpp(k,i)+ghalf c gvdwpp(k,j)=gvdwpp(k,j)+ghalf c enddo c 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo + do k=1,3 + gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) + gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) + enddo * * Loop over residues i+1 thru j-1. * @@ -1804,29 +1970,40 @@ cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l) cgrad enddo cgrad enddo #else - facvdw=ev1+evdwij*(1.0d0-sss) - facel=el1+eesij - fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) - erij(1)=xj*rmij - erij(2)=yj*rmij - erij(3)=zj*rmij + facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + facel=-3*rrmij*(el1+eesij)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + +c facvdw=ev1+evdwij*(1.0d0-sss)*sss1 +c facel=el1+eesij + fac1=fac + fac=-3*rrmij*(facvdw+facvdw+facel) + erij(1)=xj*rmij + erij(2)=yj*rmij + erij(3)=zj*rmij * * Radial derivatives. First process both termini of the fragment (i,j) * - ggg(1)=fac*xj - ggg(2)=fac*yj - ggg(3)=fac*zj + aux=fac+(sssgrad1*(1.0d0-sss)-sssgrad*sss1/rpp(iteli,itelj)) + & *eesij*rmij +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + ggg(1)=aux*xj + ggg(2)=aux*yj + ggg(3)=axu*zj +c ggg(1)=fac*xj +c ggg(2)=fac*yj +c ggg(3)=fac*zj c do k=1,3 c ghalf=0.5D0*ggg(k) c gelc(k,i)=gelc(k,i)+ghalf c gelc(k,j)=gelc(k,j)+ghalf c enddo c 9/28/08 AL Gradient compotents will be summed only at the end - do k=1,3 - gelc_long(k,j)=gelc(k,j)+ggg(k) - gelc_long(k,i)=gelc(k,i)-ggg(k) - enddo + do k=1,3 + gelc_long(k,j)=gelc(k,j)+ggg(k) + gelc_long(k,i)=gelc(k,i)-ggg(k) + enddo * * Loop over residues i+1 thru j-1. * @@ -1839,33 +2016,36 @@ c 9/28/08 AL Gradient compotents will be summed only at the end C ggg(1)=facvdw*xj C ggg(2)=facvdw*yj C ggg(3)=facvdw*zj - ggg(1)=facvdw*xj-sssgrad*rmij*evdwij*xj/rpp(iteli,itelj) - ggg(2)=facvdw*yj-sssgrad*rmij*evdwij*yj/rpp(iteli,itelj) - ggg(3)=facvdw*zj-sssgrad*rmij*evdwij*zj/rpp(iteli,itelj) - do k=1,3 - gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) - gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) - enddo + facvdw=facvdw + & (-sssgrad*sss1/rpp(iteli,itelj)+sssgrad1*(1.0d0-sss))*rmij*evdwij + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj + do k=1,3 + gvdwpp(k,j)=gvdwpp(k,j)+ggg(k) + gvdwpp(k,i)=gvdwpp(k,i)-ggg(k) + enddo #endif * * Angular part * - ecosa=2.0D0*fac3*fac1+fac4 - fac4=-3.0D0*fac4 - fac3=-6.0D0*fac3 - ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) - ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo + ecosa=2.0D0*fac3*fac1+fac4 + fac4=-3.0D0*fac4 + fac3=-6.0D0*fac3 + ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4) + ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4) + do k=1,3 + dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) + dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) + enddo cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), cd & (dcosg(k),k=1,3) - do k=1,3 - ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))* - & fac_shield(i)**2*fac_shield(j)**2 + do k=1,3 + ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss1 + & *fac_shield(i)**2*fac_shield(j)**2 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) - enddo + enddo c do k=1,3 c ghalf=0.5D0*ggg(k) c gelc(k,i)=gelc(k,i)+ghalf @@ -1880,22 +2060,24 @@ cgrad do l=1,3 cgrad gelc(l,k)=gelc(l,k)+ggg(l) cgrad enddo cgrad enddo - do k=1,3 - gelc(k,i)=gelc(k,i) - & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)) - & *fac_shield(i)**2*fac_shield(j)**2 + do k=1,3 + gelc(k,i)=gelc(k,i) + & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) + & +ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss1 + & *fac_shield(i)**2*fac_shield(j)**2 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) - gelc(k,j)=gelc(k,j) - & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)) - & *fac_shield(i)**2*fac_shield(j)**2 - gelc_long(k,j)=gelc_long(k,j)+ggg(k) - gelc_long(k,i)=gelc_long(k,i)-ggg(k) - enddo - IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 - & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 - & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN + gelc(k,j)=gelc(k,j) + & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) + & +ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss1 + & *fac_shield(i)**2*fac_shield(j)**2 +c & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0) + gelc_long(k,j)=gelc_long(k,j)+ggg(k) + gelc_long(k,i)=gelc_long(k,i)-ggg(k) + enddo + IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 + & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 + & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN C C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction C energy of a peptide unit is assumed in the form of a second-order @@ -1903,44 +2085,44 @@ C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al. C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms C are computed for EVERY pair of non-contiguous peptide groups. C - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - kkk=0 - do k=1,2 - do l=1,2 - kkk=kkk+1 - muij(kkk)=mu(k,i)*mu(l,j) + if (j.lt.nres-1) then + j1=j+1 + j2=j-1 + else + j1=j-1 + j2=j-2 + endif + kkk=0 + do k=1,2 + do l=1,2 + kkk=kkk+1 + muij(kkk)=mu(k,i)*mu(l,j) #ifdef NEWCORR - gmuij1(kkk)=gtb1(k,i+1)*mu(l,j) + gmuij1(kkk)=gtb1(k,i+1)*mu(l,j) c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j) - gmuij2(kkk)=gUb2(k,i)*mu(l,j) - gmuji1(kkk)=mu(k,i)*gtb1(l,j+1) + gmuij2(kkk)=gUb2(k,i)*mu(l,j) + gmuji1(kkk)=mu(k,i)*gtb1(l,j+1) c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i) - gmuji2(kkk)=mu(k,i)*gUb2(l,j) + gmuji2(kkk)=mu(k,i)*gUb2(l,j) #endif - enddo - enddo + enddo + enddo cd write (iout,*) 'EELEC: i',i,' j',j cd write (iout,*) 'j',j,' j1',j1,' j2',j2 cd write(iout,*) 'muij',muij - ury=scalar(uy(1,i),erij) - urz=scalar(uz(1,i),erij) - vry=scalar(uy(1,j),erij) - vrz=scalar(uz(1,j),erij) - a22=scalar(uy(1,i),uy(1,j))-3*ury*vry - a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz - a32=scalar(uz(1,i),uy(1,j))-3*urz*vry - a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz - fac=dsqrt(-ael6i)*r3ij - a22=a22*fac - a23=a23*fac - a32=a32*fac - a33=a33*fac + ury=scalar(uy(1,i),erij) + urz=scalar(uz(1,i),erij) + vry=scalar(uy(1,j),erij) + vrz=scalar(uz(1,j),erij) + a22=scalar(uy(1,i),uy(1,j))-3*ury*vry + a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz + a32=scalar(uz(1,i),uy(1,j))-3*urz*vry + a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz + fac=dsqrt(-ael6i)*r3ij + a22=a22*fac + a23=a23*fac + a32=a32*fac + a33=a33*fac cd write (iout,'(4i5,4f10.5)') cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij @@ -1953,101 +2135,113 @@ cd write (iout,'(4f10.5)') ury,urz,vry,vrz cd write (iout,'(9f10.5/)') cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij C Derivatives of the elements of A in virtual-bond vectors - call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) - do k=1,3 - uryg(k,1)=scalar(erder(1,k),uy(1,i)) - uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1)) - uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1)) - urzg(k,1)=scalar(erder(1,k),uz(1,i)) - urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1)) - urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1)) - vryg(k,1)=scalar(erder(1,k),uy(1,j)) - vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1)) - vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1)) - vrzg(k,1)=scalar(erder(1,k),uz(1,j)) - vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1)) - vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1)) - enddo + call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1)) + do k=1,3 + uryg(k,1)=scalar(erder(1,k),uy(1,i)) + uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1)) + uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1)) + urzg(k,1)=scalar(erder(1,k),uz(1,i)) + urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1)) + urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1)) + vryg(k,1)=scalar(erder(1,k),uy(1,j)) + vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1)) + vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1)) + vrzg(k,1)=scalar(erder(1,k),uz(1,j)) + vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1)) + vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1)) + enddo C Compute radial contributions to the gradient - facr=-3.0d0*rrmij - a22der=a22*facr - a23der=a23*facr - a32der=a32*facr - a33der=a33*facr - agg(1,1)=a22der*xj - agg(2,1)=a22der*yj - agg(3,1)=a22der*zj - agg(1,2)=a23der*xj - agg(2,2)=a23der*yj - agg(3,2)=a23der*zj - agg(1,3)=a32der*xj - agg(2,3)=a32der*yj - agg(3,3)=a32der*zj - agg(1,4)=a33der*xj - agg(2,4)=a33der*yj - agg(3,4)=a33der*zj + facr=-3.0d0*rrmij + a22der=a22*facr + a23der=a23*facr + a32der=a32*facr + a33der=a33*facr + agg(1,1)=a22der*xj + agg(2,1)=a22der*yj + agg(3,1)=a22der*zj + agg(1,2)=a23der*xj + agg(2,2)=a23der*yj + agg(3,2)=a23der*zj + agg(1,3)=a32der*xj + agg(2,3)=a32der*yj + agg(3,3)=a32der*zj + agg(1,4)=a33der*xj + agg(2,4)=a33der*yj + agg(3,4)=a33der*zj C Add the contributions coming from er - fac3=-3.0d0*fac - do k=1,3 - agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) - agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) - agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) - agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) - enddo - do k=1,3 + fac3=-3.0d0*fac + do k=1,3 + agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury) + agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury) + agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz) + agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz) + enddo + do k=1,3 C Derivatives in DC(i) cgrad ghalf1=0.5d0*agg(k,1) cgrad ghalf2=0.5d0*agg(k,2) cgrad ghalf3=0.5d0*agg(k,3) cgrad ghalf4=0.5d0*agg(k,4) - aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) - & -3.0d0*uryg(k,2)*vry)!+ghalf1 - aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) - & -3.0d0*uryg(k,2)*vrz)!+ghalf2 - aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) - & -3.0d0*urzg(k,2)*vry)!+ghalf3 - aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) - & -3.0d0*urzg(k,2)*vrz)!+ghalf4 + aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) + & -3.0d0*uryg(k,2)*vry)!+ghalf1 + aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) + & -3.0d0*uryg(k,2)*vrz)!+ghalf2 + aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) + & -3.0d0*urzg(k,2)*vry)!+ghalf3 + aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) + & -3.0d0*urzg(k,2)*vrz)!+ghalf4 C Derivatives in DC(i+1) - aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) - & -3.0d0*uryg(k,3)*vry)!+agg(k,1) - aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) - & -3.0d0*uryg(k,3)*vrz)!+agg(k,2) - aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) - & -3.0d0*urzg(k,3)*vry)!+agg(k,3) - aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) - & -3.0d0*urzg(k,3)*vrz)!+agg(k,4) + aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) + & -3.0d0*uryg(k,3)*vry)!+agg(k,1) + aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) + & -3.0d0*uryg(k,3)*vrz)!+agg(k,2) + aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) + & -3.0d0*urzg(k,3)*vry)!+agg(k,3) + aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) + & -3.0d0*urzg(k,3)*vrz)!+agg(k,4) C Derivatives in DC(j) - aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) - & -3.0d0*vryg(k,2)*ury)!+ghalf1 - aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) - & -3.0d0*vrzg(k,2)*ury)!+ghalf2 - aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) - & -3.0d0*vryg(k,2)*urz)!+ghalf3 - aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) - & -3.0d0*vrzg(k,2)*urz)!+ghalf4 + aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) + & -3.0d0*vryg(k,2)*ury)!+ghalf1 + aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) + & -3.0d0*vrzg(k,2)*ury)!+ghalf2 + aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) + & -3.0d0*vryg(k,2)*urz)!+ghalf3 + aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) + & -3.0d0*vrzg(k,2)*urz)!+ghalf4 C Derivatives in DC(j+1) or DC(nres-1) - aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) - & -3.0d0*vryg(k,3)*ury) - aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) - & -3.0d0*vrzg(k,3)*ury) - aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) - & -3.0d0*vryg(k,3)*urz) - aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) - & -3.0d0*vrzg(k,3)*urz) + aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) + & -3.0d0*vryg(k,3)*ury) + aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) + & -3.0d0*vrzg(k,3)*ury) + aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) + & -3.0d0*vryg(k,3)*urz) + aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) + & -3.0d0*vrzg(k,3)*urz) cgrad if (j.eq.nres-1 .and. i.lt.j-2) then cgrad do l=1,4 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l) cgrad enddo cgrad endif + enddo + acipa(1,1)=a22 + acipa(1,2)=a23 + acipa(2,1)=a32 + acipa(2,2)=a33 + a22=-a22 + a23=-a23 + do l=1,2 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) enddo - acipa(1,1)=a22 - acipa(1,2)=a23 - acipa(2,1)=a32 - acipa(2,2)=a33 + enddo + if (j.lt.nres-1) then a22=-a22 - a23=-a23 - do l=1,2 + a32=-a32 + do l=1,3,2 do k=1,3 agg(k,l)=-agg(k,l) aggi(k,l)=-aggi(k,l) @@ -2056,56 +2250,44 @@ cgrad endif aggj1(k,l)=-aggj1(k,l) enddo enddo - if (j.lt.nres-1) then - a22=-a22 - a32=-a32 - do l=1,3,2 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo + else + a22=-a22 + a23=-a23 + a32=-a32 + a33=-a33 + do l=1,4 + do k=1,3 + agg(k,l)=-agg(k,l) + aggi(k,l)=-aggi(k,l) + aggi1(k,l)=-aggi1(k,l) + aggj(k,l)=-aggj(k,l) + aggj1(k,l)=-aggj1(k,l) enddo - else - a22=-a22 - a23=-a23 - a32=-a32 - a33=-a33 - do l=1,4 - do k=1,3 - agg(k,l)=-agg(k,l) - aggi(k,l)=-aggi(k,l) - aggi1(k,l)=-aggi1(k,l) - aggj(k,l)=-aggj(k,l) - aggj1(k,l)=-aggj1(k,l) - enddo - enddo - endif - ENDIF ! WCORR - IF (wel_loc.gt.0.0d0) THEN + enddo + endif + ENDIF ! WCORR + IF (wel_loc.gt.0.0d0) THEN C Contribution to the local-electrostatic energy coming from the i-j pair - eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) - & +a33*muij(4) -cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij + eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) + & +a33*muij(4) +cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'eelloc',i,j,eel_loc_ij + if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') + & 'eelloc',i,j,eel_loc_ij - if (shield_mode.eq.0) then - fac_shield(i)=1.0 - fac_shield(j)=1.0 -C else -C fac_shield(i)=0.4 -C fac_shield(j)=0.6 - endif - eel_loc_ij=eel_loc_ij - & *fac_shield(i)*fac_shield(j) - eel_loc=eel_loc+eel_loc_ij + if (shield_mode.eq.0) then + fac_shield(i)=1.0 + fac_shield(j)=1.0 +C else +C fac_shield(i)=0.4 +C fac_shield(j)=0.6 + endif + eel_loc_ij=eel_loc_ij + & *fac_shield(i)*fac_shield(j)*sss1 + eel_loc=eel_loc+eel_loc_ij - if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. + if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. & (shield_mode.gt.0)) then C print *,i,j @@ -2117,7 +2299,7 @@ C print *,i,j C & *2.0 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ & rlocshield - & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i) + & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i) gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1) & +rlocshield enddo @@ -2130,7 +2312,7 @@ C & *2.0 C & *2.0 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ & rlocshield - & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j) + & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j) gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1) & +rlocshield @@ -2146,34 +2328,34 @@ C & *2.0 & grad_shield(k,i)*eel_loc_ij/fac_shield(i) gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ & grad_shield(k,j)*eel_loc_ij/fac_shield(j) - enddo - endif + enddo + endif #ifdef NEWCORR - geel_loc_ij=(a22*gmuij1(1) + geel_loc_ij=(a22*gmuij1(1) & +a23*gmuij1(2) & +a32*gmuij1(3) & +a33*gmuij1(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss1 c write(iout,*) "derivative over thatai" c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3), c & a33*gmuij1(4) - gloc(nphi+i,icg)=gloc(nphi+i,icg)+ + gloc(nphi+i,icg)=gloc(nphi+i,icg)+ & geel_loc_ij*wel_loc c write(iout,*) "derivative over thatai-1" c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3), c & a33*gmuij2(4) - geel_loc_ij= + geel_loc_ij= & a22*gmuij2(1) & +a23*gmuij2(2) & +a32*gmuij2(3) & +a33*gmuij2(4) - gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ + gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ & geel_loc_ij*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss1 c Derivative over j residue - geel_loc_ji=a22*gmuji1(1) + geel_loc_ji=a22*gmuji1(1) & +a23*gmuji1(2) & +a32*gmuji1(3) & +a33*gmuji1(4) @@ -2183,9 +2365,9 @@ c & a33*gmuji1(4) gloc(nphi+j,icg)=gloc(nphi+j,icg)+ & geel_loc_ji*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss1 - geel_loc_ji= + geel_loc_ji= & +a22*gmuji2(1) & +a23*gmuji2(2) & +a32*gmuji2(3) @@ -2193,147 +2375,171 @@ c & a33*gmuji1(4) c write(iout,*) "derivative over thataj-1" c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3), c & a33*gmuji2(4) - gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+ - & geel_loc_ji*wel_loc - & *fac_shield(i)*fac_shield(j) + gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+ + & geel_loc_ji*wel_loc + & *fac_shield(i)*fac_shield(j)*sss1 #endif -cC Partial derivatives in virtual-bond dihedral angles gamma - if (i.gt.1) +cC Paral derivatives in virtual-bond dihedral angles gamma + if (i.gt.1) & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ - & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) - & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) - & *fac_shield(i)*fac_shield(j) + & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) + & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *fac_shield(i)*fac_shield(j) +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) - gel_loc_loc(j-1)=gel_loc_loc(j-1)+ - & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) - & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) - & *fac_shield(i)*fac_shield(j) + + gel_loc_loc(j-1)=gel_loc_loc(j-1)+ + & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) + & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *fac_shield(i)*fac_shield(j) +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) - do l=1,3 - ggg(l)=(agg(l,1)*muij(1)+ - & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + aux=eel_loc_ij/sss1*sssgrad1*rmij + ggg(1)=aux*xj + ggg(2)=aux*yj + ggg(3)=aux*zj + do l=1,3 + ggg(l)=ggg(l)+(agg(l,1)*muij(1)+ + & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *fac_shield(i)*fac_shield(j) +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) - gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) - gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) -cgrad ghalf=0.5d0*ggg(l) -cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf -cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf - enddo + gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) + gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) +cgrad ghalf=0.5d0*ggg(l) +cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf +cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf + enddo cgrad do k=i+1,j2 cgrad do l=1,3 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l) cgrad enddo cgrad enddo C Remaining derivatives of eello - do l=1,3 - gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ - & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) +c gel_loc_long(3,j)=gel_loc_long(3,j)+ & +c ssgradlipj*eel_loc_ij/2.0d0*lipscale/ & +c ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut +c +c gel_loc_long(3,i)=gel_loc_long(3,i)+ & +c ssgradlipi*eel_loc_ij/2.0d0*lipscale/ & +c ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut - gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ - & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + do l=1,3 + gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ + & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) - gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ - & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ + & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) - gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ - & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ + & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) - enddo - ENDIF + gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ + & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)) + & *fac_shield(i)*fac_shield(j)*sss1 +c & *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) + + enddo + ENDIF +#ifdef FOURBODY C Change 12/26/95 to calculate four-body contributions to H-bonding energy c if (j.gt.i+1 .and. num_conti.le.maxconts) then - if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 - & .and. num_conti.le.maxconts) then + if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 + & .and. num_conti.le.maxconts) then c write (iout,*) i,j," entered corr" C C Calculate the contact function. The ith column of the array JCONT will C contain the numbers of atoms that make contacts with the atom I (of numbers C greater than I). The arrays FACONT and GACONT will contain the values of C the contact function and its derivative. -c r0ij=1.02D0*rpp(iteli,itelj) -c r0ij=1.11D0*rpp(iteli,itelj) - r0ij=2.20D0*rpp(iteli,itelj) -c r0ij=1.55D0*rpp(iteli,itelj) - call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont) - if (fcont.gt.0.0D0) then - num_conti=num_conti+1 - if (num_conti.gt.maxconts) then - write (iout,*) 'WARNING - max. # of contacts exceeded;', - & ' will skip next contacts for this conf.' - else - jcont_hb(num_conti,i)=j -cd write (iout,*) "i",i," j",j," num_conti",num_conti, -cd & " jcont_hb",jcont_hb(num_conti,i) - IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. - & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN +c r0ij=1.02D0*rpp(iteli,itelj) +c r0ij=1.11D0*rpp(iteli,itelj) + r0ij=2.20D0*rpp(iteli,itelj) +c r0ij=1.55D0*rpp(iteli,itelj) + call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont) + if (fcont.gt.0.0D0) then + num_conti=num_conti+1 + if (num_conti.gt.maxconts) then + write (iout,*) 'WARNING - max. # of contacts exceeded;', + & ' will skip next contacts for this conf.' + else + jcont_hb(num_conti,i)=j +cd write (iout,*) "i",i," j",j," num_conti",num_conti, +cd " jcont_hb",jcont_hb(num_conti,i) + IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. + & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el C terms. - d_cont(num_conti,i)=rij + d_cont(num_conti,i)=rij cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij C --- Electrostatic-interaction matrix --- - a_chuj(1,1,num_conti,i)=a22 - a_chuj(1,2,num_conti,i)=a23 - a_chuj(2,1,num_conti,i)=a32 - a_chuj(2,2,num_conti,i)=a33 + a_chuj(1,1,num_conti,i)=a22 + a_chuj(1,2,num_conti,i)=a23 + a_chuj(2,1,num_conti,i)=a32 + a_chuj(2,2,num_conti,i)=a33 C --- Gradient of rij - do kkk=1,3 - grij_hb_cont(kkk,num_conti,i)=erij(kkk) - enddo - kkll=0 - do k=1,2 - do l=1,2 - kkll=kkll+1 - do m=1,3 - a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll) - a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll) - a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll) - a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll) - a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll) - enddo + do kkk=1,3 + grij_hb_cont(kkk,num_conti,i)=erij(kkk) + enddo + kkll=0 + do k=1,2 + do l=1,2 + kkll=kkll+1 + do m=1,3 + a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll) + a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll) + a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll) + a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll) + a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll) enddo enddo - ENDIF - IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN + enddo + ENDIF + IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN C Calculate contact energies - cosa4=4.0D0*cosa - wij=cosa-3.0D0*cosb*cosg - cosbg1=cosb+cosg - cosbg2=cosb-cosg -c fac3=dsqrt(-ael6i)/r0ij**3 - fac3=dsqrt(-ael6i)*r3ij -c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) - ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 - if (ees0tmp.gt.0) then - ees0pij=dsqrt(ees0tmp) - else - ees0pij=0 - endif -c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) - ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 - if (ees0tmp.gt.0) then - ees0mij=dsqrt(ees0tmp) - else - ees0mij=0 - endif -c ees0mij=0.0D0 - if (shield_mode.eq.0) then + cosa4=4.0D0*cosa + wij=cosa-3.0D0*cosb*cosg + cosbg1=cosb+cosg + cosbg2=cosb-cosg +c fac3=dsqrt(-ael6i)/r0ij**3 + fac3=dsqrt(-ael6i)*r3ij +c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1) + ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1 + if (ees0tmp.gt.0) then + ees0pij=dsqrt(ees0tmp) + else + ees0pij=0 + endif +c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2) + ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2 + if (ees0tmp.gt.0) then + ees0mij=dsqrt(ees0tmp) + else + ees0mij=0 + endif +c ees0mij=0.0D0 + if (shield_mode.eq.0) then fac_shield(i)=1.0d0 fac_shield(j)=1.0d0 - else + else ees0plist(num_conti,i)=j C fac_shield(i)=0.4d0 C fac_shield(j)=0.6d0 - endif - ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) - & *fac_shield(i)*fac_shield(j) - ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) - & *fac_shield(i)*fac_shield(j) + endif + ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) + & *fac_shield(i)*fac_shield(j)*sss1 + ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) + & *fac_shield(i)*fac_shield(j)*sss1 C Diagnostics. Comment out or remove after debugging! c ees0p(num_conti,i)=0.5D0*fac3*ees0pij @@ -2343,24 +2549,24 @@ C End diagnostics. c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij, c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont C Angular derivatives of the contact function - ees0pij1=fac3/ees0pij - ees0mij1=fac3/ees0mij - fac3p=-3.0D0*fac3*rrmij - ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) - ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) -c ees0mij1=0.0D0 - ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) - ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) - ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) - ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) - ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) - ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) - ecosap=ecosa1+ecosa2 - ecosbp=ecosb1+ecosb2 - ecosgp=ecosg1+ecosg2 - ecosam=ecosa1-ecosa2 - ecosbm=ecosb1-ecosb2 - ecosgm=ecosg1-ecosg2 + ees0pij1=fac3/ees0pij + ees0mij1=fac3/ees0mij + fac3p=-3.0D0*fac3*rrmij + ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij) + ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij) +c ees0mij1=0.0D0 + ecosa1= ees0pij1*( 1.0D0+0.5D0*wij) + ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1) + ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1) + ecosa2= ees0mij1*(-1.0D0+0.5D0*wij) + ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2) + ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2) + ecosap=ecosa1+ecosa2 + ecosbp=ecosb1+ecosb2 + ecosgp=ecosg1+ecosg2 + ecosam=ecosa1-ecosa2 + ecosbm=ecosb1-ecosb2 + ecosgm=ecosg1-ecosg2 C Diagnostics c ecosap=ecosa1 c ecosbp=ecosb1 @@ -2369,84 +2575,91 @@ c ecosam=0.0D0 c ecosbm=0.0D0 c ecosgm=0.0D0 C End diagnostics - facont_hb(num_conti,i)=fcont - fprimcont=fprimcont/rij + facont_hb(num_conti,i)=fcont + fprimcont=fprimcont/rij cd facont_hb(num_conti,i)=1.0D0 C Following line is for diagnostics. cd fprimcont=0.0D0 - do k=1,3 - dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) - dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) - enddo - do k=1,3 - gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) - gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) - enddo - gggp(1)=gggp(1)+ees0pijp*xj - gggp(2)=gggp(2)+ees0pijp*yj - gggp(3)=gggp(3)+ees0pijp*zj - gggm(1)=gggm(1)+ees0mijp*xj - gggm(2)=gggm(2)+ees0mijp*yj - gggm(3)=gggm(3)+ees0mijp*zj + do k=1,3 + dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb) + dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg) + enddo + do k=1,3 + gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k) + gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) + enddo + gggp(1)=gggp(1)+ees0pijp*xj + & +ees0p(num_conti,i)/sss1*rmij*xj*sssgrad1 + gggp(2)=gggp(2)+ees0pijp*yj + & +ees0p(num_conti,i)/sss1*rmij*yj*sssgrad1 + gggp(3)=gggp(3)+ees0pijp*zj + & +ees0p(num_conti,i)/sss1*rmij*zj*sssgrad1 + gggm(1)=gggm(1)+ees0mijp*xj + & +ees0m(num_conti,i)/sss1*rmij*xj*sssgrad1 + gggm(2)=gggm(2)+ees0mijp*yj + & +ees0m(num_conti,i)/sss1*rmij*yj*sssgrad1 + gggm(3)=gggm(3)+ees0mijp*zj + & +ees0m(num_conti,i)/sss1*rmij*zj*sssgrad1 C Derivatives due to the contact function - gacont_hbr(1,num_conti,i)=fprimcont*xj - gacont_hbr(2,num_conti,i)=fprimcont*yj - gacont_hbr(3,num_conti,i)=fprimcont*zj - do k=1,3 + gacont_hbr(1,num_conti,i)=fprimcont*xj + gacont_hbr(2,num_conti,i)=fprimcont*yj + gacont_hbr(3,num_conti,i)=fprimcont*zj + do k=1,3 c c 10/24/08 cgrad and ! comments indicate the parts of the code removed c following the change of gradient-summation algorithm. c cgrad ghalfp=0.5D0*gggp(k) cgrad ghalfm=0.5D0*gggm(k) - gacontp_hb1(k,num_conti,i)=!ghalfp - & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - & *fac_shield(i)*fac_shield(j) + gacontp_hb1(k,num_conti,i)=!ghalfp + & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) + & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + & *sss1*fac_shield(i)*fac_shield(j) - gacontp_hb2(k,num_conti,i)=!ghalfp - & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - & *fac_shield(i)*fac_shield(j) + gacontp_hb2(k,num_conti,i)=!ghalfp + & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) + & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + & *sss1*fac_shield(i)*fac_shield(j) - gacontp_hb3(k,num_conti,i)=gggp(k) - & *fac_shield(i)*fac_shield(j) + gacontp_hb3(k,num_conti,i)=gggp(k) + & *sss1*fac_shield(i)*fac_shield(j) - gacontm_hb1(k,num_conti,i)=!ghalfm - & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - & *fac_shield(i)*fac_shield(j) + gacontm_hb1(k,num_conti,i)=!ghalfm + & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) + & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) + & *sss1*fac_shield(i)*fac_shield(j) - gacontm_hb2(k,num_conti,i)=!ghalfm - & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - & *fac_shield(i)*fac_shield(j) + gacontm_hb2(k,num_conti,i)=!ghalfm + & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) + & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) + & *sss1*fac_shield(i)*fac_shield(j) - gacontm_hb3(k,num_conti,i)=gggm(k) - & *fac_shield(i)*fac_shield(j) + gacontm_hb3(k,num_conti,i)=gggm(k) + & *sss1*fac_shield(i)*fac_shield(j) - enddo - ENDIF ! wcorr - endif ! num_conti.le.maxconts - endif ! fcont.gt.0 - endif ! j.gt.i+1 - if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then - do k=1,4 - do l=1,3 - ghalf=0.5d0*agg(l,k) - aggi(l,k)=aggi(l,k)+ghalf - aggi1(l,k)=aggi1(l,k)+agg(l,k) - aggj(l,k)=aggj(l,k)+ghalf enddo + ENDIF ! wcorr + endif ! num_conti.le.maxconts + endif ! fcont.gt.0 + endif ! j.gt.i+1 +#endif + if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then + do k=1,4 + do l=1,3 + ghalf=0.5d0*agg(l,k) + aggi(l,k)=aggi(l,k)+ghalf + aggi1(l,k)=aggi1(l,k)+agg(l,k) + aggj(l,k)=aggj(l,k)+ghalf + enddo + enddo + if (j.eq.nres-1 .and. i.lt.j-2) then + do k=1,4 + do l=1,3 + aggj1(l,k)=aggj1(l,k)+agg(l,k) enddo - if (j.eq.nres-1 .and. i.lt.j-2) then - do k=1,4 - do l=1,3 - aggj1(l,k)=aggj1(l,k)+agg(l,k) - enddo - enddo - endif - endif + enddo + endif + endif c t_eelecij=t_eelecij+MPI_Wtime()-time00 return end @@ -2455,7 +2668,7 @@ C----------------------------------------------------------------------- C C Compute Evdwpp C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.IOUNITS' @@ -2465,11 +2678,12 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' - dimension ggg(3) + include "COMMON.SPLITELE" + double precision ggg(3) integer xshift,yshift,zshift c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions #ifdef MOMENT @@ -2478,6 +2692,14 @@ c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions double precision scal_el /0.5d0/ #endif c write (iout,*) "evdwpp_short" + integer i,j,k,iteli,itelj,num_conti,ind,isubchap + double precision dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb + double precision xj,yj,zj,rij,rrmij,r3ij,r6ij,evdw1, + & dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, + & dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw + double precision xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp, + & dist_temp, dist_init,sss_grad + double precision sscale,sscagrad evdw1=0.0D0 C print *,"WCHODZE" c write (iout,*) "iatel_s_vdw",iatel_s_vdw, @@ -2494,12 +2716,12 @@ c call flush(iout) xmedi=c(1,i)+0.5d0*dxi ymedi=c(2,i)+0.5d0*dyi zmedi=c(3,i)+0.5d0*dzi - xmedi=mod(xmedi,boxxsize) - if (xmedi.lt.0.0d0) xmedi=xmedi+boxxsize - ymedi=mod(ymedi,boxysize) - if (ymedi.lt.0.0d0) ymedi=ymedi+boxysize - zmedi=mod(zmedi,boxzsize) - if (zmedi.lt.0.0d0) zmedi=zmedi+boxzsize + xmedi=mod(xmedi,boxxsize) + if (xmedi.lt.0.0d0) xmedi=xmedi+boxxsize + ymedi=mod(ymedi,boxysize) + if (ymedi.lt.0.0d0) ymedi=ymedi+boxysize + zmedi=mod(zmedi,boxzsize) + if (zmedi.lt.0.0d0) zmedi=zmedi+boxzsize num_conti=0 c write (iout,*) 'i',i,' ielstart',ielstart_vdw(i), c & ' ielend',ielend_vdw(i) @@ -2527,44 +2749,44 @@ c call flush(iout) if (yj.lt.0) yj=yj+boxysize zj=mod(zj,boxzsize) if (zj.lt.0) zj=zj+boxzsize - dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - isubchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 - xj=xj_safe+xshift*boxxsize - yj=yj_safe+yshift*boxysize - zj=zj_safe+zshift*boxzsize - dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 - if(dist_temp.lt.dist_init) then - dist_init=dist_temp - xj_temp=xj - yj_temp=yj - zj_temp=zj - isubchap=1 - endif - enddo - enddo - enddo - if (isubchap.eq.1) then - xj=xj_temp-xmedi - yj=yj_temp-ymedi - zj=zj_temp-zmedi - else - xj=xj_safe-xmedi - yj=yj_safe-ymedi - zj=zj_safe-zmedi - endif + dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + isubchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 + xj=xj_safe+xshift*boxxsize + yj=yj_safe+yshift*boxysize + zj=zj_safe+zshift*boxzsize + dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2 + if(dist_temp.lt.dist_init) then + dist_init=dist_temp + xj_temp=xj + yj_temp=yj + zj_temp=zj + isubchap=1 + endif + enddo + enddo + enddo + if (isubchap.eq.1) then + xj=xj_temp-xmedi + yj=yj_temp-ymedi + zj=zj_temp-zmedi + else + xj=xj_safe-xmedi + yj=yj_safe-ymedi + zj=zj_safe-zmedi + endif rij=xj*xj+yj*yj+zj*zj rrmij=1.0D0/rij rij=dsqrt(rij) c sss=sscale(rij/rpp(iteli,itelj)) c sssgrad=sscagrad(rij/rpp(iteli,itelj)) - sss=sscale(rij) - sssgrad=sscagrad(rij) + sss=sscale(rij/rpp(iteli,itelj),r_cut_respa) + sssgrad=sscagrad(rij/rpp(iteli,itelj),r_cut_respa) if (sss.gt.0.0d0) then rmij=1.0D0/rij r3ij=rrmij*rmij @@ -2584,9 +2806,9 @@ C C Calculate contributions to the Cartesian gradient. C facvdw=-6*rrmij*(ev1+evdwij)*sss - ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj/rpp(iteli,itelj) - ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj/rpp(iteli,itelj) - ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj/rpp(iteli,itelj) + ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj/rpp(iteli,itelj) + ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj/rpp(iteli,itelj) + ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj/rpp(iteli,itelj) C ggg(1)=facvdw*xj C ggg(2)=facvdw*yj C ggg(3)=facvdw*zj @@ -2617,10 +2839,18 @@ C include 'COMMON.FFIELD' include 'COMMON.IOUNITS' include 'COMMON.CONTROL' + include "COMMON.SPLITELE" logical lprint_short common /shortcheck/ lprint_short - dimension ggg(3) + double precision ggg(3) integer xshift,yshift,zshift + integer i,iint,j,k,iteli,itypj,subchap + double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1, + & fac,e1,e2,rij + double precision evdw2,evdw2_14,evdwij + double precision xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp, + & dist_temp, dist_init + double precision sscale,sscagrad if (energy_dec) write (iout,*) "escp_long:",r_cut,rlamb evdw2=0.0D0 evdw2_14=0.0d0 @@ -2635,16 +2865,17 @@ c & ' iatscp_e=',iatscp_e xi=0.5D0*(c(1,i)+c(1,i+1)) yi=0.5D0*(c(2,i)+c(2,i+1)) zi=0.5D0*(c(3,i)+c(3,i+1)) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize + xi=mod(xi,boxxsize) + if (xi.lt.0) xi=xi+boxxsize + yi=mod(yi,boxysize) + if (yi.lt.0) yi=yi+boxysize + zi=mod(zi,boxzsize) + if (zi.lt.0) zi=zi+boxzsize + do iint=1,nscp_gr(i) do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) + itypj=iabs(itype(j)) if (itypj.eq.ntyp1) cycle C Uncomment following three lines for SC-p interactions c xj=c(1,nres+j)-xi @@ -2662,14 +2893,14 @@ c corrected by AL zj=mod(zj,boxzsize) if (zj.lt.0) zj=zj+boxzsize c end correction - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 xj=xj_safe+xshift*boxxsize yj=yj_safe+yshift*boxysize zj=zj_safe+zshift*boxzsize @@ -2681,23 +2912,27 @@ c end correction zj_temp=zj subchap=1 endif - enddo - enddo - enddo - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif + enddo + enddo + enddo + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - sssgrad=sscagrad(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) + sss1=sscale(1.0d0/(dsqrt(rrij)),r_cut_int) + if (sss1.eq.0) cycle + sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)),r_cut_respa) + sssgrad= + & sscagrad(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)),r_cut_respa) + sssgrad1=sscagrad(1.0d0/dsqrt(rrij),r_cut_int) if (energy_dec) write (iout,*) "rrij",1.0d0/dsqrt(rrij), & " rscp",rscp(itypj,iteli)," subchap",subchap," sss",sss if (sss.lt.1.0d0) then @@ -2707,18 +2942,19 @@ c end correction if (iabs(j-i) .le. 2) then e1=scal14*e1 e2=scal14*e2 - evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss) + evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss1 endif evdwij=e1+e2 - evdw2=evdw2+evdwij*(1.0d0-sss) + evdw2=evdw2+evdwij*(1.0d0-sss)*sss1 if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') & 'evdw2',i,j,sss,evdwij C C Calculate contributions to the gradient in the virtual-bond and SC vectors. C - fac=-(evdwij+e1)*rrij*(1.0d0-sss) - fac=fac-(evdwij)*sssgrad*dsqrt(rrij)/rscp(itypj,iteli) + fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss1 + fac=fac+evdwij*dsqrt(rrij)*(-sssgrad/rscp(itypj,iteli) + & +sssgrad1)/expon ggg(1)=xj*fac ggg(2)=yj*fac ggg(3)=zj*fac @@ -2762,7 +2998,7 @@ C This subroutine calculates the excluded-volume interaction energy between C peptide-group centers and side chains and its gradient in virtual-bond and C side-chain vectors. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -2773,29 +3009,37 @@ C include 'COMMON.FFIELD' include 'COMMON.IOUNITS' include 'COMMON.CONTROL' + include "COMMON.SPLITELE" integer xshift,yshift,zshift logical lprint_short common /shortcheck/ lprint_short - dimension ggg(3) + integer i,iint,j,k,iteli,itypj,subchap + double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1, + & fac,e1,e2,rij + double precision evdw2,evdw2_14,evdwij + double precision xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp, + & dist_temp, dist_init + double precision ggg(3) + double precision sscale,sscagrad evdw2=0.0D0 evdw2_14=0.0d0 cd print '(a)','Enter ESCP' c if (lprint_short) c & write (iout,*) 'ESCP_SHORT iatscp_s=',iatscp_s, c & ' iatscp_e=',iatscp_e - if (energy_dec) write (iout,*) "escp_short:",r_cut,rlamb + if (energy_dec) write (iout,*) "escp_short:",r_cut_int,rlamb do i=iatscp_s,iatscp_e if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle iteli=itel(i) xi=0.5D0*(c(1,i)+c(1,i+1)) yi=0.5D0*(c(2,i)+c(2,i+1)) zi=0.5D0*(c(3,i)+c(3,i+1)) - xi=mod(xi,boxxsize) - if (xi.lt.0) xi=xi+boxxsize - yi=mod(yi,boxysize) - if (yi.lt.0) yi=yi+boxysize - zi=mod(zi,boxzsize) - if (zi.lt.0) zi=zi+boxzsize + xi=mod(xi,boxxsize) + if (xi.lt.0) xi=xi+boxxsize + yi=mod(yi,boxysize) + if (yi.lt.0) yi=yi+boxysize + zi=mod(zi,boxzsize) + if (zi.lt.0) zi=zi+boxzsize c if (lprint_short) c & write (iout,*) "i",i," itype",itype(i),itype(i+1), @@ -2803,7 +3047,7 @@ c & " nscp_gr",nscp_gr(i) do iint=1,nscp_gr(i) do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) + itypj=iabs(itype(j)) c if (lprint_short) c & write (iout,*) "j",j," itypj",itypj if (itypj.eq.ntyp1) cycle @@ -2823,18 +3067,18 @@ c corrected by AL zj=mod(zj,boxzsize) if (zj.lt.0) zj=zj+boxzsize c end correction - dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 + dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2 c if (lprint_short) then c write (iout,*) i,j,xi,yi,zi,xj,yj,zj c write (iout,*) "dist_init",dsqrt(dist_init) c endif - xj_safe=xj - yj_safe=yj - zj_safe=zj - subchap=0 - do xshift=-1,1 - do yshift=-1,1 - do zshift=-1,1 + xj_safe=xj + yj_safe=yj + zj_safe=zj + subchap=0 + do xshift=-1,1 + do yshift=-1,1 + do zshift=-1,1 xj=xj_safe+xshift*boxxsize yj=yj_safe+yshift*boxysize zj=zj_safe+zshift*boxzsize @@ -2846,24 +3090,25 @@ c endif zj_temp=zj subchap=1 endif - enddo - enddo - enddo + enddo + enddo + enddo c if (lprint_short) write (iout,*) "dist_temp",dsqrt(dist_temp) - if (subchap.eq.1) then - xj=xj_temp-xi - yj=yj_temp-yi - zj=zj_temp-zi - else - xj=xj_safe-xi - yj=yj_safe-yi - zj=zj_safe-zi - endif + if (subchap.eq.1) then + xj=xj_temp-xi + yj=yj_temp-yi + zj=zj_temp-zi + else + xj=xj_safe-xi + yj=yj_safe-yi + zj=zj_safe-zi + endif rrij=1.0D0/(xj*xj+yj*yj+zj*zj) c sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) c sssgrad=sscagrad(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli))) - sss=sscale(1.0d0/(dsqrt(rrij))) - sssgrad=sscagrad(1.0d0/(dsqrt(rrij))) + sss=sscale(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)),r_cut_respa) + sssgrad=sscagrad(1.0d0/(dsqrt(rrij)*rscp(itypj,iteli)), + & r_cut_respa) if (energy_dec) write (iout,*) "rrij",1.0d0/dsqrt(rrij), & " rscp",rscp(itypj,iteli)," subchap",subchap," sss",sss c if (lprint_short) write (iout,*) "rij",1.0/dsqrt(rrij), @@ -2886,7 +3131,7 @@ C C Calculate contributions to the gradient in the virtual-bond and SC vectors. C fac=-(evdwij+e1)*rrij*sss - fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/rscp(itypj,iteli) + fac=fac+evdwij*sssgrad*dsqrt(rrij)/rscp(itypj,iteli)/expon ggg(1)=xj*fac ggg(2)=yj*fac ggg(3)=zj*fac diff --git a/source/unres/src-HCD-5D/energy_p_new_barrier.F b/source/unres/src-HCD-5D/energy_p_new_barrier.F index 65091c6..2a588bd 100644 --- a/source/unres/src-HCD-5D/energy_p_new_barrier.F +++ b/source/unres/src-HCD-5D/energy_p_new_barrier.F @@ -1,5 +1,5 @@ subroutine etotal(energia) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifndef ISNAN external proc_proc @@ -10,6 +10,8 @@ cMS$ATTRIBUTES C :: proc_proc #ifdef MPI include "mpif.h" double precision weights_(n_ene) + double precision time00 + integer ierror,ierr #endif include 'COMMON.SETUP' include 'COMMON.IOUNITS' @@ -21,11 +23,19 @@ cMS$ATTRIBUTES C :: proc_proc include 'COMMON.SBRIDGE' include 'COMMON.CHAIN' include 'COMMON.VAR' - include 'COMMON.MD' +c include 'COMMON.MD' + include 'COMMON.QRESTR' include 'COMMON.CONTROL' include 'COMMON.TIME1' include 'COMMON.SPLITELE' include 'COMMON.TORCNSTR' + include 'COMMON.SAXS' + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6, + & eliptran,Eafmforce,Etube, + & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet + integer n_corr,n_corr1 #ifdef MPI c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, c & " nfgtasks",nfgtasks @@ -56,7 +66,8 @@ C FG slaves as WEIGHTS array. weights_(17)=wbond weights_(18)=scal14 weights_(21)=wsccor - weights_(22)=wtube + weights_(22)=wliptran + weights_(25)=wtube weights_(26)=wsaxs weights_(28)=wdfa_dist weights_(29)=wdfa_tor @@ -88,7 +99,8 @@ C FG slaves receive the WEIGHTS array wbond=weights(17) scal14=weights(18) wsccor=weights(21) - wtube=weights(22) + wliptran=weights(22) + wtube=weights(25) wsaxs=weights(26) wdfa_dist=weights_(28) wdfa_tor=weights_(29) @@ -314,6 +326,7 @@ C else esccor=0.0d0 endif +#ifdef FOURBODY C print *,"PRZED MULIt" c print *,"Processor",myrank," computed Usccorr" C @@ -342,6 +355,7 @@ c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr, c & n_corr1 c call flush(iout) endif +#endif c print *,"Processor",myrank," computed Ucorr" c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode if (nsaxs.gt.0 .and. saxs_mode.eq.0) then @@ -375,6 +389,8 @@ C based on partition function C print *,"przed lipidami" if (wliptran.gt.0) then call Eliptransfer(eliptran) + else + eliptran=0.0d0 endif C print *,"za lipidami" if (AFMlog.gt.0) then @@ -457,7 +473,7 @@ c print *," Processor",myrank," left SUM_ENERGY" end c------------------------------------------------------------------------------- subroutine sum_energy(energia,reduce) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifndef ISNAN external proc_proc @@ -467,6 +483,8 @@ cMS$ATTRIBUTES C :: proc_proc #endif #ifdef MPI include "mpif.h" + integer ierr + double precision time00 #endif include 'COMMON.SETUP' include 'COMMON.IOUNITS' @@ -480,6 +498,13 @@ cMS$ATTRIBUTES C :: proc_proc include 'COMMON.CONTROL' include 'COMMON.TIME1' logical reduce + integer i + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6, + & eliptran,Eafmforce,Etube, + & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet + double precision Uconst,etot #ifdef MPI if (nfgtasks.gt.1 .and. reduce) then #ifdef DEBUG @@ -591,7 +616,7 @@ c detecting NaNQ end c------------------------------------------------------------------------------- subroutine sum_gradient - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifndef ISNAN external proc_proc @@ -601,6 +626,8 @@ cMS$ATTRIBUTES C :: proc_proc #endif #ifdef MPI include 'mpif.h' + integer ierror,ierr + double precision time00,time01 #endif double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres), & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres) @@ -617,7 +644,16 @@ cMS$ATTRIBUTES C :: proc_proc include 'COMMON.TIME1' include 'COMMON.MAXGRAD' include 'COMMON.SCCOR' - include 'COMMON.MD' +c include 'COMMON.MD' + include 'COMMON.QRESTR' + integer i,j,k + double precision scalar + double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm, + &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm, + &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm, + &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm, + &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm, + &gsclocx_norm #ifdef TIMING time01=MPI_Wtime() #endif @@ -1058,13 +1094,13 @@ c gradcorr5_max=0.0d0 gradcorr6_max=0.0d0 gcorr6_turn_max=0.0d0 - gsccorc_max=0.0d0 + gsccorrc_max=0.0d0 gscloc_max=0.0d0 gvdwx_max=0.0d0 gradx_scp_max=0.0d0 ghpbx_max=0.0d0 gradxorr_max=0.0d0 - gsccorx_max=0.0d0 + gsccorrx_max=0.0d0 gsclocx_max=0.0d0 do i=1,nct gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) @@ -1096,13 +1132,13 @@ c if (gradcorr5_norm.gt.gradcorr5_max) & gradcorr5_max=gradcorr5_norm gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i))) - if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm + if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i), & gcorr6_turn(1,i))) if (gcorr6_turn_norm.gt.gcorr6_turn_max) & gcorr6_turn_max=gcorr6_turn_norm - gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) - if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm + gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) + if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i))) if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i))) @@ -1128,9 +1164,9 @@ c write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max, & gelc_max,gvdwpp_max,gradb_max,ghpbc_max, & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, + & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max, & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max + & gsccorrx_max,gsclocx_max close(istat) if (gvdwc_max.gt.1.0d4) then write (iout,*) "gvdwc gvdwx gradb gradbx" @@ -1157,12 +1193,18 @@ c end c------------------------------------------------------------------------------- subroutine rescale_weights(t_bath) - implicit real*8 (a-h,o-z) + implicit none +#ifdef MPI + include 'mpif.h' + integer ierror +#endif include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.SBRIDGE' include 'COMMON.CONTROL' + double precision t_bath + double precision facT,facT2,facT3,facT4,facT5 double precision kfac /2.4d0/ double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/ c facT=temp0/t_bath @@ -1222,13 +1264,19 @@ c write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb end C------------------------------------------------------------------------ subroutine enerprint(energia) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.SBRIDGE' - include 'COMMON.MD' + include 'COMMON.QRESTR' double precision energia(0:n_ene) + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6, + & eello_turn6, + & eliptran,Eafmforce,Etube, + & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot etot=energia(0) evdw=energia(1) evdw2=energia(2) @@ -1272,10 +1320,17 @@ C Bartek write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp, & estr,wbond,ebe,wang, & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, +#ifdef FOURBODY & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr, - & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, + & ecorr5,wcorr5,ecorr6,wcorr6, +#endif + & eel_loc,wel_loc,eello_turn3,wturn3, + & eello_turn4,wturn4, +#ifdef FOURBODY + & eello_turn6,wturn6, +#endif + & esccor,wsccor,edihcnstr, + & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce, & etube,wtube,esaxs,wsaxs,ehomology_constr, & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, & edfabet,wdfa_beta, @@ -1292,13 +1347,17 @@ C Bartek & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, & ' (SS bridges & dist. cnstr.)'/ +#ifdef FOURBODY & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ @@ -1319,9 +1378,16 @@ C Bartek write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, & estr,wbond,ebe,wang, & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, +#ifdef FOURBODY & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr, + & ecorr5,wcorr5,ecorr6,wcorr6, +#endif + & eel_loc,wel_loc,eello_turn3,wturn3, + & eello_turn4,wturn4, +#ifdef FOURBODY + & eello_turn6,wturn6, +#endif + & esccor,wsccor,edihcnstr, & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, & etube,wtube,esaxs,wsaxs,ehomology_constr, & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei, @@ -1338,13 +1404,17 @@ C Bartek & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, & ' (SS bridges & dist. restr.)'/ +#ifdef FOURBODY & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ @@ -1369,7 +1439,8 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the LJ potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none + double precision accur include 'DIMENSIONS' parameter (accur=1.0d-10) include 'COMMON.GEO' @@ -1382,8 +1453,18 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' + include 'COMMON.SPLITELE' +#ifdef FOURBODY include 'COMMON.CONTACTS' - dimension gg(3) + include 'COMMON.CONTMAT' +#endif + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj,itypi1,num_conti,iint + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij, + & sigij,r0ij,rcut,sqrij,sss1,sssgrad1 + double precision fcont,fprimcont + double precision sscale,sscagrad c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e @@ -1410,6 +1491,11 @@ cd & 'iend=',iend(i,iint) C Change 12/1/95 to calculate four-body interactions rij=xj*xj+yj*yj+zj*zj rrij=1.0D0/rij + sqrij=dsqrt(rij) + sss1=sscale(sqrij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(sqrij,r_cut_int) + c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj eps0ij=eps(itypi,itypj) fac=rrij**expon2 @@ -1423,11 +1509,12 @@ cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj), cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+evdwij + evdw=evdw+sss1*evdwij C C Calculate the components of the gradient in DC and X C - fac=-rrij*(e1+evdwij) + fac=-rrij*(e1+evdwij)*sss1 + & +evdwij*sssgrad1/sqrij/expon gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -1443,6 +1530,7 @@ cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) cgrad enddo cgrad enddo C +#ifdef FOURBODY C 12/1/95, revised on 5/20/97 C C Calculate the contact function. The ith column of the array JCONT will @@ -1498,10 +1586,13 @@ cd write (iout,'(2i3,3f10.5)') cd & i,j,(gacont(kk,num_conti,i),kk=1,3) endif endif +#endif enddo ! j enddo ! iint C Change 12/1/95 +#ifdef FOURBODY num_cont(i)=num_conti +#endif enddo ! i do i=1,nct do j=1,3 @@ -1526,7 +1617,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the LJK potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -1536,8 +1627,14 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.NAMES' - dimension gg(3) + include 'COMMON.SPLITELE' + double precision gg(3) + double precision evdw,evdwij + integer i,j,k,itypi,itypj,itypi1,iint + double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij, + & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1 logical scheck + double precision sscale,sscagrad c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 do i=iatsc_s,iatsc_e @@ -1562,6 +1659,9 @@ C e_augm=augm(itypi,itypj)*fac_augm r_inv_ij=dsqrt(rrij) rij=1.0D0/r_inv_ij + sss1=sscale(rij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(rij,r_cut_int) r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) fac=r_shift_inv**expon C have you changed here? @@ -1575,11 +1675,12 @@ cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+evdwij + evdw=evdw+evdwij*sss1 C C Calculate the components of the gradient in DC and X C fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) + & +evdwij*sssgrad1*r_inv_ij/expon gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -1611,7 +1712,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Berne-Pechukas potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -1622,7 +1723,14 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' + include 'COMMON.SPLITELE' + integer icall common /srutu/ icall + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi, + & sss1,sssgrad1 + double precision sscale,sscagrad c double precision rrsave(maxdim) logical lprn evdw=0.0D0 @@ -1688,6 +1796,9 @@ cd else cd rrij=rrsave(ind) cd endif rij=dsqrt(rrij) + sss1=sscale(1.0d0/rij,r_cut_int) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(1.0d0/rij,r_cut_int) C Calculate the angle-dependent terms of energy & contributions to derivatives. call sc_angular C Calculate whole angle-dependent part of epsilon and contributions @@ -1700,7 +1811,7 @@ C have you changed here? eps2der=evdwij*eps3rt eps3der=evdwij*eps2rt evdwij=evdwij*eps2rt*eps3rt - evdw=evdw+evdwij + evdw=evdw+sss1*evdwij if (lprn) then sigm=dabs(aa/bb)**(1.0D0/6.0D0) epsi=bb**2/aa @@ -1716,6 +1827,7 @@ C Calculate gradient components. fac=-expon*(e1+evdwij) sigder=fac/sigsq fac=rrij*fac + & +evdwij*sssgrad1/sss1*rij C Calculate radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac @@ -1735,7 +1847,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Gay-Berne potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -1750,8 +1862,14 @@ C include 'COMMON.SPLITELE' include 'COMMON.SBRIDGE' logical lprn - integer xshift,yshift,zshift - + integer xshift,yshift,zshift,subchap + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi + double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij, + & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip + double precision dist,sscale,sscagrad,sscagradlip,sscalelip evdw=0.0D0 ccccc energy_dec=.false. C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon @@ -2014,12 +2132,11 @@ c write (iout,*) "j",j," dc_norm", c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) - sss=sscale((1.0d0/rij)/sigma(itypi,itypj)) - sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj)) - + sss=sscale(1.0d0/rij,r_cut_int) c write (iout,'(a7,4f8.3)') c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb - if (sss.gt.0.0d0) then + if (sss.eq.0.0d0) cycle + sssgrad=sscagrad(1.0d0/rij,r_cut_int) C Calculate angle-dependent terms of energy and contributions to their C derivatives. call sc_angular @@ -2066,8 +2183,8 @@ c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2 & evdwij endif - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw',i,j,evdwij + if (energy_dec) write (iout,'(a,2i5,3f10.5)') + & 'r sss evdw',i,j,rij,sss,evdwij C Calculate gradient components. e1=e1*eps1*eps2rt**2*eps3rt**2 @@ -2076,13 +2193,13 @@ C Calculate gradient components. fac=rij*fac c print '(2i4,6f8.4)',i,j,sss,sssgrad* c & evdwij,fac,sigma(itypi,itypj),expon - fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij + fac=fac+evdwij*sssgrad/sss*rij c fac=0.0d0 C Calculate the radial part of the gradient gg_lipi(3)=eps1*(eps2rt*eps2rt) - &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip* - & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj)) - &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj))) + & *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip* + & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj)) + & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj))) gg_lipj(3)=ssgradlipj*gg_lipi(3) gg_lipi(3)=gg_lipi(3)*ssgradlipi C gg_lipi(3)=0.0d0 @@ -2091,8 +2208,8 @@ C gg_lipj(3)=0.0d0 gg(2)=yj*fac gg(3)=zj*fac C Calculate angular part of the gradient. +c call sc_grad_scale(sss) call sc_grad - endif ENDIF ! dyn_ss enddo ! j enddo ! iint @@ -2110,7 +2227,7 @@ C C This subroutine calculates the interaction energy of nonbonded side chains C assuming the Gay-Berne-Vorobjev potential of interaction. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -2121,9 +2238,19 @@ C include 'COMMON.INTERACT' include 'COMMON.IOUNITS' include 'COMMON.CALC' - integer xshift,yshift,zshift + include 'COMMON.SPLITELE' + integer xshift,yshift,zshift,subchap + integer icall common /srutu/ icall logical lprn + double precision evdw + integer itypi,itypj,itypi1,iint,ind + double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij, + & xi,yi,zi,fac_augm,e_augm + double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij, + & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip,sssgrad1 + double precision dist,sscale,sscagrad,sscagradlip,sscalelip evdw=0.0D0 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon evdw=0.0D0 @@ -2282,6 +2409,9 @@ C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj dzj=dc_norm(3,nres+j) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) + sss=sscale(1.0d0/rij,r_cut_int) + if (sss.eq.0.0d0) cycle + sssgrad=sscagrad(1.0d0/rij,r_cut_int) C Calculate angle-dependent terms of energy and contributions to their C derivatives. call sc_angular @@ -2322,12 +2452,13 @@ C Calculate gradient components. fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac-2*expon*rrij*e_augm - fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij + fac=fac+(evdwij+e_augm)*sssgrad/sss*rij C Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac C Calculate angular part of the gradient. +c call sc_grad_scale(sss) call sc_grad enddo ! j enddo ! iint @@ -2477,7 +2608,7 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' dimension gg(3) cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct evdw=0.0D0 @@ -2551,7 +2682,7 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -2632,8 +2763,8 @@ c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) zj=zj_safe-zmedi endif rij=xj*xj+yj*yj+zj*zj - sss=sscale(sqrt(rij)) - sssgrad=sscagrad(sqrt(rij)) + sss=sscale(sqrt(rij),r_cut_int) + sssgrad=sscagrad(sqrt(rij),r_cut_int) if (rij.lt.r0ijsq) then evdw1ij=0.25d0*(rij-r0ijsq)**2 fac=rij-r0ijsq @@ -2858,90 +2989,6 @@ c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1) #endif return end -C----------------------------------------------------------------------------- - subroutine check_vecgrad - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.VECTORS' - dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres) - dimension uyt(3,maxres),uzt(3,maxres) - dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3) - double precision delta /1.0d-7/ - call vec_and_deriv -cd do i=1,nres -crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i) -crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i) -crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i) -cd write(iout,'(2i5,2(3f10.5,5x))') i,1, -cd & (dc_norm(if90,i),if90=1,3) -cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3) -cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3) -cd write(iout,'(a)') -cd enddo - do i=1,nres - do j=1,2 - do k=1,3 - do l=1,3 - uygradt(l,k,j,i)=uygrad(l,k,j,i) - uzgradt(l,k,j,i)=uzgrad(l,k,j,i) - enddo - enddo - enddo - enddo - call vec_and_deriv - do i=1,nres - do j=1,3 - uyt(j,i)=uy(j,i) - uzt(j,i)=uz(j,i) - enddo - enddo - do i=1,nres -cd write (iout,*) 'i=',i - do k=1,3 - erij(k)=dc_norm(k,i) - enddo - do j=1,3 - do k=1,3 - dc_norm(k,i)=erij(k) - enddo - dc_norm(j,i)=dc_norm(j,i)+delta -c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))) -c do k=1,3 -c dc_norm(k,i)=dc_norm(k,i)/fac -c enddo -c write (iout,*) (dc_norm(k,i),k=1,3) -c write (iout,*) (erij(k),k=1,3) - call vec_and_deriv - do k=1,3 - uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta - uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta - uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta - uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta - enddo -c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') -c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3), -c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3) - enddo - do k=1,3 - dc_norm(k,i)=erij(k) - enddo -cd do k=1,3 -cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') -cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3), -cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3) -cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)') -cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3), -cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3) -cd write (iout,'(a)') -cd enddo - enddo - return - end C-------------------------------------------------------------------------- subroutine set_matrices implicit real*8 (a-h,o-z) @@ -2959,7 +3006,7 @@ C-------------------------------------------------------------------------- include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -2975,18 +3022,26 @@ c write(iout,*) "itype2loc",itype2loc #else do i=3,nres+1 #endif - if (i.gt. nnt+2 .and. i.lt.nct+2) then + ii=ireschain(i-2) +c write (iout,*) "i",i,i-2," ii",ii + if (ii.eq.0) cycle + innt=chain_border(1,ii) + inct=chain_border(2,ii) +c write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct +c if (i.gt. nnt+2 .and. i.lt.nct+2) then + if (i.gt. innt+2 .and. i.lt.inct+2) then iti = itype2loc(itype(i-2)) else iti=nloctyp endif c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then - if (i.gt. nnt+1 .and. i.lt.nct+1) then + if (i.gt. innt+1 .and. i.lt.inct+1) then iti1 = itype2loc(itype(i-1)) else iti1=nloctyp endif -c write(iout,*),i +c write(iout,*),"i",i,i-2," iti",itype(i-2),iti, +c & " iti1",itype(i-1),iti1 #ifdef NEWCORR cost1=dcos(theta(i-1)) sint1=dsin(theta(i-1)) @@ -3052,7 +3107,8 @@ c b2tilde(2,i-2)=-b2(2,i-2) write (iout,*) 'theta=', theta(i-1) #endif #else - if (i.gt. nnt+2 .and. i.lt.nct+2) then + if (i.gt. innt+2 .and. i.lt.inct+2) then +c if (i.gt. nnt+2 .and. i.lt.nct+2) then iti = itype2loc(itype(i-2)) else iti=nloctyp @@ -3097,12 +3153,14 @@ c write(iout,*) 'b2=',(b2(k,i-2),k=1,2) #endif enddo + mu=0.0d0 #ifdef PARMAT do i=ivec_start+2,ivec_end+2 #else do i=3,nres+1 #endif - if (i .lt. nres+1) then +c if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle + if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then sin1=dsin(phi(i)) cos1=dcos(phi(i)) sintab(i-2)=sin1 @@ -3139,7 +3197,7 @@ c Ug2(2,1,i-2)=0.0d0 Ug2(2,2,i-2)=0.0d0 endif - if (i .gt. 3 .and. i .lt. nres+1) then + if (i .gt. 3) then obrot_der(1,i-2)=-sin1 obrot_der(2,i-2)= cos1 Ugder(1,1,i-2)= sin1 @@ -3169,7 +3227,8 @@ c Ug2der(2,2,i-2)=0.0d0 endif c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then - if (i.gt. nnt+2 .and. i.lt.nct+2) then +c if (i.gt. nnt+2 .and. i.lt.nct+2) then + if (i.gt.nnt+2 .and.i.lt.nct+2) then iti = itype2loc(itype(i-2)) else iti=nloctyp @@ -3198,6 +3257,7 @@ c & EE(1,2,iti),EE(2,2,i) c write(iout,*) "Macierz EUG", c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2), c & eug(2,2,i-2) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) & then call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2)) @@ -3206,6 +3266,7 @@ c & eug(2,2,i-2) call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2)) call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2)) endif +#endif else do k=1,2 Ub2(k,i-2)=0.0d0 @@ -3250,6 +3311,7 @@ c mu(k,i-2)=Ub2(k,i-2) cd write (iout,*) 'mu1',mu1(:,i-2) cd write (iout,*) 'mu2',mu2(:,i-2) cd write (iout,*) 'mu',i-2,mu(:,i-2) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) & then call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2)) @@ -3268,7 +3330,9 @@ C Vectors and matrices dependent on a single virtual-bond dihedral. call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2)) call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2)) endif +#endif enddo +#ifdef FOURBODY C Matrices dependent on two consecutive virtual-bond dihedrals. C The order of matrices is from left to right. if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) @@ -3285,6 +3349,7 @@ c do i=max0(ivec_start,2),ivec_end call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i)) enddo endif +#endif #if defined(MPI) && defined(PARMAT) #ifdef DEBUG c if (fg_rank.eq.0) then @@ -3353,6 +3418,7 @@ c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1) call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1), & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0), & MPI_DOUBLE_PRECISION,FG_COMM1,IERR) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) & then call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1), @@ -3428,6 +3494,7 @@ c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1) & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0), & MPI_MAT2,FG_COMM1,IERR) endif +#endif #else c Passes matrix info through the ring isend=fg_rank1 @@ -3472,6 +3539,7 @@ c call flush(iout) & iprev,6600+irecv,FG_COMM,status,IERR) c write (iout,*) "Gather PRECOMP12" c call flush(iout) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) & then call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1, @@ -3491,6 +3559,7 @@ c call flush(iout) & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1, & MPI_PRECOMP23(lenrecv), & iprev,9900+irecv,FG_COMM,status,IERR) +#endif c write (iout,*) "Gather PRECOMP23" c call flush(iout) endif @@ -3543,7 +3612,7 @@ cd enddo cd enddo return end -C-------------------------------------------------------------------------- +C----------------------------------------------------------------------------- subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) C C This subroutine calculates the average interaction energy and its gradient @@ -3566,7 +3635,11 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -3639,9 +3712,11 @@ cd enddo eello_turn3=0.0d0 eello_turn4=0.0d0 ind=0 +#ifdef FOURBODY do i=1,nres num_cont_hb(i)=0 enddo +#endif cd print '(a)','Enter EELEC' cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e do i=1,nres @@ -3691,7 +3766,9 @@ c end if num_conti=0 call eelecij(i,i+2,ees,evdw1,eel_loc) if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo do i=iturn4_start,iturn4_end if (i.lt.1) cycle @@ -3747,12 +3824,16 @@ c endif zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif c write(iout,*) "JESTEM W PETLI" call eelecij(i,i+3,ees,evdw1,eel_loc) if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) & call eturn4(i,eello_turn4) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i C Loop over all neighbouring boxes C do xshift=-1,1 @@ -3819,7 +3900,9 @@ c go to 166 c endif c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif C I TU KURWA do j=ielstart(i),ielend(i) C do j=16,17 @@ -3835,7 +3918,9 @@ c & .or.itype(j-1).eq.ntyp1 &) cycle call eelecij(i,j,ees,evdw1,eel_loc) enddo ! j +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i C enddo ! zshift C enddo ! yshift @@ -3853,7 +3938,7 @@ cd print *,"Processor",fg_rank," t_eelecij",t_eelecij end C------------------------------------------------------------------------------- subroutine eelecij(i,j,ees,evdw1,eel_loc) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include "mpif.h" @@ -3866,21 +3951,44 @@ C------------------------------------------------------------------------------- include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' include 'COMMON.TIME1' include 'COMMON.SPLITELE' include 'COMMON.SHIELD' - dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), + double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3), & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3) double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4), & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4), & gmuij2(4),gmuji2(4) + double precision dxi,dyi,dzi + double precision dx_normi,dy_normi,dz_normi,aux + integer j1,j2,lll,num_conti common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33, & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi, & num_conti,j1,j2 + integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield + double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp + double precision ees,evdw1,eel_loc,aaa,bbb,ael3i + double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj, + & rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4, + & evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa, + & ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der, + & a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij, + & ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp, + & ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp, + & ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield + double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji + double precision dist_init,xj_safe,yj_safe,zj_safe, + & xj_temp,yj_temp,zj_temp,dist_temp,xmedi,ymedi,zmedi + double precision sscale,sscagrad,scalar + c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions #ifdef MOMENT double precision scal_el /1.0d0/ @@ -3984,8 +4092,9 @@ C yj=yj-ymedi C zj=zj-zmedi rij=xj*xj+yj*yj+zj*zj - sss=sscale(sqrt(rij)) - sssgrad=sscagrad(sqrt(rij)) + sss=sscale(dsqrt(rij),r_cut_int) + if (sss.eq.0.0d0) return + sssgrad=sscagrad(dsqrt(rij),r_cut_int) c if (sss.gt.0.0d0) then rrmij=1.0D0/rij rij=dsqrt(rij) @@ -4020,7 +4129,7 @@ C fac_shield(j)=0.6 fac_shield(i)=1.0 fac_shield(j)=1.0 eesij=(el1+el2) - ees=ees+eesij + ees=ees+eesij*sss endif evdw1=evdw1+evdwij*sss cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)') @@ -4029,11 +4138,10 @@ cd & 1.0D0/dsqrt(rrmij),evdwij,eesij, cd & xmedi,ymedi,zmedi,xj,yj,zj if (energy_dec) then - write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)') - &'evdw1',i,j,evdwij - &,iteli,itelj,aaa,evdw1,sss - write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij, - &fac_shield(i),fac_shield(j) + write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)') + & 'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij + write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij, + & fac_shield(i),fac_shield(j) endif C @@ -4050,9 +4158,10 @@ C * * Radial derivatives. First process both termini of the fragment (i,j) * - ggg(1)=facel*xj - ggg(2)=facel*yj - ggg(3)=facel*zj + aux=facel*sss+rmij*sssgrad*eesij + ggg(1)=aux*xj + ggg(2)=aux*yj + ggg(3)=aux*zj if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. & (shield_mode.gt.0)) then C print *,i,j @@ -4086,10 +4195,10 @@ C endif iresshield=shield_list(ilist,j) do k=1,3 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) - & *2.0 + & *2.0*sss gshieldx(k,iresshield)=gshieldx(k,iresshield)+ & rlocshield - & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 + & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j) @@ -4112,13 +4221,13 @@ C endif do k=1,3 gshieldc(k,i)=gshieldc(k,i)+ - & grad_shield(k,i)*eesij/fac_shield(i)*2.0 + & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss gshieldc(k,j)=gshieldc(k,j)+ - & grad_shield(k,j)*eesij/fac_shield(j)*2.0 + & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss gshieldc(k,i-1)=gshieldc(k,i-1)+ - & grad_shield(k,i)*eesij/fac_shield(i)*2.0 + & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss gshieldc(k,j-1)=gshieldc(k,j-1)+ - & grad_shield(k,j)*eesij/fac_shield(j)*2.0 + & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss enddo endif @@ -4149,15 +4258,10 @@ cgrad do l=1,3 cgrad gelc(l,k)=gelc(l,k)+ggg(l) cgrad enddo cgrad enddo - if (sss.gt.0.0) then - ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj - ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj - ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj - else - ggg(1)=0.0 - ggg(2)=0.0 - ggg(3)=0.0 - endif + facvdw=facvdw+sssgrad*rmij*evdwij + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj c do k=1,3 c ghalf=0.5D0*ggg(k) c gvdwpp(k,i)=gvdwpp(k,i)+ghalf @@ -4178,10 +4282,11 @@ cgrad enddo cgrad enddo #else C MARYSIA - facvdw=(ev1+evdwij)*sss + facvdw=(ev1+evdwij) facel=(el1+eesij) fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) + fac=-3*rrmij*(facvdw+facvdw+facel)*sss + & +(evdwij+eesij)*sssgrad*rrmij erij(1)=xj*rmij erij(2)=yj*rmij erij(3)=zj*rmij @@ -4237,7 +4342,7 @@ cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3), cd & (dcosg(k),k=1,3) do k=1,3 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))* - & fac_shield(i)**2*fac_shield(j)**2 + & fac_shield(i)**2*fac_shield(j)**2*sss enddo c do k=1,3 c ghalf=0.5D0*ggg(k) @@ -4257,11 +4362,11 @@ C print *,"before22", gelc_long(1,i), gelc_long(1,j) do k=1,3 gelc(k,i)=gelc(k,i) & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) - & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)) + & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss & *fac_shield(i)**2*fac_shield(j)**2 gelc(k,j)=gelc(k,j) & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) - & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)) + & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss & *fac_shield(i)**2*fac_shield(j)**2 gelc_long(k,j)=gelc_long(k,j)+ggg(k) gelc_long(k,i)=gelc_long(k,i)-ggg(k) @@ -4497,7 +4602,7 @@ C fac_shield(i)=0.4 C fac_shield(j)=0.6 endif eel_loc_ij=eel_loc_ij - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') c & 'eelloc',i,j,eel_loc_ij C Now derivative over eel_loc @@ -4555,7 +4660,7 @@ C Calculate patrial derivative for theta angle & +a23*gmuij1(2) & +a32*gmuij1(3) & +a33*gmuij1(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss c write(iout,*) "derivative over thatai" c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3), c & a33*gmuij1(4) @@ -4571,7 +4676,7 @@ c & a33*gmuij2(4) & +a33*gmuij2(4) gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ & geel_loc_ij*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss c Derivative over j residue geel_loc_ji=a22*gmuji1(1) @@ -4584,7 +4689,7 @@ c & a33*gmuji1(4) gloc(nphi+j,icg)=gloc(nphi+j,icg)+ & geel_loc_ji*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss geel_loc_ji= & +a22*gmuji2(1) @@ -4596,7 +4701,7 @@ c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3), c & a33*gmuji2(4) gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+ & geel_loc_ji*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss #endif cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij @@ -4612,17 +4717,21 @@ C Partial derivatives in virtual-bond dihedral angles gamma & gel_loc_loc(i-1)=gel_loc_loc(i-1)+ & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gel_loc_loc(j-1)=gel_loc_loc(j-1)+ & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) + aux=eel_loc_ij/sss*sssgrad*rmij + ggg(1)=aux*xj + ggg(2)=aux*yj + ggg(3)=aux*zj do l=1,3 - ggg(l)=(agg(l,1)*muij(1)+ + ggg(l)=ggg(l)+(agg(l,1)*muij(1)+ & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) cgrad ghalf=0.5d0*ggg(l) @@ -4638,24 +4747,25 @@ C Remaining derivatives of eello do l=1,3 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss enddo ENDIF C Change 12/26/95 to calculate four-body contributions to H-bonding energy c if (j.gt.i+1 .and. num_conti.le.maxconts) then +#ifdef FOURBODY if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 & .and. num_conti.le.maxconts) then c write (iout,*) i,j," entered corr" @@ -4739,9 +4849,9 @@ C fac_shield(i)=0.4d0 C fac_shield(j)=0.6d0 endif ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss C Diagnostics. Comment out or remove after debugging! c ees0p(num_conti,i)=0.5D0*fac3*ees0pij c ees0m(num_conti,i)=0.5D0*fac3*ees0mij @@ -4790,11 +4900,17 @@ cd fprimcont=0.0D0 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) enddo gggp(1)=gggp(1)+ees0pijp*xj + & +ees0p(num_conti,i)/sss*rmij*xj*sssgrad gggp(2)=gggp(2)+ees0pijp*yj + & +ees0p(num_conti,i)/sss*rmij*yj*sssgrad gggp(3)=gggp(3)+ees0pijp*zj + & +ees0p(num_conti,i)/sss*rmij*zj*sssgrad gggm(1)=gggm(1)+ees0mijp*xj + & +ees0m(num_conti,i)/sss*rmij*xj*sssgrad gggm(2)=gggm(2)+ees0mijp*yj + & +ees0m(num_conti,i)/sss*rmij*yj*sssgrad gggm(3)=gggm(3)+ees0mijp*zj + & +ees0m(num_conti,i)/sss*rmij*zj*sssgrad C Derivatives due to the contact function gacont_hbr(1,num_conti,i)=fprimcont*xj gacont_hbr(2,num_conti,i)=fprimcont*yj @@ -4809,28 +4925,28 @@ cgrad ghalfm=0.5D0*gggm(k) gacontp_hb1(k,num_conti,i)=!ghalfp & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontp_hb2(k,num_conti,i)=!ghalfp & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontp_hb3(k,num_conti,i)=gggp(k) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontm_hb1(k,num_conti,i)=!ghalfm & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontm_hb2(k,num_conti,i)=!ghalfm & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontm_hb3(k,num_conti,i)=gggm(k) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss enddo C Diagnostics. Comment out or remove after debugging! @@ -4846,6 +4962,7 @@ cdiag enddo endif ! num_conti.le.maxconts endif ! fcont.gt.0 endif ! j.gt.i+1 +#endif if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then do k=1,4 do l=1,3 @@ -4878,7 +4995,7 @@ C Third- and fourth-order contributions from turns include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -5061,7 +5178,7 @@ C Third- and fourth-order contributions from turns include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -5610,7 +5727,7 @@ C This subroutine calculates the excluded-volume interaction energy between C peptide-group centers and side chains and its gradient in virtual-bond and C side-chain vectors. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -5623,7 +5740,14 @@ C include 'COMMON.CONTROL' include 'COMMON.SPLITELE' integer xshift,yshift,zshift - dimension ggg(3) + double precision ggg(3) + integer i,iint,j,k,iteli,itypj,subchap + double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1, + & fac,e1,e2,rij + double precision evdw2,evdw2_14,evdwij + double precision xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp, + & dist_temp, dist_init + double precision sscale,sscagrad evdw2=0.0D0 evdw2_14=0.0d0 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla' @@ -5632,7 +5756,7 @@ cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e C do xshift=-1,1 C do yshift=-1,1 C do zshift=-1,1 - if (energy_dec) write (iout,*) "escp:",r_cut,rlamb + if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb do i=iatscp_s,iatscp_e if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle iteli=itel(i) @@ -5754,11 +5878,11 @@ CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE c print *,xj,yj,zj,'polozenie j' rrij=1.0D0/(xj*xj+yj*yj+zj*zj) c print *,rrij - sss=sscale(1.0d0/(dsqrt(rrij))) + sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int) c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz' c if (sss.eq.0) print *,'czasem jest OK' if (sss.le.0.0d0) cycle - sssgrad=sscagrad(1.0d0/(dsqrt(rrij))) + sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int) fac=rrij**expon2 e1=fac*fac*aad(itypj,iteli) e2=fac*bad(itypj,iteli) @@ -5769,8 +5893,9 @@ c if (sss.eq.0) print *,'czasem jest OK' endif evdwij=e1+e2 evdw2=evdw2+evdwij*sss - if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') - & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli), + if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)') + & 'evdw2',i,j,1.0d0/dsqrt(rrij),sss, + & evdwij,iteli,itypj,fac,aad(itypj,iteli), & bad(itypj,iteli) C C Calculate contributions to the gradient in the virtual-bond and SC vectors. @@ -6185,6 +6310,12 @@ c estr=0.0d0 estr1=0.0d0 do i=ibondp_start,ibondp_end +c 3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are +c used +#ifdef FIVEDIAG + if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle + diff = vbld(i)-vbldp0 +#else if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) c do j=1,3 @@ -6195,15 +6326,16 @@ c if (energy_dec) write(iout,*) c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax) c else C Checking if it involves dummy (NH3+ or COO-) group - if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then + if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then C YES vbldpDUM is the equlibrium length of spring for Dummy atom - diff = vbld(i)-vbldpDUM - if (energy_dec) write(iout,*) "dum_bond",i,diff - else -C NO vbldp0 is the equlibrium lenght of spring for peptide group - diff = vbld(i)-vbldp0 - endif - if (energy_dec) write (iout,'(a7,i5,4f7.3)') + diff = vbld(i)-vbldpDUM + if (energy_dec) write(iout,*) "dum_bond",i,diff + else +C NO vbldp0 is the equlibrium length of spring for peptide group + diff = vbld(i)-vbldp0 + endif +#endif + if (energy_dec) write (iout,'(a7,i5,4f7.3)') & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff estr=estr+diff*diff do j=1,3 @@ -6713,8 +6845,6 @@ C print *,ethetai & phii1*rad2deg,ethetai c lprn1=.false. etheta=etheta+ethetai - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'ebend',i,ethetai if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai @@ -7157,9 +7287,8 @@ c & sumene4, c & dscp1,dscp2,sumene c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) escloc = escloc + sumene - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'escloc',i,sumene -c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i) + if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it, + & " escloc",sumene,escloc,it,itype(i) c & ,zz,xx,yy c#define DEBUG #ifdef DEBUG @@ -7656,7 +7785,6 @@ C 6/23/01 Compute double torsional energy include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' logical lprn C Set lprn=.true. for debugging lprn=.false. @@ -7673,7 +7801,6 @@ C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or. & (itype(i+1).eq.ntyp1)) cycle C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF - etors_d_ii=0.0D0 itori=itortyp(itype(i-2)) itori1=itortyp(itype(i-1)) itori2=itortyp(itype(i)) @@ -7708,8 +7835,6 @@ C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock) sinphi2=dsin(j*phii1) etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ & v2cij*cosphi2+v2sij*sinphi2 - if (energy_dec) etors_d_ii=etors_d_ii+ - & v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) enddo @@ -7725,17 +7850,12 @@ C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock) sinphi1m2=dsin(l*phii-(k-l)*phii1) etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ & v1sdij*sinphi1p2+v2sdij*sinphi1m2 - if (energy_dec) etors_d_ii=etors_d_ii+ - & v1cdij*cosphi1p2+v2cdij*cosphi1m2+ - & v1sdij*sinphi1p2+v2sdij*sinphi1m2 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) enddo enddo - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'etor_d',i,etors_d_ii gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 enddo @@ -7936,10 +8056,11 @@ c do i=1,ndih_constr c---------------------------------------------------------------------------- c MODELLER restraint function subroutine e_modeller(ehomology_constr) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' - integer nnn, i, j, k, ki, irec, l + double precision ehomology_constr + integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l integer katy, odleglosci, test7 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template) real*8 Eval,Erot @@ -7955,8 +8076,11 @@ c double precision, dimension (max_template) :: & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3, & theta_diff + double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih, + & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz, + & betai,sum_sgodl,dij + double precision dist,pinorm c - include 'COMMON.SBRIDGE' include 'COMMON.CHAIN' include 'COMMON.GEO' @@ -7965,8 +8089,10 @@ c include 'COMMON.INTERACT' include 'COMMON.VAR' include 'COMMON.IOUNITS' - include 'COMMON.MD' +c include 'COMMON.MD' include 'COMMON.CONTROL' + include 'COMMON.HOMOLOGY' + include 'COMMON.QRESTR' c c From subroutine Econstr_back c @@ -8682,12 +8808,12 @@ c write (iout,*) "EBACK_SC_COR",itau_start,itau_end esccor=0.0D0 do i=itau_start,itau_end if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle + esccor_ii=0.0D0 isccori=isccortyp(itype(i-2)) isccori1=isccortyp(itype(i-1)) c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1) phii=phi(i) do intertyp=1,3 !intertyp - esccor_ii=0.0D0 cc Added 09 May 2012 (Adasko) cc Intertyp means interaction type of backbone mainchain correlation: c 1 = SC...Ca...Ca...Ca @@ -8711,12 +8837,9 @@ c 3 = SC...Ca...Ca...SCi v2ij=v2sccor(j,intertyp,isccori,isccori1) cosphi=dcos(j*tauangle(intertyp,i)) sinphi=dsin(j*tauangle(intertyp,i)) - if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi esccor=esccor+v1ij*cosphi+v2ij*sinphi gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) enddo - if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') - & 'esccor',i,intertyp,esccor_ii c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci if (lprn) @@ -8730,6 +8853,7 @@ c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp return end +#ifdef FOURBODY c---------------------------------------------------------------------------- subroutine multibody(ecorr) C This subroutine calculates multi-body contributions to energy following @@ -8742,6 +8866,8 @@ C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision gx(3),gx1(3) logical lprn @@ -8796,6 +8922,8 @@ c------------------------------------------------------------------------------ include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.SHIELD' double precision gx(3),gx1(3) logical lprn @@ -8850,6 +8978,8 @@ C This subroutine calculates multi-body contributions to hydrogen-bonding include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.CONTROL' include 'COMMON.LOCAL' double precision gx(3),gx1(3),time00 @@ -9143,6 +9273,8 @@ c------------------------------------------------------------------------------ parameter (max_cont=maxconts) parameter (max_dim=26) include "COMMON.CONTACTS" + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision zapas(max_dim,maxconts,max_fg_procs), & zapas_recv(max_dim,maxconts,max_fg_procs) common /przechowalnia/ zapas @@ -9214,6 +9346,8 @@ C This subroutine calculates multi-body contributions to hydrogen-bonding include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.CHAIN' include 'COMMON.CONTROL' include 'COMMON.SHIELD' @@ -9584,6 +9718,8 @@ c------------------------------------------------------------------------------ parameter (max_cont=maxconts) parameter (max_dim=70) include "COMMON.CONTACTS" + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision zapas(max_dim,maxconts,max_fg_procs), & zapas_recv(max_dim,maxconts,max_fg_procs) common /przechowalnia/ zapas @@ -9637,6 +9773,8 @@ c------------------------------------------------------------------------------ include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.SHIELD' include 'COMMON.CONTROL' double precision gx(3),gx1(3) @@ -9812,6 +9950,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -9877,6 +10017,8 @@ C include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10263,6 +10405,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10384,6 +10528,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10788,6 +10934,8 @@ c-------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -10928,6 +11076,8 @@ c-------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -11032,6 +11182,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -11217,6 +11369,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -11332,6 +11486,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -11576,6 +11732,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -11894,8 +12052,8 @@ cd write (2,*) 'ekont',ekont cd write (2,*) 'eel_turn6',ekont*eel_turn6 return end - C----------------------------------------------------------------------------- +#endif double precision function scalar(u,v) !DIR$ INLINEALWAYS scalar #ifndef OSF @@ -12969,8 +13127,18 @@ c---------------------------------------------------------------------------- include 'COMMON.INTERACT' include 'COMMON.VAR' include 'COMMON.IOUNITS' - include 'COMMON.MD' +c include 'COMMON.MD' +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif include 'COMMON.CONTROL' + include 'COMMON.SAXS' include 'COMMON.NAMES' include 'COMMON.TIME1' include 'COMMON.FFIELD' @@ -13279,8 +13447,18 @@ c---------------------------------------------------------------------------- include 'COMMON.INTERACT' include 'COMMON.VAR' include 'COMMON.IOUNITS' - include 'COMMON.MD' +c include 'COMMON.MD' +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif include 'COMMON.CONTROL' + include 'COMMON.SAXS' include 'COMMON.NAMES' include 'COMMON.TIME1' include 'COMMON.FFIELD' diff --git a/source/unres/src-HCD-5D/energy_p_new_barrier.F.orig b/source/unres/src-HCD-5D/energy_p_new_barrier.F.orig deleted file mode 100644 index ac5a20a..0000000 --- a/source/unres/src-HCD-5D/energy_p_new_barrier.F.orig +++ /dev/null @@ -1,8915 +0,0 @@ - subroutine etotal(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" - double precision weights_(n_ene) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene) - include 'COMMON.LOCAL' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' -#ifdef MPI -c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank, -c & " nfgtasks",nfgtasks - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (fg_rank.eq.0) then - call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR) -c print *,"Processor",myrank," BROADCAST iorder" -C FG master sets up the WEIGHTS_ array which will be broadcast to the -C FG slaves as WEIGHTS array. - weights_(1)=wsc - weights_(2)=wscp - weights_(3)=welec - weights_(4)=wcorr - weights_(5)=wcorr5 - weights_(6)=wcorr6 - weights_(7)=wel_loc - weights_(8)=wturn3 - weights_(9)=wturn4 - weights_(10)=wturn6 - weights_(11)=wang - weights_(12)=wscloc - weights_(13)=wtor - weights_(14)=wtor_d - weights_(15)=wstrain - weights_(16)=wvdwpp - weights_(17)=wbond - weights_(18)=scal14 - weights_(21)=wsccor -C FG Master broadcasts the WEIGHTS_ array - call MPI_Bcast(weights_(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - else -C FG slaves receive the WEIGHTS array - call MPI_Bcast(weights(1),n_ene, - & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) - wsc=weights(1) - wscp=weights(2) - welec=weights(3) - wcorr=weights(4) - wcorr5=weights(5) - wcorr6=weights(6) - wel_loc=weights(7) - wturn3=weights(8) - wturn4=weights(9) - wturn6=weights(10) - wang=weights(11) - wscloc=weights(12) - wtor=weights(13) - wtor_d=weights(14) - wstrain=weights(15) - wvdwpp=weights(16) - wbond=weights(17) - scal14=weights(18) - wsccor=weights(21) - endif - time_Bcast=time_Bcast+MPI_Wtime()-time00 - time_Bcastw=time_Bcastw+MPI_Wtime()-time00 -c call chainbuild_cart - endif -c print *,'Processor',myrank,' calling etotal ipot=',ipot -c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct -#else -c if (modecalc.eq.12.or.modecalc.eq.14) then -c call int_from_cart1(.false.) -c endif -#endif -#ifdef TIMING - time00=MPI_Wtime() -#endif -C -C Compute the side-chain and electrostatic interaction energy -C - goto (101,102,103,104,105,106) ipot -C Lennard-Jones potential. - 101 call elj(evdw) -cd print '(a)','Exit ELJ' - goto 107 -C Lennard-Jones-Kihara potential (shifted). - 102 call eljk(evdw) - goto 107 -C Berne-Pechukas potential (dilated LJ, angular dependence). - 103 call ebp(evdw) - goto 107 -C Gay-Berne potential (shifted LJ, angular dependence). - 104 call egb(evdw) - goto 107 -C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence). - 105 call egbv(evdw) - goto 107 -C Soft-sphere potential - 106 call e_softsphere(evdw) -C -C Calculate electrostatic (H-bonding) energy of the main chain. -C - 107 continue -c print *,"Processor",myrank," computed USCSC" -#ifdef TIMING - time01=MPI_Wtime() -#endif - call vec_and_deriv -#ifdef TIMING - time_vec=time_vec+MPI_Wtime()-time01 -#endif -c print *,"Processor",myrank," left VEC_AND_DERIV" - if (ipot.lt.6) then -#ifdef SPLITELE - if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#else - if (welec.gt.0d0.or.wel_loc.gt.0d0.or. - & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 - & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 - & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then -#endif - call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4) - else - ees=0.0d0 - evdw1=0.0d0 - eel_loc=0.0d0 - eello_turn3=0.0d0 - eello_turn4=0.0d0 - endif - else -c write (iout,*) "Soft-spheer ELEC potential" - call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3, - & eello_turn4) - endif -c print *,"Processor",myrank," computed UELEC" -C -C Calculate excluded-volume interaction energy between peptide groups -C and side chains. -C - if (ipot.lt.6) then - if(wscp.gt.0d0) then - call escp(evdw2,evdw2_14) - else - evdw2=0 - evdw2_14=0 - endif - else -c write (iout,*) "Soft-sphere SCP potential" - call escp_soft_sphere(evdw2,evdw2_14) - endif -c -c Calculate the bond-stretching energy -c - call ebond(estr) -C -C Calculate the disulfide-bridge and other energy and the contributions -C from other distance constraints. -cd print *,'Calling EHPB' - call edis(ehpb) -cd print *,'EHPB exitted succesfully.' -C -C Calculate the virtual-bond-angle energy. -C - if (wang.gt.0d0) then - call ebend(ebe) - else - ebe=0 - endif -c print *,"Processor",myrank," computed UB" -C -C Calculate the SC local energy. -C - call esc(escloc) -c print *,"Processor",myrank," computed USC" -C -C Calculate the virtual-bond torsional energy. -C -cd print *,'nterm=',nterm - if (wtor.gt.0) then - call etor(etors,edihcnstr) - else - etors=0 - edihcnstr=0 - endif -c print *,"Processor",myrank," computed Utor" -C -C 6/23/01 Calculate double-torsional energy -C - if (wtor_d.gt.0) then - call etor_d(etors_d) - else - etors_d=0 - endif -c print *,"Processor",myrank," computed Utord" -C -C 21/5/07 Calculate local sicdechain correlation energy -C - if (wsccor.gt.0.0d0) then - call eback_sc_corr(esccor) - else - esccor=0.0d0 - endif -c print *,"Processor",myrank," computed Usccorr" -C -C 12/1/95 Multi-body terms -C - n_corr=0 - n_corr1=0 - if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 - & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then - call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1) -cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1, -cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 - else - ecorr=0.0d0 - ecorr5=0.0d0 - ecorr6=0.0d0 - eturn6=0.0d0 - endif - if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then - call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -cd write (iout,*) "multibody_hb ecorr",ecorr - endif -c print *,"Processor",myrank," computed Ucorr" -C -C If performing constraint dynamics, call the constraint energy -C after the equilibration time - if(usampl.and.totT.gt.eq_time) then - call EconstrQ - call Econstr_back - else - Uconst=0.0d0 - Uconst_back=0.0d0 - endif -#ifdef TIMING - time_enecalc=time_enecalc+MPI_Wtime()-time00 -#endif -c print *,"Processor",myrank," computed Uconstr" -#ifdef TIMING - time00=MPI_Wtime() -#endif -c -C Sum the energies -C - energia(1)=evdw -#ifdef SCP14 - energia(2)=evdw2-evdw2_14 - energia(18)=evdw2_14 -#else - energia(2)=evdw2 - energia(18)=0.0d0 -#endif -#ifdef SPLITELE - energia(3)=ees - energia(16)=evdw1 -#else - energia(3)=ees+evdw1 - energia(16)=0.0d0 -#endif - energia(4)=ecorr - energia(5)=ecorr5 - energia(6)=ecorr6 - energia(7)=eel_loc - energia(8)=eello_turn3 - energia(9)=eello_turn4 - energia(10)=eturn6 - energia(11)=ebe - energia(12)=escloc - energia(13)=etors - energia(14)=etors_d - energia(15)=ehpb - energia(19)=edihcnstr - energia(17)=estr - energia(20)=Uconst+Uconst_back - energia(21)=esccor -c print *," Processor",myrank," calls SUM_ENERGY" - call sum_energy(energia,.true.) -c print *," Processor",myrank," left SUM_ENERGY" -#ifdef TIMING - time_sumene=time_sumene+MPI_Wtime()-time00 -#endif - return - end -c------------------------------------------------------------------------------- - subroutine sum_energy(energia,reduce) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include "mpif.h" -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energia(0:n_ene),enebuff(0:n_ene+1) - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' - logical reduce -#ifdef MPI - if (nfgtasks.gt.1 .and. reduce) then -#ifdef DEBUG - write (iout,*) "energies before REDUCE" - call enerprint(energia) - call flush(iout) -#endif - do i=0,n_ene - enebuff(i)=energia(i) - enddo - time00=MPI_Wtime() - call MPI_Barrier(FG_COMM,IERR) - time_barrier_e=time_barrier_e+MPI_Wtime()-time00 - time00=MPI_Wtime() - call MPI_Reduce(enebuff(0),energia(0),n_ene+1, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) -#ifdef DEBUG - write (iout,*) "energies after REDUCE" - call enerprint(energia) - call flush(iout) -#endif - time_Reduce=time_Reduce+MPI_Wtime()-time00 - endif - if (fg_rank.eq.0) then -#endif - evdw=energia(1) -#ifdef SCP14 - evdw2=energia(2)+energia(18) - evdw2_14=energia(18) -#else - evdw2=energia(2) -#endif -#ifdef SPLITELE - ees=energia(3) - evdw1=energia(16) -#else - ees=energia(3) - evdw1=0.0d0 -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eturn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -#ifdef SPLITELE - etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor -#else - etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) - & +wang*ebe+wtor*etors+wscloc*escloc - & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 - & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 - & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d - & +wbond*estr+Uconst+wsccor*esccor -#endif - energia(0)=etot -c detecting NaNQ -#ifdef ISNAN -#ifdef AIX - if (isnan(etot).ne.0) energia(0)=1.0d+99 -#else - if (isnan(etot)) energia(0)=1.0d+99 -#endif -#else - i=0 -#ifdef WINPGI - idumm=proc_proc(etot,i) -#else - call proc_proc(etot,i) -#endif - if(i.eq.1)energia(0)=1.0d+99 -#endif -#ifdef MPI - endif -#endif - return - end -c------------------------------------------------------------------------------- - subroutine sum_gradient - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifndef ISNAN - external proc_proc -#ifdef WINPGI -cMS$ATTRIBUTES C :: proc_proc -#endif -#endif -#ifdef MPI - include 'mpif.h' - double precision gradbufc(3,maxres),gradbufx(3,maxres), - & glocbuf(4*maxres),gradbufc_sum(3,maxres) -#endif - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.TIME1' - include 'COMMON.MAXGRAD' -#ifdef TIMING - time01=MPI_Wtime() -#endif -#ifdef DEBUG - write (iout,*) "sum_gradient gvdwc, gvdwx" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef MPI -C FG slaves call the following matching MPI_Bcast in ERGASTULUM - if (nfgtasks.gt.1 .and. fg_rank.eq.0) - & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR) -#endif -C -C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient -C in virtual-bond-vector coordinates -C -#ifdef DEBUG -c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc" -c do i=1,nres-1 -c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)') -c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i) -c enddo -c write (iout,*) "gel_loc_tur3 gel_loc_turn4" -c do i=1,nres-1 -c write (iout,'(i5,3f10.5,2x,f10.5)') -c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i) -c enddo - write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc" - do i=1,nres - write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3), - & g_corr5_loc(i) - enddo - call flush(iout) -#endif -#ifdef SPLITELE - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i) - enddo - enddo -#else - do i=1,nct - do j=1,3 - gradbufc(j,i)=wsc*gvdwc(j,i)+ - & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ - & welec*gelc_long(j,i)+ - & wbond*gradb(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i)+ - & wstrain*ghpbc(j,i) - enddo - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - time00=MPI_Wtime() -#ifdef DEBUG - write (iout,*) "gradbufc before allreduce" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - do i=1,nres - do j=1,3 - gradbufc_sum(j,i)=gradbufc(j,i) - enddo - enddo -c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres, -c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR) -c time_reduce=time_reduce+MPI_Wtime()-time00 -#ifdef DEBUG -c write (iout,*) "gradbufc_sum after allreduce" -c do i=1,nres -c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3) -c enddo -c call flush(iout) -#endif -#ifdef TIMING -c time_allreduce=time_allreduce+MPI_Wtime()-time00 -#endif - do i=nnt,nres - do k=1,3 - gradbufc(k,i)=0.0d0 - enddo - enddo -#ifdef DEBUG - write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end - write (iout,*) (i," jgrad_start",jgrad_start(i), - & " jgrad_end ",jgrad_end(i), - & i=igrad_start,igrad_end) -#endif -c -c Obsolete and inefficient code; we can make the effort O(n) and, therefore, -c do not parallelize this part. -c -c do i=igrad_start,igrad_end -c do j=jgrad_start(i),jgrad_end(i) -c do k=1,3 -c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j) -c enddo -c enddo -c enddo - do j=1,3 - gradbufc(j,nres-1)=gradbufc_sum(j,nres) - enddo - do i=nres-2,nnt,-1 - do j=1,3 - gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) - enddo - enddo -#ifdef DEBUG - write (iout,*) "gradbufc after summing" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - else -#endif -#ifdef DEBUG - write (iout,*) "gradbufc" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif - do i=1,nres - do j=1,3 - gradbufc_sum(j,i)=gradbufc(j,i) - gradbufc(j,i)=0.0d0 - enddo - enddo - do j=1,3 - gradbufc(j,nres-1)=gradbufc_sum(j,nres) - enddo - do i=nres-2,nnt,-1 - do j=1,3 - gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1) - enddo - enddo -c do i=nnt,nres-1 -c do k=1,3 -c gradbufc(k,i)=0.0d0 -c enddo -c do j=i+1,nres -c do k=1,3 -c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j) -c enddo -c enddo -c enddo -#ifdef DEBUG - write (iout,*) "gradbufc after summing" - do i=1,nres - write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3) - enddo - call flush(iout) -#endif -#ifdef MPI - endif -#endif - do k=1,3 - gradbufc(k,nres)=0.0d0 - enddo - do i=1,nct - do j=1,3 -#ifdef SPLITELE - gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ - & wel_loc*gel_loc(j,i)+ - & 0.5d0*(wscp*gvdwc_scpp(j,i)+ - & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gradcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i))+ - & wbond*gradb(j,i)+ - & wcorr*gradcorr(j,i)+ - & wturn3*gcorr3_turn(j,i)+ - & wturn4*gcorr4_turn(j,i)+ - & wcorr5*gradcorr5(j,i)+ - & wcorr6*gradcorr6(j,i)+ - & wturn6*gcorr6_turn(j,i)+ - & wsccor*gsccorc(j,i) - & +wscloc*gscloc(j,i) -#else - gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ - & wel_loc*gel_loc(j,i)+ - & 0.5d0*(wscp*gvdwc_scpp(j,i)+ - & welec*gelc_long(j,i) - & wel_loc*gel_loc_long(j,i)+ - & wcorr*gcorr_long(j,i)+ - & wcorr5*gradcorr5_long(j,i)+ - & wcorr6*gradcorr6_long(j,i)+ - & wturn6*gcorr6_turn_long(j,i))+ - & wbond*gradb(j,i)+ - & wcorr*gradcorr(j,i)+ - & wturn3*gcorr3_turn(j,i)+ - & wturn4*gcorr4_turn(j,i)+ - & wcorr5*gradcorr5(j,i)+ - & wcorr6*gradcorr6(j,i)+ - & wturn6*gcorr6_turn(j,i)+ - & wsccor*gsccorc(j,i) - & +wscloc*gscloc(j,i) -#endif - gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ - & wbond*gradbx(j,i)+ - & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ - & wsccor*gsccorx(j,i) - & +wscloc*gsclocx(j,i) - enddo - enddo -#ifdef DEBUG - write (iout,*) "gloc before adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - do i=1,nres-3 - gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) - & +wcorr5*g_corr5_loc(i) - & +wcorr6*g_corr6_loc(i) - & +wturn4*gel_loc_turn4(i) - & +wturn3*gel_loc_turn3(i) - & +wturn6*gel_loc_turn6(i) - & +wel_loc*gel_loc_loc(i) - & +wsccor*gsccor_loc(i) - enddo -#ifdef DEBUG - write (iout,*) "gloc after adding corr" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif -#ifdef MPI - if (nfgtasks.gt.1) then - do j=1,3 - do i=1,nres - gradbufc(j,i)=gradc(j,i,icg) - gradbufx(j,i)=gradx(j,i,icg) - enddo - enddo - do i=1,4*nres - glocbuf(i)=gloc(i,icg) - enddo - time00=MPI_Wtime() - call MPI_Barrier(FG_COMM,IERR) - time_barrier_g=time_barrier_g+MPI_Wtime()-time00 - time00=MPI_Wtime() - call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres, - & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR) - time_reduce=time_reduce+MPI_Wtime()-time00 -#ifdef DEBUG - write (iout,*) "gloc after reduce" - do i=1,4*nres - write (iout,*) i,gloc(i,icg) - enddo -#endif - endif -#endif - if (gnorm_check) then -c -c Compute the maximum elements of the gradient -c - gvdwc_max=0.0d0 - gvdwc_scp_max=0.0d0 - gelc_max=0.0d0 - gvdwpp_max=0.0d0 - gradb_max=0.0d0 - ghpbc_max=0.0d0 - gradcorr_max=0.0d0 - gel_loc_max=0.0d0 - gcorr3_turn_max=0.0d0 - gcorr4_turn_max=0.0d0 - gradcorr5_max=0.0d0 - gradcorr6_max=0.0d0 - gcorr6_turn_max=0.0d0 - gsccorc_max=0.0d0 - gscloc_max=0.0d0 - gvdwx_max=0.0d0 - gradx_scp_max=0.0d0 - ghpbx_max=0.0d0 - gradxorr_max=0.0d0 - gsccorx_max=0.0d0 - gsclocx_max=0.0d0 - do i=1,nct - gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i))) - if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm - gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i))) - if (gvdwc_scp_norm.gt.gvdwc_scp_max) - & gvdwc_scp_max=gvdwc_scp_norm - gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i))) - if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm - gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i))) - if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm - gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i))) - if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm - ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i))) - if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm - gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i))) - if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm - gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i))) - if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm - gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i), - & gcorr3_turn(1,i))) - if (gcorr3_turn_norm.gt.gcorr3_turn_max) - & gcorr3_turn_max=gcorr3_turn_norm - gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i), - & gcorr4_turn(1,i))) - if (gcorr4_turn_norm.gt.gcorr4_turn_max) - & gcorr4_turn_max=gcorr4_turn_norm - gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i))) - if (gradcorr5_norm.gt.gradcorr5_max) - & gradcorr5_max=gradcorr5_norm - gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i))) - if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm - gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i), - & gcorr6_turn(1,i))) - if (gcorr6_turn_norm.gt.gcorr6_turn_max) - & gcorr6_turn_max=gcorr6_turn_norm - gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i))) - if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm - gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i))) - if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm - gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i))) - if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm - gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i))) - if (gradx_scp_norm.gt.gradx_scp_max) - & gradx_scp_max=gradx_scp_norm - ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i))) - if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm - gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i))) - if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm - gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i))) - if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm - gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i))) - if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm - enddo - if (gradout) then -#ifdef AIX - open(istat,file=statname,position="append") -#else - open(istat,file=statname,access="append") -#endif - write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max, - & gelc_max,gvdwpp_max,gradb_max,ghpbc_max, - & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max, - & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max, - & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max, - & gsccorx_max,gsclocx_max - close(istat) - if (gvdwc_max.gt.1.0d4) then - write (iout,*) "gvdwc gvdwx gradb gradbx" - do i=nnt,nct - write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i), - & gradb(j,i),gradbx(j,i),j=1,3) - enddo - call pdbout(0.0d0,'cipiszcze',iout) - call flush(iout) - endif - endif - endif -#ifdef DEBUG - write (iout,*) "gradc gradx gloc" - do i=1,nres - write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') - & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg) - enddo -#endif -#ifdef TIMING - time_sumgradient=time_sumgradient+MPI_Wtime()-time01 -#endif - return - end -c------------------------------------------------------------------------------- - subroutine rescale_weights(t_bath) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - double precision kfac /2.4d0/ - double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/ -c facT=temp0/t_bath -c facT=2*temp0/(t_bath+temp0) - if (rescale_mode.eq.0) then - facT=1.0d0 - facT2=1.0d0 - facT3=1.0d0 - facT4=1.0d0 - facT5=1.0d0 - else if (rescale_mode.eq.1) then - facT=kfac/(kfac-1.0d0+t_bath/temp0) - facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2) - facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3) - facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4) - facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5) - else if (rescale_mode.eq.2) then - x=t_bath/temp0 - x2=x*x - x3=x2*x - x4=x3*x - x5=x4*x - facT=licznik/dlog(dexp(x)+dexp(-x)) - facT2=licznik/dlog(dexp(x2)+dexp(-x2)) - facT3=licznik/dlog(dexp(x3)+dexp(-x3)) - facT4=licznik/dlog(dexp(x4)+dexp(-x4)) - facT5=licznik/dlog(dexp(x5)+dexp(-x5)) - else - write (iout,*) "Wrong RESCALE_MODE",rescale_mode - write (*,*) "Wrong RESCALE_MODE",rescale_mode -#ifdef MPI - call MPI_Finalize(MPI_COMM_WORLD,IERROR) -#endif - stop 555 - endif - welec=weights(3)*fact - wcorr=weights(4)*fact3 - wcorr5=weights(5)*fact4 - wcorr6=weights(6)*fact5 - wel_loc=weights(7)*fact2 - wturn3=weights(8)*fact2 - wturn4=weights(9)*fact3 - wturn6=weights(10)*fact5 - wtor=weights(13)*fact - wtor_d=weights(14)*fact2 - wsccor=weights(21)*fact - - return - end -C------------------------------------------------------------------------ - subroutine enerprint(energia) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.SBRIDGE' - include 'COMMON.MD' - double precision energia(0:n_ene) - etot=energia(0) - evdw=energia(1) - evdw2=energia(2) -#ifdef SCP14 - evdw2=energia(2)+energia(18) -#else - evdw2=energia(2) -#endif - ees=energia(3) -#ifdef SPLITELE - evdw1=energia(16) -#endif - ecorr=energia(4) - ecorr5=energia(5) - ecorr6=energia(6) - eel_loc=energia(7) - eello_turn3=energia(8) - eello_turn4=energia(9) - eello_turn6=energia(10) - ebe=energia(11) - escloc=energia(12) - etors=energia(13) - etors_d=energia(14) - ehpb=energia(15) - edihcnstr=energia(19) - estr=energia(17) - Uconst=energia(20) - esccor=energia(21) -#ifdef SPLITELE - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor, - & edihcnstr,ebr*nss, - & Uconst,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST= ',1pE16.6,' (Constraint energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#else - write (iout,10) evdw,wsc,evdw2,wscp,ees,welec, - & estr,wbond,ebe,wang, - & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain, - & ecorr,wcorr, - & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3, - & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr, - & ebr*nss,Uconst,etot - 10 format (/'Virtual-chain energies:'// - & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ - & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ - & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ - & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ - & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ - & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ - & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ - & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ - & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6, - & ' (SS bridges & dist. cnstr.)'/ - & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ - & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ - & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ - & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ - & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ - & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ - & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ - & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ - & 'UCONST=',1pE16.6,' (Constraint energy)'/ - & 'ETOT= ',1pE16.6,' (total)') -#endif - return - end -C----------------------------------------------------------------------- - subroutine elj(evdw) -C -C This subroutine calculates the interaction energy of nonbonded side chains -C assuming the LJ potential of interaction. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - parameter (accur=1.0d-10) - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.TORSION' - include 'COMMON.SBRIDGE' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.CONTACTS' - dimension gg(3) -c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon - evdw=0.0D0 - do i=iatsc_s,iatsc_e - itypi=itype(i) - if (itypi.eq.21) cycle - itypi1=itype(i+1) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) -C Change 12/1/95 - num_conti=0 -C -C Calculate SC interaction energy. -C - do iint=1,nint_gr(i) -cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint), -cd & 'iend=',iend(i,iint) - do j=istart(i,iint),iend(i,iint) - itypj=itype(j) - if (itypj.eq.21) cycle - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi -C Change 12/1/95 to calculate four-body interactions - rij=xj*xj+yj*yj+zj*zj - rrij=1.0D0/rij -c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj - eps0ij=eps(itypi,itypj) - fac=rrij**expon2 - e1=fac*fac*aa(itypi,itypj) - e2=fac*bb(itypi,itypj) - evdwij=e1+e2 -cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0) -cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj) -cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)') -cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), -cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, -cd & (c(k,i),k=1,3),(c(k,j),k=1,3) - evdw=evdw+evdwij -C -C Calculate the components of the gradient in DC and X -C - fac=-rrij*(e1+evdwij) - gg(1)=xj*fac - gg(2)=yj*fac - gg(3)=zj*fac - do k=1,3 - gvdwx(k,i)=gvdwx(k,i)-gg(k) - gvdwx(k,j)=gvdwx(k,j)+gg(k) - gvdwc(k,i)=gvdwc(k,i)-gg(k) - gvdwc(k,j)=gvdwc(k,j)+gg(k) - enddo -cgrad do k=i,j-1 -cgrad do l=1,3 -cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l) -cgrad enddo -cgrad enddo -C -C 12/1/95, revised on 5/20/97 -C -C Calculate the contact function. The ith column of the array JCONT will -C contain the numbers of atoms that make contacts with the atom I (of numbers -C greater than I). The arrays FACONT and GACONT will contain the values of -C the contact function and its derivative. -C -C Uncomment next line, if the correlation interactions include EVDW explicitly. -c if (j.gt.i+1 .and. evdwij.le.0.0D0) then -C Uncomment next line, if the correlation interactions are contact function only - if (j.gt.i+1.and. eps0ij.gt.0.0D0) then - rij=dsqrt(rij) - sigij=sigma(itypi,itypj) - r0ij=rs0(itypi,itypj) -C -C Check whether the SC's are not too far to make a contact. -C - rcut=1.5d0*r0ij - call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont) -C Add a new contact, if the SC's are close enough, but not too close (ri' -cgrad do k=1,3 -cgrad ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -cgrad enddo -cgrad endif -cgrad do k=1,3 -cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -cgrad enddo -cgrad kstart=min0(i+1,j) -cgrad kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) -cgrad do k=kstart,kend -cgrad do l=1,3 -cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - return - end -C----------------------------------------------------------------------------- - subroutine escp(evdw2,evdw2_14) -C -C This subroutine calculates the excluded-volume interaction energy between -C peptide-group centers and side chains and its gradient in virtual-bond and -C side-chain vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.LOCAL' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.CONTROL' - dimension ggg(3) - evdw2=0.0D0 - evdw2_14=0.0d0 -cd print '(a)','Enter ESCP' -cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e - do i=iatscp_s,iatscp_e - if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle - iteli=itel(i) - xi=0.5D0*(c(1,i)+c(1,i+1)) - yi=0.5D0*(c(2,i)+c(2,i+1)) - zi=0.5D0*(c(3,i)+c(3,i+1)) - - do iint=1,nscp_gr(i) - - do j=iscpstart(i,iint),iscpend(i,iint) - itypj=itype(j) - if (itypj.eq.21) cycle -C Uncomment following three lines for SC-p interactions -c xj=c(1,nres+j)-xi -c yj=c(2,nres+j)-yi -c zj=c(3,nres+j)-zi -C Uncomment following three lines for Ca-p interactions - xj=c(1,j)-xi - yj=c(2,j)-yi - zj=c(3,j)-zi - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - fac=rrij**expon2 - e1=fac*fac*aad(itypj,iteli) - e2=fac*bad(itypj,iteli) - if (iabs(j-i) .le. 2) then - e1=scal14*e1 - e2=scal14*e2 - evdw2_14=evdw2_14+e1+e2 - endif - evdwij=e1+e2 - evdw2=evdw2+evdwij - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'evdw2',i,j,evdwij -C -C Calculate contributions to the gradient in the virtual-bond and SC vectors. -C - fac=-(evdwij+e1)*rrij - ggg(1)=xj*fac - ggg(2)=yj*fac - ggg(3)=zj*fac -cgrad if (j.lt.i) then -cd write (iout,*) 'ji' -cgrad do k=1,3 -cgrad ggg(k)=-ggg(k) -C Uncomment following line for SC-p interactions -ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k) -c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k) -cgrad enddo -cgrad endif -cgrad do k=1,3 -cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k) -cgrad enddo -cgrad kstart=min0(i+1,j) -cgrad kend=max0(i-1,j-1) -cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend -cd write (iout,*) ggg(1),ggg(2),ggg(3) -cgrad do k=kstart,kend -cgrad do l=1,3 -cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l) -cgrad enddo -cgrad enddo - do k=1,3 - gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k) - gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k) - enddo - enddo - - enddo ! iint - enddo ! i - do i=1,nct - do j=1,3 - gvdwc_scp(j,i)=expon*gvdwc_scp(j,i) - gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i) - gradx_scp(j,i)=expon*gradx_scp(j,i) - enddo - enddo -C****************************************************************************** -C -C N O T E !!! -C -C To save time the factor EXPON has been extracted from ALL components -C of GVDWC and GRADX. Remember to multiply them by this factor before further -C use! -C -C****************************************************************************** - return - end -C-------------------------------------------------------------------------- - subroutine edis(ehpb) -C -C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - dimension ggg(3) - ehpb=0.0D0 -cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr -cd write(iout,*)'link_start=',link_start,' link_end=',link_end - if (link_end.eq.0) return - do i=link_start,link_end -C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a -C CA-CA distance used in regularization of structure. - ii=ihpb(i) - jj=jhpb(i) -C iii and jjj point to the residues for which the distance is assigned. - if (ii.gt.nres) then - iii=ii-nres - jjj=jj-nres - else - iii=ii - jjj=jj - endif -cd write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj -C 24/11/03 AL: SS bridges handled separately because of introducing a specific -C distance and angle dependent SS bond potential. - if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then - call ssbond_ene(iii,jjj,eij) - ehpb=ehpb+2*eij -cd write (iout,*) "eij",eij - else -C Calculate the distance between the two points and its difference from the -C target distance. - dd=dist(ii,jj) - rdis=dd-dhpb(i) -C Get the force constant corresponding to this distance. - waga=forcon(i) -C Calculate the contribution to energy. - ehpb=ehpb+waga*rdis*rdis -C -C Evaluate gradient. -C - fac=waga*rdis/dd -cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd, -cd & ' waga=',waga,' fac=',fac - do j=1,3 - ggg(j)=fac*(c(j,jj)-c(j,ii)) - enddo -cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3) -C If this is a SC-SC distance, we need to calculate the contributions to the -C Cartesian gradient in the SC vectors (ghpbx). - if (iii.lt.ii) then - do j=1,3 - ghpbx(j,iii)=ghpbx(j,iii)-ggg(j) - ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j) - enddo - endif -cgrad do j=iii,jjj-1 -cgrad do k=1,3 -cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k) -cgrad enddo -cgrad enddo - do k=1,3 - ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k) - ghpbc(k,iii)=ghpbc(k,iii)-ggg(k) - enddo - endif - enddo - ehpb=0.5D0*ehpb - return - end -C-------------------------------------------------------------------------- - subroutine ssbond_ene(i,j,eij) -C -C Calculate the distance and angle dependent SS-bond potential energy -C using a free-energy function derived based on RHF/6-31G** ab initio -C calculations of diethyl disulfide. -C -C A. Liwo and U. Kozlowska, 11/24/03 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.VAR' - include 'COMMON.IOUNITS' - double precision erij(3),dcosom1(3),dcosom2(3),gg(3) - itypi=itype(i) - xi=c(1,nres+i) - yi=c(2,nres+i) - zi=c(3,nres+i) - dxi=dc_norm(1,nres+i) - dyi=dc_norm(2,nres+i) - dzi=dc_norm(3,nres+i) -c dsci_inv=dsc_inv(itypi) - dsci_inv=vbld_inv(nres+i) - itypj=itype(j) -c dscj_inv=dsc_inv(itypj) - dscj_inv=vbld_inv(nres+j) - xj=c(1,nres+j)-xi - yj=c(2,nres+j)-yi - zj=c(3,nres+j)-zi - dxj=dc_norm(1,nres+j) - dyj=dc_norm(2,nres+j) - dzj=dc_norm(3,nres+j) - rrij=1.0D0/(xj*xj+yj*yj+zj*zj) - rij=dsqrt(rrij) - erij(1)=xj*rij - erij(2)=yj*rij - erij(3)=zj*rij - om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3) - om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3) - om12=dxi*dxj+dyi*dyj+dzi*dzj - do k=1,3 - dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k)) - dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k)) - enddo - rij=1.0d0/rij - deltad=rij-d0cm - deltat1=1.0d0-om1 - deltat2=1.0d0+om2 - deltat12=om2-om1+2.0d0 - cosphi=om12-om1*om2 - eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) - & +akct*deltad*deltat12 - & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr -c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, -c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2, -c & " deltat12",deltat12," eij",eij - ed=2*akcm*deltad+akct*deltat12 - pom1=akct*deltad - pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi - eom1=-2*akth*deltat1-pom1-om2*pom2 - eom2= 2*akth*deltat2+pom1-om1*pom2 - eom12=pom2 - do k=1,3 - ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k) - ghpbx(k,i)=ghpbx(k,i)-ggk - & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) - & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv - ghpbx(k,j)=ghpbx(k,j)+ggk - & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) - & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv - ghpbc(k,i)=ghpbc(k,i)-ggk - ghpbc(k,j)=ghpbc(k,j)+ggk - enddo -C -C Calculate the components of the gradient in DC and X -C -cgrad do k=i,j-1 -cgrad do l=1,3 -cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l) -cgrad enddo -cgrad enddo - return - end -C-------------------------------------------------------------------------- - subroutine ebond(estr) -c -c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - include 'COMMON.SETUP' - double precision u(3),ud(3) - estr=0.0d0 - estr1=0.0d0 - do i=ibondp_start,ibondp_end - if (itype(i-1).eq.21 .or. itype(i).eq.21) then - estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax) - do j=1,3 - gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) - & *dc(j,i-1)/vbld(i) - enddo - if (energy_dec) write(iout,*) - & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax) - else - diff = vbld(i)-vbldp0 - if (energy_dec) write (iout,*) - & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff - estr=estr+diff*diff - do j=1,3 - gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i) - enddo -c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3) - endif - enddo - estr=0.5d0*AKP*estr+estr1 -c -c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included -c - do i=ibond_start,ibond_end - iti=itype(i) - if (iti.ne.10 .and. iti.ne.21) then - nbi=nbondterm(iti) - if (nbi.eq.1) then - diff=vbld(i+nres)-vbldsc0(1,iti) - if (energy_dec) write (iout,*) - & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff, - & AKSC(1,iti),AKSC(1,iti)*diff*diff - estr=estr+0.5d0*AKSC(1,iti)*diff*diff - do j=1,3 - gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres) - enddo - else - do j=1,nbi - diff=vbld(i+nres)-vbldsc0(j,iti) - ud(j)=aksc(j,iti)*diff - u(j)=abond0(j,iti)+0.5d0*ud(j)*diff - enddo - uprod=u(1) - do j=2,nbi - uprod=uprod*u(j) - enddo - usum=0.0d0 - usumsqder=0.0d0 - do j=1,nbi - uprod1=1.0d0 - uprod2=1.0d0 - do k=1,nbi - if (k.ne.j) then - uprod1=uprod1*u(k) - uprod2=uprod2*u(k)*u(k) - endif - enddo - usum=usum+uprod1 - usumsqder=usumsqder+ud(j)*uprod2 - enddo - estr=estr+uprod/usum - do j=1,3 - gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres) - enddo - endif - endif - enddo - return - end -#ifdef CRYST_THETA -C-------------------------------------------------------------------------- - subroutine ebend(etheta) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - double precision y(2),z(2) - delta=0.02d0*pi -c time11=dexp(-2*time) -c time12=1.0d0 - etheta=0.0D0 -c write (*,'(a,i2)') 'EBEND ICG=',icg - do i=ithet_start,ithet_end - if (itype(i-1).eq.21) cycle -C Zero the energy function and its derivative at 0 or pi. - call splinthet(theta(i),0.5d0*delta,ss,ssd) - it=itype(i-1) - if (i.gt.3 .and. itype(i-2).ne.21) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - y(1)=dcos(phii) - y(2)=dsin(phii) - else - y(1)=0.0D0 - y(2)=0.0D0 - endif - if (i.lt.nres .and. itype(i).ne.21) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) - z(1)=cos(phii1) -#else - phii1=phi(i+1) - z(1)=dcos(phii1) -#endif - z(2)=dsin(phii1) - else - z(1)=0.0D0 - z(2)=0.0D0 - endif -C Calculate the "mean" value of theta from the part of the distribution -C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2). -C In following comments this theta will be referred to as t_c. - thet_pred_mean=0.0d0 - do k=1,2 - athetk=athet(k,it) - bthetk=bthet(k,it) - thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k) - enddo - dthett=thet_pred_mean*ssd - thet_pred_mean=thet_pred_mean*ss+a0thet(it) -C Derivatives of the "mean" values in gamma1 and gamma2. - dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss - dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss - if (theta(i).gt.pi-delta) then - call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0, - & E_tc0) - call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0) - call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai, - & E_theta) - call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else if (theta(i).lt.delta) then - call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0) - call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1) - call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai, - & E_theta) - call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0) - call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0, - & E_tc) - else - call theteng(theta(i),thet_pred_mean,theta0(it),ethetai, - & E_theta,E_tc) - endif - etheta=etheta+ethetai - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'ebend',i,ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1 - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2 - gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett) - enddo -C Ufff.... We've done all this!!! - return - end -C--------------------------------------------------------------------------- - subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta, - & E_tc) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it -C Calculate the contributions to both Gaussian lobes. -C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time) -C The "polynomial part" of the "standard deviation" of this part of -C the distribution. - sig=polthet(3,it) - do j=2,0,-1 - sig=sig*thet_pred_mean+polthet(j,it) - enddo -C Derivative of the "interior part" of the "standard deviation of the" -C gamma-dependent Gaussian lobe in t_c. - sigtc=3*polthet(3,it) - do j=2,1,-1 - sigtc=sigtc*thet_pred_mean+j*polthet(j,it) - enddo - sigtc=sig*sigtc -C Set the parameters of both Gaussian lobes of the distribution. -C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc) - fac=sig*sig+sigc0(it) - sigcsq=fac+fac - sigc=1.0D0/sigcsq -C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c - sigsqtc=-4.0D0*sigcsq*sigtc -c print *,i,sig,sigtc,sigsqtc -C Following variable (sigtc) is d[sigma(t_c)]/dt_c - sigtc=-sigtc/(fac*fac) -C Following variable is sigma(t_c)**(-2) - sigcsq=sigcsq*sigcsq - sig0i=sig0(it) - sig0inv=1.0D0/sig0i**2 - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i - term1=-0.5D0*sigcsq*delthec*delthec - term2=-0.5D0*sig0inv*delthe0*delthe0 -C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and -C NaNs in taking the logarithm. We extract the largest exponent which is added -C to the energy (this being the log of the distribution) at the end of energy -C term evaluation for this virtual-bond angle. - if (term1.gt.term2) then - termm=term1 - term2=dexp(term2-termm) - term1=1.0d0 - else - termm=term2 - term1=dexp(term1-termm) - term2=1.0d0 - endif -C The ratio between the gamma-independent and gamma-dependent lobes of -C the distribution is a Gaussian function of thet_pred_mean too. - diffak=gthet(2,it)-thet_pred_mean - ratak=diffak/gthet(3,it)**2 - ak=dexp(gthet(1,it)-0.5D0*diffak*ratak) -C Let's differentiate it in thet_pred_mean NOW. - aktc=ak*ratak -C Now put together the distribution terms to make complete distribution. - termexp=term1+ak*term2 - termpre=sigc+ak*sig0i -C Contribution of the bending energy from this theta is just the -log of -C the sum of the contributions from the two lobes and the pre-exponential -C factor. Simple enough, isn't it? - ethetai=(-dlog(termexp)-termm+dlog(termpre)) -C NOW the derivatives!!! -C 6/6/97 Take into account the deformation. - E_theta=(delthec*sigcsq*term1 - & +ak*delthe0*sig0inv*term2)/termexp - E_tc=((sigtc+aktc*sig0i)/termpre - & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ - & aktc*term2)/termexp) - return - end -c----------------------------------------------------------------------------- - subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /calcthet/ term1,term2,termm,diffak,ratak, - & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq, - & delthe0,sig0inv,sigtc,sigsqtc,delthec,it - delthec=thetai-thet_pred_mean - delthe0=thetai-theta0i -C "Thank you" to MAPLE (probably spared one day of hand-differentiation). - t3 = thetai-thet_pred_mean - t6 = t3**2 - t9 = term1 - t12 = t3*sigcsq - t14 = t12+t6*sigsqtc - t16 = 1.0d0 - t21 = thetai-theta0i - t23 = t21**2 - t26 = term2 - t27 = t21*t26 - t32 = termexp - t40 = t32**2 - E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 - & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 - & *(-t12*t9-ak*sig0inv*t27) - return - end -#else -C-------------------------------------------------------------------------- - subroutine ebend(etheta) -C -C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral -C angles gamma and its derivatives in consecutive thetas and gammas. -C ab initio-derived potentials from -c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.LOCAL' - include 'COMMON.GEO' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - double precision coskt(mmaxtheterm),sinkt(mmaxtheterm), - & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle), - & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble), - & sinph1ph2(maxdouble,maxdouble) - logical lprn /.false./, lprn1 /.false./ - etheta=0.0D0 - do i=ithet_start,ithet_end - if (itype(i-1).eq.21) cycle - dethetai=0.0d0 - dephii=0.0d0 - dephii1=0.0d0 - theti2=0.5d0*theta(i) - ityp2=ithetyp(itype(i-1)) - do k=1,nntheterm - coskt(k)=dcos(k*theti2) - sinkt(k)=dsin(k*theti2) - enddo - if (i.gt.3 .and. itype(i-2).ne.21) then -#ifdef OSF - phii=phi(i) - if (phii.ne.phii) phii=150.0 -#else - phii=phi(i) -#endif - ityp1=ithetyp(itype(i-2)) - do k=1,nsingle - cosph1(k)=dcos(k*phii) - sinph1(k)=dsin(k*phii) - enddo - else - phii=0.0d0 - ityp1=nthetyp+1 - do k=1,nsingle - cosph1(k)=0.0d0 - sinph1(k)=0.0d0 - enddo - endif - if (i.lt.nres .and. itype(i).ne.21) then -#ifdef OSF - phii1=phi(i+1) - if (phii1.ne.phii1) phii1=150.0 - phii1=pinorm(phii1) -#else - phii1=phi(i+1) -#endif - ityp3=ithetyp(itype(i)) - do k=1,nsingle - cosph2(k)=dcos(k*phii1) - sinph2(k)=dsin(k*phii1) - enddo - else - phii1=0.0d0 - ityp3=nthetyp+1 - do k=1,nsingle - cosph2(k)=0.0d0 - sinph2(k)=0.0d0 - enddo - endif - ethetai=aa0thet(ityp1,ityp2,ityp3) - do k=1,ndouble - do l=1,k-1 - ccl=cosph1(l)*cosph2(k-l) - ssl=sinph1(l)*sinph2(k-l) - scl=sinph1(l)*cosph2(k-l) - csl=cosph1(l)*sinph2(k-l) - cosph1ph2(l,k)=ccl-ssl - cosph1ph2(k,l)=ccl+ssl - sinph1ph2(l,k)=scl+csl - sinph1ph2(k,l)=scl-csl - enddo - enddo - if (lprn) then - write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2, - & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1 - write (iout,*) "coskt and sinkt" - do k=1,nntheterm - write (iout,*) k,coskt(k),sinkt(k) - enddo - endif - do k=1,ntheterm - ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k) - dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3) - & *coskt(k) - if (lprn) - & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3), - & " ethetai",ethetai - enddo - if (lprn) then - write (iout,*) "cosph and sinph" - do k=1,nsingle - write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k) - enddo - write (iout,*) "cosph1ph2 and sinph2ph2" - do k=2,ndouble - do l=1,k-1 - write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l), - & sinph1ph2(l,k),sinph1ph2(k,l) - enddo - enddo - write(iout,*) "ethetai",ethetai - endif - do m=1,ntheterm2 - do k=1,nsingle - aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k) - & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k) - & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k) - & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*aux*coskt(m) - dephii=dephii+k*sinkt(m)*( - & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)- - & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)) - dephii1=dephii1+k*sinkt(m)*( - & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)- - & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k)) - if (lprn) - & write (iout,*) "m",m," k",k," bbthet", - & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet", - & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet", - & ddthet(k,m,ityp1,ityp2,ityp3)," eethet", - & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai - enddo - enddo - if (lprn) - & write(iout,*) "ethetai",ethetai - do m=1,ntheterm3 - do k=2,ndouble - do l=1,k-1 - aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l) - ethetai=ethetai+sinkt(m)*aux - dethetai=dethetai+0.5d0*m*coskt(m)*aux - dephii=dephii+l*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)- - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+ - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - dephii1=dephii1+(k-l)*sinkt(m)*( - & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+ - & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+ - & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)- - & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)) - if (lprn) then - write (iout,*) "m",m," k",k," l",l," ffthet", - & ffthet(l,k,m,ityp1,ityp2,ityp3), - & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet", - & ggthet(l,k,m,ityp1,ityp2,ityp3), - & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai - write (iout,*) cosph1ph2(l,k)*sinkt(m), - & cosph1ph2(k,l)*sinkt(m), - & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m) - endif - enddo - enddo - enddo -10 continue - if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') - & i,theta(i)*rad2deg,phii*rad2deg, - & phii1*rad2deg,ethetai - etheta=etheta+ethetai - if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii - if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1 - gloc(nphi+i-2,icg)=wang*dethetai - enddo - return - end -#endif -#ifdef CRYST_SC -c----------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3), - & ddersc0(3),ddummy(3),xtemp(3),temp(3) - common /sccalc/ time11,time12,time112,theti,it,nlobit - delta=0.02d0*pi - escloc=0.0D0 -c write (iout,'(a)') 'ESC' - do i=loc_start,loc_end - it=itype(i) - if (it.eq.21) cycle - if (it.eq.10) goto 1 - nlobit=nlob(it) -c print *,'i=',i,' it=',it,' nlobit=',nlobit -c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad - theti=theta(i+1)-pipol - x(1)=dtan(theti) - x(2)=alph(i) - x(3)=omeg(i) - - if (x(2).gt.pi-delta) then - xtemp(1)=x(1) - xtemp(2)=pi-delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=pi - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=pi-delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=pi - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - call splinthet(x(2),0.5d0*delta,ss,ssd) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c escloci=esclocbi -c write (iout,*) escloci - else if (x(2).lt.delta) then - xtemp(1)=x(1) - xtemp(2)=delta - xtemp(3)=x(3) - call enesc(xtemp,escloci0,dersc0,ddersc0,.true.) - xtemp(2)=0.0d0 - call enesc(xtemp,escloci1,dersc1,ddummy,.false.) - call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2), - & escloci,dersc(2)) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & ddersc0(1),dersc(1)) - call spline2(x(2),delta,-delta,dersc0(3),dersc1(3), - & ddersc0(3),dersc(3)) - xtemp(2)=delta - call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.) - xtemp(2)=0.0d0 - call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.) - call spline1(x(2),delta,-delta,esclocbi0,esclocbi1, - & dersc0(2),esclocbi,dersc02) - call spline2(x(2),delta,-delta,dersc0(1),dersc1(1), - & dersc12,dersc01) - dersc0(1)=dersc01 - dersc0(2)=dersc02 - dersc0(3)=0.0d0 - call splinthet(x(2),0.5d0*delta,ss,ssd) - do k=1,3 - dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k) - enddo - dersc(2)=dersc(2)+ssd*(escloci-esclocbi) -c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci, -c & esclocbi,ss,ssd - escloci=ss*escloci+(1.0d0-ss)*esclocbi -c write (iout,*) escloci - else - call enesc(x,escloci,dersc,ddummy,.false.) - endif - - escloc=escloc+escloci - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'escloc',i,escloci -c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc - - gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ - & wscloc*dersc(1) - gloc(ialph(i,1),icg)=wscloc*dersc(2) - gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3) - 1 continue - enddo - return - end -C--------------------------------------------------------------------------- - subroutine enesc(x,escloci,dersc,ddersc,mixed) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /sccalc/ time11,time12,time112,theti,it,nlobit - double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3) - double precision contr(maxlob,-1:1) - logical mixed -c write (iout,*) 'it=',it,' nlobit=',nlobit - escloc_i=0.0D0 - do j=1,3 - dersc(j)=0.0D0 - if (mixed) ddersc(j)=0.0d0 - enddo - x3=x(3) - -C Because of periodicity of the dependence of the SC energy in omega we have -C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi). -C To avoid underflows, first compute & store the exponents. - - do iii=-1,1 - - x(3)=x3+iii*dwapi - - do j=1,nlobit - do k=1,3 - z(k)=x(k)-censc(k,j,it) - enddo - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j,iii)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j,iii)*z(k) - enddo - contr(j,iii)=expfac - enddo ! j - - enddo ! iii - - x(3)=x3 -C As in the case of ebend, we want to avoid underflows in exponentiation and -C subsequent NaNs and INFs in energy calculation. -C Find the largest exponent - emin=contr(1,-1) - do iii=-1,1 - do j=1,nlobit - if (emin.gt.contr(j,iii)) emin=contr(j,iii) - enddo - enddo - emin=0.5D0*emin -cd print *,'it=',it,' emin=',emin - -C Compute the contribution to SC energy and derivatives - do iii=-1,1 - - do j=1,nlobit -#ifdef OSF - adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin - if(adexp.ne.adexp) adexp=1.0 - expfac=dexp(adexp) -#else - expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin) -#endif -cd print *,'j=',j,' expfac=',expfac - escloc_i=escloc_i+expfac - do k=1,3 - dersc(k)=dersc(k)+Ax(k,j,iii)*expfac - enddo - if (mixed) then - do k=1,3,2 - ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) - & +gaussc(k,2,j,it))*expfac - enddo - endif - enddo - - enddo ! iii - - dersc(1)=dersc(1)/cos(theti)**2 - ddersc(1)=ddersc(1)/cos(theti)**2 - ddersc(3)=ddersc(3) - - escloci=-(dlog(escloc_i)-emin) - do j=1,3 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) then - do j=1,3,2 - ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j)) - enddo - endif - return - end -C------------------------------------------------------------------------------ - subroutine enesc_bound(x,escloci,dersc,dersc12,mixed) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.IOUNITS' - common /sccalc/ time11,time12,time112,theti,it,nlobit - double precision x(3),z(3),Ax(3,maxlob),dersc(3) - double precision contr(maxlob) - logical mixed - - escloc_i=0.0D0 - - do j=1,3 - dersc(j)=0.0D0 - enddo - - do j=1,nlobit - do k=1,2 - z(k)=x(k)-censc(k,j,it) - enddo - z(3)=dwapi - do k=1,3 - Axk=0.0D0 - do l=1,3 - Axk=Axk+gaussc(l,k,j,it)*z(l) - enddo - Ax(k,j)=Axk - enddo - expfac=0.0D0 - do k=1,3 - expfac=expfac+Ax(k,j)*z(k) - enddo - contr(j)=expfac - enddo ! j - -C As in the case of ebend, we want to avoid underflows in exponentiation and -C subsequent NaNs and INFs in energy calculation. -C Find the largest exponent - emin=contr(1) - do j=1,nlobit - if (emin.gt.contr(j)) emin=contr(j) - enddo - emin=0.5D0*emin - -C Compute the contribution to SC energy and derivatives - - dersc12=0.0d0 - do j=1,nlobit - expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin) - escloc_i=escloc_i+expfac - do k=1,2 - dersc(k)=dersc(k)+Ax(k,j)*expfac - enddo - if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) - & +gaussc(1,2,j,it))*expfac - dersc(3)=0.0d0 - enddo - - dersc(1)=dersc(1)/cos(theti)**2 - dersc12=dersc12/cos(theti)**2 - escloci=-(dlog(escloc_i)-emin) - do j=1,2 - dersc(j)=dersc(j)/escloc_i - enddo - if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1)) - return - end -#else -c---------------------------------------------------------------------------------- - subroutine esc(escloc) -C Calculate the local energy of a side chain and its derivatives in the -C corresponding virtual-bond valence angles THETA and the spherical angles -C ALPHA and OMEGA derived from AM1 all-atom calculations. -C added by Urszula Kozlowska. 07/11/2007 -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.VAR' - include 'COMMON.SCROT' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - include 'COMMON.VECTORS' - double precision x_prime(3),y_prime(3),z_prime(3) - & , sumene,dsc_i,dp2_i,x(65), - & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6, - & de_dxx,de_dyy,de_dzz,de_dt - double precision s1_t,s1_6_t,s2_t,s2_6_t - double precision - & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3), - & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3), - & dt_dCi(3),dt_dCi1(3) - common /sccalc/ time11,time12,time112,theti,it,nlobit - delta=0.02d0*pi - escloc=0.0D0 - do i=loc_start,loc_end - if (itype(i).eq.21) cycle - costtab(i+1) =dcos(theta(i+1)) - sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1)) - cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1))) - sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1))) - cosfac2=0.5d0/(1.0d0+costtab(i+1)) - cosfac=dsqrt(cosfac2) - sinfac2=0.5d0/(1.0d0-costtab(i+1)) - sinfac=dsqrt(sinfac2) - it=itype(i) - if (it.eq.10) goto 1 -c -C Compute the axes of tghe local cartesian coordinates system; store in -c x_prime, y_prime and z_prime -c - do j=1,3 - x_prime(j) = 0.00 - y_prime(j) = 0.00 - z_prime(j) = 0.00 - enddo -C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres), -C & dc_norm(3,i+nres) - do j = 1,3 - x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac - y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac - enddo - do j = 1,3 - z_prime(j) = -uz(j,i-1) - enddo -c write (2,*) "i",i -c write (2,*) "x_prime",(x_prime(j),j=1,3) -c write (2,*) "y_prime",(y_prime(j),j=1,3) -c write (2,*) "z_prime",(z_prime(j),j=1,3) -c write (2,*) "xx",scalar(x_prime(1),x_prime(1)), -c & " xy",scalar(x_prime(1),y_prime(1)), -c & " xz",scalar(x_prime(1),z_prime(1)), -c & " yy",scalar(y_prime(1),y_prime(1)), -c & " yz",scalar(y_prime(1),z_prime(1)), -c & " zz",scalar(z_prime(1),z_prime(1)) -c -C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i), -C to local coordinate system. Store in xx, yy, zz. -c - xx=0.0d0 - yy=0.0d0 - zz=0.0d0 - do j = 1,3 - xx = xx + x_prime(j)*dc_norm(j,i+nres) - yy = yy + y_prime(j)*dc_norm(j,i+nres) - zz = zz + z_prime(j)*dc_norm(j,i+nres) - enddo - - xxtab(i)=xx - yytab(i)=yy - zztab(i)=zz -C -C Compute the energy of the ith side cbain -C -c write (2,*) "xx",xx," yy",yy," zz",zz - it=itype(i) - do j = 1,65 - x(j) = sc_parmin(j,it) - enddo -#ifdef CHECK_COORD -Cc diagnostics - remove later - xx1 = dcos(alph(2)) - yy1 = dsin(alph(2))*dcos(omeg(2)) - zz1 = -dsin(alph(2))*dsin(omeg(2)) - write(2,'(3f8.1,3f9.3,1x,3f9.3)') - & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz, - & xx1,yy1,zz1 -C," --- ", xx_w,yy_w,zz_w -c end diagnostics -#endif - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)+yy*sint2tab(i+1))) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2tab(i+1)-yy*sint2tab(i+1))) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) - & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6) -c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3, -c & sumene4, -c & dscp1,dscp2,sumene -c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - escloc = escloc + sumene -c write (2,*) "i",i," escloc",sumene,escloc -#ifdef DEBUG -C -C This section to check the numerical derivatives of the energy of ith side -C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert -C #define DEBUG in the code to turn it on. -C - write (2,*) "sumene =",sumene - aincr=1.0d-7 - xxsave=xx - xx=xx+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dxx_num=(sumenep-sumene)/aincr - xx=xxsave - write (2,*) "xx+ sumene from enesc=",sumenep - yysave=yy - yy=yy+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dyy_num=(sumenep-sumene)/aincr - yy=yysave - write (2,*) "yy+ sumene from enesc=",sumenep - zzsave=zz - zz=zz+aincr - write (2,*) xx,yy,zz - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dzz_num=(sumenep-sumene)/aincr - zz=zzsave - write (2,*) "zz+ sumene from enesc=",sumenep - costsave=cost2tab(i+1) - sintsave=sint2tab(i+1) - cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr)) - sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr)) - sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1)) - de_dt_num=(sumenep-sumene)/aincr - write (2,*) " t+ sumene from enesc=",sumenep - cost2tab(i+1)=costsave - sint2tab(i+1)=sintsave -C End of diagnostics section. -#endif -C -C Compute the gradient of esc -C - pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2 - pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2 - pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2 - pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2 - pom_dx=dsc_i*dp2_i*cost2tab(i+1) - pom_dy=dsc_i*dp2_i*sint2tab(i+1) - pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1)) - pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1)) - pom1=(sumene3*sint2tab(i+1)+sumene1) - & *(pom_s1/dscp1+pom_s16*dscp1**4) - pom2=(sumene4*cost2tab(i+1)+sumene2) - & *(pom_s2/dscp2+pom_s26*dscp2**4) - sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy - sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 - & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) - & +x(40)*yy*zz - sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy - sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 - & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) - & +x(60)*yy*zz - de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) - & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) - & +(pom1+pom2)*pom_dx -#ifdef DEBUG - write(2,*), "de_dxx = ", de_dxx,de_dxx_num -#endif -C - sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz - sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 - & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) - & +x(40)*xx*zz - sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz - sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz - & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz - & +x(59)*zz**2 +x(60)*xx*zz - de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) - & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) - & +(pom1-pom2)*pom_dy -#ifdef DEBUG - write(2,*), "de_dyy = ", de_dyy,de_dyy_num -#endif -C - de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy - & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx - & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) - & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6) - & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2 - & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy - & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) - & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6) -#ifdef DEBUG - write(2,*), "de_dzz = ", de_dzz,de_dzz_num -#endif -C - de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) - & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) - & +pom1*pom_dt1+pom2*pom_dt2 -#ifdef DEBUG - write(2,*), "de_dt = ", de_dt,de_dt_num -#endif -c -C - cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres)) - cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres)) - cosfac2xx=cosfac2*xx - sinfac2yy=sinfac2*yy - do k = 1,3 - dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* - & vbld_inv(i+1) - dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* - & vbld_inv(i) - pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1) - pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i) -c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1, -c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k) -c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3), -c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i) - dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx - dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx - dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy - dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy - dZZ_Ci1(k)=0.0d0 - dZZ_Ci(k)=0.0d0 - do j=1,3 - dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres) - dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres) - enddo - - dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres)) - dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres)) - dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres)) -c - dt_dCi(k) = -dt_dCi(k)/sinttab(i+1) - dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1) - enddo - - do k=1,3 - dXX_Ctab(k,i)=dXX_Ci(k) - dXX_C1tab(k,i)=dXX_Ci1(k) - dYY_Ctab(k,i)=dYY_Ci(k) - dYY_C1tab(k,i)=dYY_Ci1(k) - dZZ_Ctab(k,i)=dZZ_Ci(k) - dZZ_C1tab(k,i)=dZZ_Ci1(k) - dXX_XYZtab(k,i)=dXX_XYZ(k) - dYY_XYZtab(k,i)=dYY_XYZ(k) - dZZ_XYZtab(k,i)=dZZ_XYZ(k) - enddo - - do k = 1,3 -c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1", -c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k) -c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci", -c & dyy_ci(k)," dzz_ci",dzz_ci(k) -c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci", -c & dt_dci(k) -c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ", -c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k) - gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) - & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k) - gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) - & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k) - gsclocx(k,i)= de_dxx*dxx_XYZ(k) - & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k) - enddo -c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3), -c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3) - -C to check gradient call subroutine check_grad - - 1 continue - enddo - return - end -c------------------------------------------------------------------------------ - double precision function enesc(x,xx,yy,zz,cost2,sint2) - implicit none - double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2, - & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6 - sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2 - & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy - & + x(10)*yy*zz - sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 - & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy - & + x(20)*yy*zz - sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 - & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy - & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 - & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx - & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy - & +x(40)*xx*yy*zz - sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 - & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy - & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 - & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx - & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy - & +x(60)*xx*yy*zz - dsc_i = 0.743d0+x(61) - dp2_i = 1.9d0+x(62) - dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2+yy*sint2)) - dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i - & *(xx*cost2-yy*sint2)) - s1=(1+x(63))/(0.1d0 + dscp1) - s1_6=(1+x(64))/(0.1d0 + dscp1**6) - s2=(1+x(65))/(0.1d0 + dscp2) - s2_6=(1+x(65))/(0.1d0 + dscp2**6) - sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) - & + (sumene4*cost2 +sumene2)*(s2+s2_6) - enesc=sumene - return - end -#endif -c------------------------------------------------------------------------------ - subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont) -C -C This procedure calculates two-body contact function g(rij) and its derivative: -C -C eps0ij ! x < -1 -C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1 -C 0 ! x > 1 -C -C where x=(rij-r0ij)/delta -C -C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy -C - implicit none - double precision rij,r0ij,eps0ij,fcont,fprimcont - double precision x,x2,x4,delta -c delta=0.02D0*r0ij -c delta=0.2D0*r0ij - x=(rij-r0ij)/delta - if (x.lt.-1.0D0) then - fcont=eps0ij - fprimcont=0.0D0 - else if (x.le.1.0D0) then - x2=x*x - x4=x2*x2 - fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0) - fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta - else - fcont=0.0D0 - fprimcont=0.0D0 - endif - return - end -c------------------------------------------------------------------------------ - subroutine splinthet(theti,delta,ss,ssder) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - thetup=pi-delta - thetlow=delta - if (theti.gt.pipol) then - call gcont(theti,thetup,1.0d0,delta,ss,ssder) - else - call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder) - ssder=-ssder - endif - return - end -c------------------------------------------------------------------------------ - subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim) - implicit none - double precision x,x0,delta,f0,f1,fprim0,f,fprim - double precision ksi,ksi2,ksi3,a1,a2,a3 - a1=fprim0*delta/(f1-f0) - a2=3.0d0-2.0d0*a1 - a3=a1-2.0d0 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi)) - fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3)) - return - end -c------------------------------------------------------------------------------ - subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx) - implicit none - double precision x,x0,delta,f0x,f1x,fprim0x,fx - double precision ksi,ksi2,ksi3,a1,a2,a3 - ksi=(x-x0)/delta - ksi2=ksi*ksi - ksi3=ksi2*ksi - a1=fprim0x*delta - a2=3*(f1x-f0x)-2*fprim0x*delta - a3=fprim0x*delta-2*(f1x-f0x) - fx=f0x+a1*ksi+a2*ksi2+a3*ksi3 - return - end -C----------------------------------------------------------------------------- -#ifdef CRYST_TOR -C----------------------------------------------------------------------------- - subroutine etor(etors,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - etors_ii=0.0D0 - if (itype(i-2).eq.21 .or. itype(i-1).eq.21 - & .or. itype(i).eq.21) cycle - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -C Proline-Proline pair is a special case... - if (itori.eq.3 .and. itori1.eq.3) then - if (phii.gt.-dwapi3) then - cosphi=dcos(3*phii) - fac=1.0D0/(1.0D0-cosphi) - etorsi=v1(1,3,3)*fac - etorsi=etorsi+etorsi - etors=etors+etorsi-v1(1,3,3) - if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3) - gloci=gloci-3*fac*etorsi*dsin(3*phii) - endif - do j=1,3 - v1ij=v1(j+1,itori,itori1) - v2ij=v2(j+1,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ - & v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - else - do j=1,nterm_old - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - if (energy_dec) etors_ii=etors_ii+ - & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij) - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - endif - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - 'etor',i,etors_ii - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci -c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 - do i=1,ndih_constr - itori=idih_constr(i) - phii=phi(itori) - difi=phii-phi0(i) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - endif -! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii, -! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -! write (iout,*) 'edihcnstr',edihcnstr - return - end -c------------------------------------------------------------------------------ - subroutine etor_d(etors_d) - etors_d=0.0d0 - return - end -c---------------------------------------------------------------------------- -#else - subroutine etor(etors,edihcnstr) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors=0.0D0 - do i=iphi_start,iphi_end - if (itype(i-2).eq.21 .or. itype(i-1).eq.21 - & .or. itype(i).eq.21) cycle - etors_ii=0.0D0 - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - phii=phi(i) - gloci=0.0D0 -C Regular cosine and sine terms - do j=1,nterm(itori,itori1) - v1ij=v1(j,itori,itori1) - v2ij=v2(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - etors=etors+v1ij*cosphi+v2ij*sinphi - if (energy_dec) etors_ii=etors_ii+ - & v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo -C Lorentz terms -C v1 -C E = SUM ----------------------------------- - v1 -C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1 -C - cosphi=dcos(0.5d0*phii) - sinphi=dsin(0.5d0*phii) - do j=1,nlor(itori,itori1) - vl1ij=vlor1(j,itori,itori1) - vl2ij=vlor2(j,itori,itori1) - vl3ij=vlor3(j,itori,itori1) - pom=vl2ij*cosphi+vl3ij*sinphi - pom1=1.0d0/(pom*pom+1.0d0) - etors=etors+vl1ij*pom1 - if (energy_dec) etors_ii=etors_ii+ - & vl1ij*pom1 - pom=-pom*pom1*pom1 - gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom - enddo -C Subtract the constant term - etors=etors-v0(itori,itori1) - if (energy_dec) write (iout,'(a6,i5,0pf7.3)') - & 'etor',i,etors_ii-v0(itori,itori1) - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6) - gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci -c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg) - enddo -! 6/20/98 - dihedral angle constraints - edihcnstr=0.0d0 -c do i=1,ndih_constr - do i=idihconstr_start,idihconstr_end - itori=idih_constr(i) - phii=phi(itori) - difi=pinorm(phii-phi0(i)) - if (difi.gt.drange(i)) then - difi=difi-drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else if (difi.lt.-drange(i)) then - difi=difi+drange(i) - edihcnstr=edihcnstr+0.25d0*ftors*difi**4 - gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3 - else - difi=0.0 - endif -cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii, -cd & rad2deg*phi0(i), rad2deg*drange(i), -cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg) - enddo -cd write (iout,*) 'edihcnstr',edihcnstr - return - end -c---------------------------------------------------------------------------- - subroutine etor_d(etors_d) -C 6/23/01 Compute double torsional energy - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.TORCNSTR' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. - etors_d=0.0D0 - do i=iphid_start,iphid_end - if (itype(i-2).eq.21 .or. itype(i-1).eq.21 - & .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle - itori=itortyp(itype(i-2)) - itori1=itortyp(itype(i-1)) - itori2=itortyp(itype(i)) - phii=phi(i) - phii1=phi(i+1) - gloci1=0.0D0 - gloci2=0.0D0 -C Regular cosine and sine terms - do j=1,ntermd_1(itori,itori1,itori2) - v1cij=v1c(1,j,itori,itori1,itori2) - v1sij=v1s(1,j,itori,itori1,itori2) - v2cij=v1c(2,j,itori,itori1,itori2) - v2sij=v1s(2,j,itori,itori1,itori2) - cosphi1=dcos(j*phii) - sinphi1=dsin(j*phii) - cosphi2=dcos(j*phii1) - sinphi2=dsin(j*phii1) - etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ - & v2cij*cosphi2+v2sij*sinphi2 - gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1) - gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2) - enddo - do k=2,ntermd_2(itori,itori1,itori2) - do l=1,k-1 - v1cdij = v2c(k,l,itori,itori1,itori2) - v2cdij = v2c(l,k,itori,itori1,itori2) - v1sdij = v2s(k,l,itori,itori1,itori2) - v2sdij = v2s(l,k,itori,itori1,itori2) - cosphi1p2=dcos(l*phii+(k-l)*phii1) - cosphi1m2=dcos(l*phii-(k-l)*phii1) - sinphi1p2=dsin(l*phii+(k-l)*phii1) - sinphi1m2=dsin(l*phii-(k-l)*phii1) - etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ - & v1sdij*sinphi1p2+v2sdij*sinphi1m2 - gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 - & -v1cdij*sinphi1p2-v2cdij*sinphi1m2) - gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 - & -v1cdij*sinphi1p2+v2cdij*sinphi1m2) - enddo - enddo - gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1 - gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2 - enddo - return - end -#endif -c------------------------------------------------------------------------------ - subroutine eback_sc_corr(esccor) -c 7/21/2007 Correlations between the backbone-local and side-chain-local -c conformational states; temporarily implemented as differences -c between UNRES torsional potentials (dependent on three types of -c residues) and the torsional potentials dependent on all 20 types -c of residues computed from AM1 energy surfaces of terminally-blocked -c amino-acid residues. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.TORSION' - include 'COMMON.SCCOR' - include 'COMMON.INTERACT' - include 'COMMON.DERIV' - include 'COMMON.CHAIN' - include 'COMMON.NAMES' - include 'COMMON.IOUNITS' - include 'COMMON.FFIELD' - include 'COMMON.CONTROL' - logical lprn -C Set lprn=.true. for debugging - lprn=.false. -c lprn=.true. -c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor - esccor=0.0D0 - do i=iphi_start,iphi_end - if (itype(i-2).eq.21 .or. itype(i-1).eq.21) cycle - esccor_ii=0.0D0 - itori=itype(i-2) - itori1=itype(i-1) - phii=phi(i) - gloci=0.0D0 - do j=1,nterm_sccor - v1ij=v1sccor(j,itori,itori1) - v2ij=v2sccor(j,itori,itori1) - cosphi=dcos(j*phii) - sinphi=dsin(j*phii) - esccor=esccor+v1ij*cosphi+v2ij*sinphi - gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi) - enddo - if (lprn) - & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') - & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1, - & (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6) - gsccor_loc(i-3)=gsccor_loc(i-3)+gloci - enddo - return - end -c---------------------------------------------------------------------------- - subroutine multibody(ecorr) -C This subroutine calculates multi-body contributions to energy following -C the idea of Skolnick et al. If side chains I and J make a contact and -C at the same time side chains I+1 and J+1 make a contact, an extra -C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - -C Set lprn=.true. for debugging - lprn=.false. - - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(i2,20(1x,i2,f10.5))') - & i,(jcont(j,i),facont(j,i),j=1,num_cont(i)) - enddo - endif - ecorr=0.0D0 - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo - do i=nnt,nct-2 - - DO ISHIFT = 3,4 - - i1=i+ishift - num_conti=num_cont(i) - num_conti1=num_cont(i1) - do jj=1,num_conti - j=jcont(jj,i) - do kk=1,num_conti1 - j1=jcont(kk,i1) - if (j1.eq.j+ishift .or. j1.eq.j-ishift) then -cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1, -cd & ' ishift=',ishift -C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk) - endif ! j1==j+-ishift - enddo ! kk - enddo ! jj - - ENDDO ! ISHIFT - - enddo ! i - return - end -c------------------------------------------------------------------------------ - double precision function esccorr(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont(jj,i) - ekl=facont(kk,k) -cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl -C Calculate the multi-body contribution to energy. -C Calculate multi-body contributions to the gradient. -cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3), -cd & k,l,(gacont(m,kk,k),m=1,3) - do m=1,3 - gx(m) =ekl*gacont(m,jj,i) - gx1(m)=eij*gacont(m,kk,k) - gradxorr(m,i)=gradxorr(m,i)-gx(m) - gradxorr(m,j)=gradxorr(m,j)+gx(m) - gradxorr(m,k)=gradxorr(m,k)-gx1(m) - gradxorr(m,l)=gradxorr(m,l)+gx1(m) - enddo - do m=i,j-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx(ll) - enddo - enddo - do m=k,l-1 - do ll=1,3 - gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll) - enddo - enddo - esccorr=-eij*ekl - return - end -c------------------------------------------------------------------------------ - subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) -C This subroutine calculates multi-body contributions to hydrogen-bonding - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPI - include "mpif.h" - parameter (max_cont=maxconts) - parameter (max_dim=26) - integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer status(MPI_STATUS_SIZE),req(maxconts*2), - & status_array(MPI_STATUS_SIZE,maxconts*2) -#endif - include 'COMMON.SETUP' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.CONTROL' - include 'COMMON.LOCAL' - double precision gx(3),gx1(3),time00 - logical lprn,ldone - -C Set lprn=.true. for debugging - lprn=.false. -#ifdef MPI - n_corr=0 - n_corr1=0 - if (nfgtasks.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values before RECEIVE:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", -c & ntask_cont_to -C Make the list of contacts to send to send to other procesors -c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end -c call flush(iout) - do i=iturn3_start,iturn3_end -c write (iout,*) "make contact list turn3",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact(i,i+2,iturn3_sent_local(1,i)) - enddo - do i=iturn4_start,iturn4_end -c write (iout,*) "make contact list turn4",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact(i,i+3,iturn4_sent_local(1,i)) - enddo - do ii=1,nat_sent - i=iat_sent(ii) -c write (iout,*) "make contact list longrange",i,ii," num_cont", -c & num_cont_hb(i) - do j=1,num_cont_hb(i) - do k=1,4 - jjc=jcont_hb(j,i) - iproc=iint_sent_local(k,jjc,ii) -c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc - if (iproc.gt.0) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=i - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=facont_hb(j,i) - zapas(4,nn,iproc)=ees0p(j,i) - zapas(5,nn,iproc)=ees0m(j,i) - zapas(6,nn,iproc)=gacont_hbr(1,j,i) - zapas(7,nn,iproc)=gacont_hbr(2,j,i) - zapas(8,nn,iproc)=gacont_hbr(3,j,i) - zapas(9,nn,iproc)=gacontm_hb1(1,j,i) - zapas(10,nn,iproc)=gacontm_hb1(2,j,i) - zapas(11,nn,iproc)=gacontm_hb1(3,j,i) - zapas(12,nn,iproc)=gacontp_hb1(1,j,i) - zapas(13,nn,iproc)=gacontp_hb1(2,j,i) - zapas(14,nn,iproc)=gacontp_hb1(3,j,i) - zapas(15,nn,iproc)=gacontm_hb2(1,j,i) - zapas(16,nn,iproc)=gacontm_hb2(2,j,i) - zapas(17,nn,iproc)=gacontm_hb2(3,j,i) - zapas(18,nn,iproc)=gacontp_hb2(1,j,i) - zapas(19,nn,iproc)=gacontp_hb2(2,j,i) - zapas(20,nn,iproc)=gacontp_hb2(3,j,i) - zapas(21,nn,iproc)=gacontm_hb3(1,j,i) - zapas(22,nn,iproc)=gacontm_hb3(2,j,i) - zapas(23,nn,iproc)=gacontm_hb3(3,j,i) - zapas(24,nn,iproc)=gacontp_hb3(1,j,i) - zapas(25,nn,iproc)=gacontp_hb3(2,j,i) - zapas(26,nn,iproc)=gacontp_hb3(3,j,i) - endif - enddo - enddo - enddo - if (lprn) then - write (iout,*) - & "Numbers of contacts to be sent to other processors", - & (ncont_sent(i),i=1,ntask_cont_to) - write (iout,*) "Contacts sent" - do ii=1,ntask_cont_to - nn=ncont_sent(ii) - iproc=itask_cont_to(ii) - write (iout,*) nn," contacts to processor",iproc, - & " of CONT_TO_COMM group" - do i=1,nn - write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) - enddo - enddo - call flush(iout) - endif - CorrelType=477 - CorrelID=fg_rank+1 - CorrelType1=478 - CorrelID1=nfgtasks+fg_rank+1 - ireq=0 -C Receive the numbers of needed contacts from other processors - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - ireq=ireq+1 - call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "IRECV ended" -c call flush(iout) -C Send the number of contacts needed by other processors - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - ireq=ireq+1 - call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "ISEND ended" -c write (iout,*) "number of requests (nn)",ireq - call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) -c write (iout,*) -c & "Numbers of contacts to be received from other processors", -c & (ncont_recv(i),i=1,ntask_cont_from) -c call flush(iout) -C Receive contacts - ireq=0 - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - nn=ncont_recv(ii) -c write (iout,*) "Receiving",nn," contacts from processor",iproc, -c & " of CONT_TO_COMM group" - call flush(iout) - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, - & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) - endif - enddo -C Send the contacts to processors that need them - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - nn=ncont_sent(ii) -c write (iout,*) nn," contacts to processor",iproc, -c & " of CONT_TO_COMM group" - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, - & iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) -c do i=1,nn -c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) -c enddo - endif - enddo -c write (iout,*) "number of requests (contacts)",ireq -c write (iout,*) "req",(req(i),i=1,4) -c call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) - do iii=1,ntask_cont_from - iproc=itask_cont_from(iii) - nn=ncont_recv(iii) - if (lprn) then - write (iout,*) "Received",nn," contacts from processor",iproc, - & " of CONT_FROM_COMM group" - call flush(iout) - do i=1,nn - write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5) - enddo - call flush(iout) - endif - do i=1,nn - ii=zapas_recv(1,i,iii) -c Flag the received contacts to prevent double-counting - jj=-zapas_recv(2,i,iii) -c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj -c call flush(iout) - nnn=num_cont_hb(ii)+1 - num_cont_hb(ii)=nnn - jcont_hb(nnn,ii)=jj - facont_hb(nnn,ii)=zapas_recv(3,i,iii) - ees0p(nnn,ii)=zapas_recv(4,i,iii) - ees0m(nnn,ii)=zapas_recv(5,i,iii) - gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii) - gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii) - gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii) - gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii) - gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii) - gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii) - gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii) - gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii) - gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii) - gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii) - gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii) - gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii) - gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii) - gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii) - gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii) - gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii) - gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii) - gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii) - gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii) - gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii) - gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii) - enddo - enddo - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 -C Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -C Calculate the local-electrostatic correlation terms - do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end) - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - jp=iabs(j) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) - jp1=iabs(j1) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 - & .or. j.lt.0 .and. j1.gt.0) .and. - & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then -C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -C The system gains extra energy. - ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0) - if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') - & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0) - n_corr=n_corr+1 - else if (j1.eq.j) then -C Contacts I-J and I-(J+1) occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0) - endif - enddo ! kk - do kk=1,num_conti - j1=jcont_hb(kk,i) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk - if (j1.eq.j+1) then -C Contacts I-J and (I+1)-J occur simultaneously. -C The system loses extra energy. -c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0) - endif ! j1==j+1 - enddo ! kk - enddo ! jj - enddo ! i - return - end -c------------------------------------------------------------------------------ - subroutine add_hb_contact(ii,jj,itask) - implicit real*8 (a-h,o-z) - include "DIMENSIONS" - include "COMMON.IOUNITS" - integer max_cont - integer max_dim - parameter (max_cont=maxconts) - parameter (max_dim=26) - include "COMMON.CONTACTS" - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer i,j,ii,jj,iproc,itask(4),nn -c write (iout,*) "itask",itask - do i=1,2 - iproc=itask(i) - if (iproc.gt.0) then - do j=1,num_cont_hb(ii) - jjc=jcont_hb(j,ii) -c write (iout,*) "i",ii," j",jj," jjc",jjc - if (jjc.eq.jj) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=ii - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=facont_hb(j,ii) - zapas(4,nn,iproc)=ees0p(j,ii) - zapas(5,nn,iproc)=ees0m(j,ii) - zapas(6,nn,iproc)=gacont_hbr(1,j,ii) - zapas(7,nn,iproc)=gacont_hbr(2,j,ii) - zapas(8,nn,iproc)=gacont_hbr(3,j,ii) - zapas(9,nn,iproc)=gacontm_hb1(1,j,ii) - zapas(10,nn,iproc)=gacontm_hb1(2,j,ii) - zapas(11,nn,iproc)=gacontm_hb1(3,j,ii) - zapas(12,nn,iproc)=gacontp_hb1(1,j,ii) - zapas(13,nn,iproc)=gacontp_hb1(2,j,ii) - zapas(14,nn,iproc)=gacontp_hb1(3,j,ii) - zapas(15,nn,iproc)=gacontm_hb2(1,j,ii) - zapas(16,nn,iproc)=gacontm_hb2(2,j,ii) - zapas(17,nn,iproc)=gacontm_hb2(3,j,ii) - zapas(18,nn,iproc)=gacontp_hb2(1,j,ii) - zapas(19,nn,iproc)=gacontp_hb2(2,j,ii) - zapas(20,nn,iproc)=gacontp_hb2(3,j,ii) - zapas(21,nn,iproc)=gacontm_hb3(1,j,ii) - zapas(22,nn,iproc)=gacontm_hb3(2,j,ii) - zapas(23,nn,iproc)=gacontm_hb3(3,j,ii) - zapas(24,nn,iproc)=gacontp_hb3(1,j,ii) - zapas(25,nn,iproc)=gacontp_hb3(2,j,ii) - zapas(26,nn,iproc)=gacontp_hb3(3,j,ii) - exit - endif - enddo - endif - enddo - return - end -c------------------------------------------------------------------------------ - subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr, - & n_corr1) -C This subroutine calculates multi-body contributions to hydrogen-bonding - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' -#ifdef MPI - include "mpif.h" - parameter (max_cont=maxconts) - parameter (max_dim=70) - integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer status(MPI_STATUS_SIZE),req(maxconts*2), - & status_array(MPI_STATUS_SIZE,maxconts*2) -#endif - include 'COMMON.SETUP' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.CHAIN' - include 'COMMON.CONTROL' - double precision gx(3),gx1(3) - integer num_cont_hb_old(maxres) - logical lprn,ldone - double precision eello4,eello5,eelo6,eello_turn6 - external eello4,eello5,eello6,eello_turn6 -C Set lprn=.true. for debugging - lprn=.false. - eturn6=0.0d0 -#ifdef MPI - do i=1,nres - num_cont_hb_old(i)=num_cont_hb(i) - enddo - n_corr=0 - n_corr1=0 - if (nfgtasks.le.1) goto 30 - if (lprn) then - write (iout,'(a)') 'Contact function values before RECEIVE:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,f5.2))') - & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), - & j=1,num_cont_hb(i)) - enddo - endif - call flush(iout) - do i=1,ntask_cont_from - ncont_recv(i)=0 - enddo - do i=1,ntask_cont_to - ncont_sent(i)=0 - enddo -c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to", -c & ntask_cont_to -C Make the list of contacts to send to send to other procesors - do i=iturn3_start,iturn3_end -c write (iout,*) "make contact list turn3",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i)) - enddo - do i=iturn4_start,iturn4_end -c write (iout,*) "make contact list turn4",i," num_cont", -c & num_cont_hb(i) - call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i)) - enddo - do ii=1,nat_sent - i=iat_sent(ii) -c write (iout,*) "make contact list longrange",i,ii," num_cont", -c & num_cont_hb(i) - do j=1,num_cont_hb(i) - do k=1,4 - jjc=jcont_hb(j,i) - iproc=iint_sent_local(k,jjc,ii) -c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc - if (iproc.ne.0) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=i - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=d_cont(j,i) - ind=3 - do kk=1,3 - ind=ind+1 - zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i) - enddo - enddo - enddo - enddo - endif - enddo - enddo - enddo - if (lprn) then - write (iout,*) - & "Numbers of contacts to be sent to other processors", - & (ncont_sent(i),i=1,ntask_cont_to) - write (iout,*) "Contacts sent" - do ii=1,ntask_cont_to - nn=ncont_sent(ii) - iproc=itask_cont_to(ii) - write (iout,*) nn," contacts to processor",iproc, - & " of CONT_TO_COMM group" - do i=1,nn - write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10) - enddo - enddo - call flush(iout) - endif - CorrelType=477 - CorrelID=fg_rank+1 - CorrelType1=478 - CorrelID1=nfgtasks+fg_rank+1 - ireq=0 -C Receive the numbers of needed contacts from other processors - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - ireq=ireq+1 - call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "IRECV ended" -c call flush(iout) -C Send the number of contacts needed by other processors - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - ireq=ireq+1 - call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType, - & FG_COMM,req(ireq),IERR) - enddo -c write (iout,*) "ISEND ended" -c write (iout,*) "number of requests (nn)",ireq - call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) -c write (iout,*) -c & "Numbers of contacts to be received from other processors", -c & (ncont_recv(i),i=1,ntask_cont_from) -c call flush(iout) -C Receive contacts - ireq=0 - do ii=1,ntask_cont_from - iproc=itask_cont_from(ii) - nn=ncont_recv(ii) -c write (iout,*) "Receiving",nn," contacts from processor",iproc, -c & " of CONT_TO_COMM group" - call flush(iout) - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim, - & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) - endif - enddo -C Send the contacts to processors that need them - do ii=1,ntask_cont_to - iproc=itask_cont_to(ii) - nn=ncont_sent(ii) -c write (iout,*) nn," contacts to processor",iproc, -c & " of CONT_TO_COMM group" - if (nn.gt.0) then - ireq=ireq+1 - call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION, - & iproc,CorrelType1,FG_COMM,req(ireq),IERR) -c write (iout,*) "ireq,req",ireq,req(ireq) -c do i=1,nn -c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5) -c enddo - endif - enddo -c write (iout,*) "number of requests (contacts)",ireq -c write (iout,*) "req",(req(i),i=1,4) -c call flush(iout) - if (ireq.gt.0) - & call MPI_Waitall(ireq,req,status_array,ierr) - do iii=1,ntask_cont_from - iproc=itask_cont_from(iii) - nn=ncont_recv(iii) - if (lprn) then - write (iout,*) "Received",nn," contacts from processor",iproc, - & " of CONT_FROM_COMM group" - call flush(iout) - do i=1,nn - write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10) - enddo - call flush(iout) - endif - do i=1,nn - ii=zapas_recv(1,i,iii) -c Flag the received contacts to prevent double-counting - jj=-zapas_recv(2,i,iii) -c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj -c call flush(iout) - nnn=num_cont_hb(ii)+1 - num_cont_hb(ii)=nnn - jcont_hb(nnn,ii)=jj - d_cont(nnn,ii)=zapas_recv(3,i,iii) - ind=3 - do kk=1,3 - ind=ind+1 - grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii) - enddo - enddo - enddo - enddo - enddo - enddo - call flush(iout) - if (lprn) then - write (iout,'(a)') 'Contact function values after receive:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i3,5f6.3))') - & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), - & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - call flush(iout) - endif - 30 continue -#endif - if (lprn) then - write (iout,'(a)') 'Contact function values:' - do i=nnt,nct-2 - write (iout,'(2i3,50(1x,i2,5f6.3))') - & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i), - & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i)) - enddo - endif - ecorr=0.0D0 - ecorr5=0.0d0 - ecorr6=0.0d0 -C Remove the loop below after debugging !!! - do i=nnt,nct - do j=1,3 - gradcorr(j,i)=0.0D0 - gradxorr(j,i)=0.0D0 - enddo - enddo -C Calculate the dipole-dipole interaction energies - if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then - do i=iatel_s,iatel_e+1 - num_conti=num_cont_hb(i) - do jj=1,num_conti - j=jcont_hb(jj,i) -#ifdef MOMENT - call dipole(i,j,jj) -#endif - enddo - enddo - endif -C Calculate the local-electrostatic correlation terms -c write (iout,*) "gradcorr5 in eello5 before loop" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1) -c write (iout,*) "corr loop i",i - i1=i+1 - num_conti=num_cont_hb(i) - num_conti1=num_cont_hb(i+1) - do jj=1,num_conti - j=jcont_hb(jj,i) - jp=iabs(j) - do kk=1,num_conti1 - j1=jcont_hb(kk,i1) - jp1=iabs(j1) -c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1, -c & ' jj=',jj,' kk=',kk -c if (j1.eq.j+1 .or. j1.eq.j-1) then - if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 - & .or. j.lt.0 .and. j1.gt.0) .and. - & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then -C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously. -C The system gains extra energy. - n_corr=n_corr+1 - sqd1=dsqrt(d_cont(jj,i)) - sqd2=dsqrt(d_cont(kk,i1)) - sred_geom = sqd1*sqd2 - IF (sred_geom.lt.cutoff_corr) THEN - call gcont(sred_geom,r0_corr,1.0D0,delt_corr, - & ekont,fprimcont) -cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1, -cd & ' jj=',jj,' kk=',kk - fac_prim1=0.5d0*sqd2/sqd1*fprimcont - fac_prim2=0.5d0*sqd1/sqd2*fprimcont - do l=1,3 - g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i) - g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1) - enddo - n_corr1=n_corr1+1 -cd write (iout,*) 'sred_geom=',sred_geom, -cd & ' ekont=',ekont,' fprim=',fprimcont, -cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2 -cd write (iout,*) "g_contij",g_contij -cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i) -cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1) - call calc_eello(i,jp,i+1,jp1,jj,kk) - if (wcorr4.gt.0.0d0) - & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk) - if (energy_dec.and.wcorr4.gt.0.0d0) - 1 write (iout,'(a6,4i5,0pf7.3)') - 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk) -c write (iout,*) "gradcorr5 before eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - if (wcorr5.gt.0.0d0) - & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk) -c write (iout,*) "gradcorr5 after eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - if (energy_dec.and.wcorr5.gt.0.0d0) - 1 write (iout,'(a6,4i5,0pf7.3)') - 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk) -cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6 -cd write(2,*)'ijkl',i,jp,i+1,jp1 - if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 - & .or. wturn6.eq.0.0d0))then -cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1 - ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk) - if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') - 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk) -cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5, -cd & 'ecorr6=',ecorr6 -cd write (iout,'(4e15.5)') sred_geom, -cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)), -cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)), -cd & dabs(eello6(i,jp,i+1,jp1,jj,kk)) - else if (wturn6.gt.0.0d0 - & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then -cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1 - eturn6=eturn6+eello_turn6(i,jj,kk) - if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') - 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk) -cd write (2,*) 'multibody_eello:eturn6',eturn6 - endif - ENDIF -1111 continue - endif - enddo ! kk - enddo ! jj - enddo ! i - do i=1,nres - num_cont_hb(i)=num_cont_hb_old(i) - enddo -c write (iout,*) "gradcorr5 in eello5" -c do iii=1,nres -c write (iout,'(i5,3f10.5)') -c & iii,(gradcorr5(jjj,iii),jjj=1,3) -c enddo - return - end -c------------------------------------------------------------------------------ - subroutine add_hb_contact_eello(ii,jj,itask) - implicit real*8 (a-h,o-z) - include "DIMENSIONS" - include "COMMON.IOUNITS" - integer max_cont - integer max_dim - parameter (max_cont=maxconts) - parameter (max_dim=70) - include "COMMON.CONTACTS" - double precision zapas(max_dim,maxconts,max_fg_procs), - & zapas_recv(max_dim,maxconts,max_fg_procs) - common /przechowalnia/ zapas - integer i,j,ii,jj,iproc,itask(4),nn -c write (iout,*) "itask",itask - do i=1,2 - iproc=itask(i) - if (iproc.gt.0) then - do j=1,num_cont_hb(ii) - jjc=jcont_hb(j,ii) -c write (iout,*) "send turns i",ii," j",jj," jjc",jjc - if (jjc.eq.jj) then - ncont_sent(iproc)=ncont_sent(iproc)+1 - nn=ncont_sent(iproc) - zapas(1,nn,iproc)=ii - zapas(2,nn,iproc)=jjc - zapas(3,nn,iproc)=d_cont(j,ii) - ind=3 - do kk=1,3 - ind=ind+1 - zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii) - enddo - do kk=1,2 - do ll=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii) - enddo - enddo - do jj=1,5 - do kk=1,3 - do ll=1,2 - do mm=1,2 - ind=ind+1 - zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii) - enddo - enddo - enddo - enddo - exit - endif - enddo - endif - enddo - return - end -c------------------------------------------------------------------------------ - double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - double precision gx(3),gx1(3) - logical lprn - lprn=.false. - eij=facont_hb(jj,i) - ekl=facont_hb(kk,k) - ees0pij=ees0p(jj,i) - ees0pkl=ees0p(kk,k) - ees0mij=ees0m(jj,i) - ees0mkl=ees0m(kk,k) - ekont=eij*ekl - ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl) -cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl) -C Following 4 lines for diagnostics. -cd ees0pkl=0.0D0 -cd ees0pij=1.0D0 -cd ees0mkl=0.0D0 -cd ees0mij=1.0D0 -c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)') -c & 'Contacts ',i,j, -c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l -c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees, -c & 'gradcorr_long' -C Calculate the multi-body contribution to energy. -c ecorr=ecorr+ekont*ees -C Calculate multi-body contributions to the gradient. - coeffpees0pij=coeffp*ees0pij - coeffmees0mij=coeffm*ees0mij - coeffpees0pkl=coeffp*ees0pkl - coeffmees0mkl=coeffm*ees0mkl - do ll=1,3 -cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i) - gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi - & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb1(ll,jj,i)) - gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi - & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb2(ll,jj,i)) -cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k) - gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk - & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ - & coeffmees0mij*gacontm_hb1(ll,kk,k)) - gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk - & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ - & coeffmees0mij*gacontm_hb2(ll,kk,k)) - gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- - & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ - & coeffmees0mkl*gacontm_hb3(ll,jj,i)) - gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij - gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij - gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- - & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ - & coeffmees0mij*gacontm_hb3(ll,kk,k)) - gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl - gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl -c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl - enddo -c write (iout,*) -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ -cgrad & ees*ekl*gacont_hbr(ll,jj,i)- -cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+ -cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i)) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ -cgrad & ees*eij*gacont_hbr(ll,kk,k)- -cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+ -cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k)) -cgrad enddo -cgrad enddo -c write (iout,*) "ehbcorr",ekont*ees - ehbcorr=ekont*ees - return - end -#ifdef MOMENT -C--------------------------------------------------------------------------- - subroutine dipole(i,j,jj) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2), - & auxmat(2,2) - iti1 = itortyp(itype(i+1)) - if (j.lt.nres-1) then - itj1 = itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - do iii=1,2 - dipi(iii,1)=Ub2(iii,i) - dipderi(iii)=Ub2der(iii,i) - dipi(iii,2)=b1(iii,iti1) - dipj(iii,1)=Ub2(iii,j) - dipderj(iii)=Ub2der(iii,j) - dipj(iii,2)=b1(iii,itj1) - enddo - kkk=0 - do iii=1,2 - call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1)) - do jjj=1,2 - kkk=kkk+1 - dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - do kkk=1,5 - do lll=1,3 - mmm=0 - do iii=1,2 - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii), - & auxvec(1)) - do jjj=1,2 - mmm=mmm+1 - dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1)) - enddo - enddo - enddo - enddo - call transpose2(a_chuj(1,1,jj,i),auxmat(1,1)) - call matvec2(auxmat(1,1),dipderi(1),auxvec(1)) - do iii=1,2 - dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii)) - enddo - call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1)) - do iii=1,2 - dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii)) - enddo - return - end -#endif -C--------------------------------------------------------------------------- - subroutine calc_eello(i,j,k,l,jj,kk) -C -C This subroutine computes matrices and vectors needed to calculate -C the fourth-, fifth-, and sixth-order local-electrostatic terms. -C - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2), - & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2) - logical lprn - common /kutas/ lprn -cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l, -cd & ' jj=',jj,' kk=',kk -cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return -cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2) -cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2) - do iii=1,2 - do jjj=1,2 - aa1(iii,jjj)=a_chuj(iii,jjj,jj,i) - aa2(iii,jjj)=a_chuj(iii,jjj,kk,k) - enddo - enddo - call transpose2(aa1(1,1),aa1t(1,1)) - call transpose2(aa2(1,1),aa2t(1,1)) - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,jj,i), - & aa1tder(1,1,lll,kkk)) - call transpose2(a_chuj_der(1,1,lll,kkk,kk,k), - & aa2tder(1,1,lll,kkk)) - enddo - enddo - if (l.eq.j+1) then -C parallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itj=itortyp(itype(j)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -C A1 kernel(j+1) A2T -cd do iii=1,2 -cd write (iout,'(3f10.5,5x,3f10.5)') -cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2) -cd enddo - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l), - & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l), - & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l), - & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1), - & ADtEAderx(1,1,1,1,1,1)) - lprn=.false. - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l), - & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), - & ADtEA1derx(1,1,1,1,1,1)) - ENDIF -C End 6-th order cumulants -cd lprn=.false. -cd if (lprn) then -cd write (2,*) 'In calc_eello6' -cd do iii=1,2 -cd write (2,*) 'iii=',iii -cd do kkk=1,5 -cd write (2,*) 'kkk=',kkk -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) -cd enddo -cd enddo -cd enddo -cd endif - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -C A1T kernel(i+1) A2 - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k), - & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0) THEN - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k), - & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k), - & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), - & ADtEAderx(1,1,1,1,1,2)) - call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1), - & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k), - & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), - & ADtEA1derx(1,1,1,1,1,2)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2)) - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -C AEAb1 and AEAb2 -C Calculate the vectors and their derivatives in virtual-bond dihedral angles. -C They are needed only when the fifth- or the sixth-order cumulants are -C indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2)) -C Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -C End vectors - else -C Antiparallel orientation of the two CA-CA-CA frames. - if (i.gt.1) then - iti=itortyp(itype(i)) - else - iti=ntortyp+1 - endif - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif -C A2 kernel(j-1)T A1T - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j), - & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. - & j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j), - & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1)) - call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j), - & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1), - & ADtEAderx(1,1,1,1,1,1)) - call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i), - & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j), - & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1), - & ADtEA1derx(1,1,1,1,1,1)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & EAEAderx(1,1,lll,kkk,iii,1)) - enddo - enddo - enddo -C A2T kernel(i+1)T A1 - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k), - & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2)) -C Following matrices are needed only for 6-th order cumulants - IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. - & j.eq.i+4 .and. l.eq.i+3)) THEN - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k), - & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k), - & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2), - & ADtEAderx(1,1,1,1,1,2)) - call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1), - & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k), - & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2), - & ADtEA1derx(1,1,1,1,1,2)) - ENDIF -C End 6-th order cumulants - call transpose2(EUgder(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2)) - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2)) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & EAEAderx(1,1,lll,kkk,iii,2)) - enddo - enddo - enddo -C AEAb1 and AEAb2 -C Calculate the vectors and their derivatives in virtual-bond dihedral angles. -C They are needed only when the fifth- or the sixth-order cumulants are -C indluded. - IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. - & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1)) - call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1)) - call transpose2(AEAderg(1,1,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1)) - call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1)) - call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1)) - call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1)) - call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1)) - call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1)) - call transpose2(AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2)) - call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2)) - call transpose2(AEAderg(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2)) - call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2)) - call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2)) - call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2)) - call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2)) - call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2)) -C Calculate the Cartesian derivatives of the vectors. - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,iti), - & AEAb1derx(1,lll,kkk,iii,1,1)) - call matvec2(auxmat(1,1),Ub2(1,i), - & AEAb2derx(1,lll,kkk,iii,1,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & AEAb1derx(1,lll,kkk,iii,2,1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1), - & AEAb2derx(1,lll,kkk,iii,2,1)) - call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1)) - call matvec2(auxmat(1,1),b1(1,itl), - & AEAb1derx(1,lll,kkk,iii,1,2)) - call matvec2(auxmat(1,1),Ub2(1,l), - & AEAb2derx(1,lll,kkk,iii,1,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1), - & AEAb1derx(1,lll,kkk,iii,2,2)) - call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j), - & AEAb2derx(1,lll,kkk,iii,2,2)) - enddo - enddo - enddo - ENDIF -C End vectors - endif - return - end -C--------------------------------------------------------------------------- - subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp, - & KK,KKderg,AKA,AKAderg,AKAderx) - implicit none - integer nderg - logical transp - double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5), - & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2), - & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2) - integer iii,kkk,lll - integer jjj,mmm - logical lprn - common /kutas/ lprn - call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1)) - do iii=1,nderg - call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp, - & AKAderg(1,1,iii)) - enddo -cd if (lprn) write (2,*) 'In kernel' - do kkk=1,5 -cd if (lprn) write (2,*) 'kkk=',kkk - do lll=1,3 - call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1), - & KK(1,1),transp,AKAderx(1,1,lll,kkk,1)) -cd if (lprn) then -cd write (2,*) 'lll=',lll -cd write (2,*) 'iii=1' -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2) -cd enddo -cd endif - call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk), - & KK(1,1),transp,AKAderx(1,1,lll,kkk,2)) -cd if (lprn) then -cd write (2,*) 'lll=',lll -cd write (2,*) 'iii=2' -cd do jjj=1,2 -cd write (2,'(3(2f10.5),5x)') -cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2) -cd enddo -cd endif - enddo - enddo - return - end -C--------------------------------------------------------------------------- - double precision function eello4(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then -cd eello4=0.0d0 -cd return -cd endif -cd print *,'eello4:',i,j,k,l,jj,kk -cd write (2,*) 'i',i,' j',j,' k',k,' l',l -cd call checkint4(i,j,k,l,jj,kk,eel4_num) -cold eij=facont_hb(jj,i) -cold ekl=facont_hb(kk,k) -cold ekont=eij*ekl - eel4=-EAEA(1,1,1)-EAEA(2,2,1) -cd eel41=-EAEA(1,1,2)-EAEA(2,2,2) - gcorr_loc(k-1)=gcorr_loc(k-1) - & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1)) - if (l.eq.j+1) then - gcorr_loc(l-1)=gcorr_loc(l-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - else - gcorr_loc(j-1)=gcorr_loc(j-1) - & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1)) - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) - & -EAEAderx(2,2,lll,kkk,iii,1) -cd derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd gcorr_loc(l-1)=0.0d0 -cd gcorr_loc(j-1)=0.0d0 -cd gcorr_loc(k-1)=0.0d0 -cd eel4=1.0d0 -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l, -cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel4*g_contij(ll,1) -cgrad ggg2(ll)=eel4*g_contij(ll,2) - glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1) - glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2) -cgrad ghalf=0.5d0*ggg1(ll) - gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1) - gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1) - gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1) - gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1) - gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij - gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij -cgrad ghalf=0.5d0*ggg2(ll) - gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2) - gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2) - gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2) - gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2) - gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl - gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl - enddo -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,gcorr_loc(iii) -cd enddo - eello4=ekont*eel4 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello4',ekont*eel4 - return - end -C--------------------------------------------------------------------------- - double precision function eello5(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2) - double precision ggg1(3),ggg2(3) -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel chains C -C C -C o o o o C -C /l\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j| o |l1 | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C Antiparallel chains C -C C -C o o o o C -C /j\ / \ \ / \ / \ / C -C / \ / \ \ / \ / \ / C -C j1| o |l | o | o| o | | o |o C -C \ |/k\| |/ \| / |/ \| |/ \| C -C \i/ \ / \ / / \ / \ C -C o k1 o C -C (I) (II) (III) (IV) C -C C -C eello5_1 eello5_2 eello5_3 eello5_4 C -C C -C o denotes a local interaction, vertical lines an electrostatic interaction. C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then -cd eello5=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO5: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - itk=itortyp(itype(k)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) - eello5_1=0.0d0 - eello5_2=0.0d0 - eello5_3=0.0d0 - eello5_4=0.0d0 -cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num, -cd & eel5_3_num,eel5_4_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd write (iout,*)'Contacts have occurred for peptide groups', -cd & i,j,' fcont:',eij,' eij',' and ',k,l -cd goto 1111 -C Contribution from the graph I. -cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1) -cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) -C Explicit gradient in virtual-dihedral angles. - if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,i))) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - if (l.eq.j+1) then - if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - else - if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i))) - endif -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,i)) - enddo - enddo - enddo -c goto 1112 -c1111 continue -C Contribution from graph II - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k)) - call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - if (l.eq.j+1) then - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - else - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k))) - endif -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) - & -0.5d0*scalar2(vv(1),Ctobr(1,k)) - enddo - enddo - enddo -cd goto 1112 -cd1111 continue - if (l.eq.j+1) then -cd goto 1110 -C Parallel orientation -C Contribution from graph III - call transpose2(EUg(1,1,l),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,j))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) - call transpose2(EUgder(1,1,l),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,j)) - enddo - enddo - enddo -cd goto 1112 -C Contribution from graph IV -cd1110 continue - call transpose2(EE(1,1,itl),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,iii)=derx(lll,kkk,iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) - & -0.5d0*scalar2(vv(1),Ctobr(1,l)) - enddo - enddo - enddo - else -C Antiparallel orientation -C Contribution from graph III -c goto 1110 - call transpose2(EUg(1,1,j),auxmat(1,1)) - call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(l-1)=g_corr5_loc(l-1) - & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2der(1,l))) - call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) - call transpose2(EUgder(1,1,j),auxmat1(1,1)) - call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) - & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) - & +0.5d0*scalar2(vv(1),Dtobr2(1,l)) - enddo - enddo - enddo -cd goto 1112 -C Contribution from graph IV -1110 continue - call transpose2(EE(1,1,itj),auxmat(1,1)) - call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) -C Explicit gradient in virtual-dihedral angles. - g_corr5_loc(j-1)=g_corr5_loc(j-1) - & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j)) - call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - g_corr5_loc(k-1)=g_corr5_loc(k-1) - & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j))) -C Cartesian gradient - do iii=1,2 - do kkk=1,5 - do lll=1,3 - call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) - & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) - & -0.5d0*scalar2(vv(1),Ctobr(1,j)) - enddo - enddo - enddo - endif -1112 continue - eel5=eello5_1+eello5_2+eello5_3+eello5_4 -cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then -cd write (2,*) 'ijkl',i,j,k,l -cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2, -cd & ' eello5_3',eello5_3,' eello5_4',eello5_4 -cd endif -cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num -cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num -cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num -cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 -cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont -C 2/11/08 AL Gradients over DC's connecting interacting sites will be -C summed up outside the subrouine as for the other subroutines -C handling long-range interactions. The old code is commented out -C with "cgrad" to keep track of changes. - do ll=1,3 -cgrad ggg1(ll)=eel5*g_contij(ll,1) -cgrad ggg2(ll)=eel5*g_contij(ll,2) - gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1) - gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2) -c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)') -c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1), -c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2), -c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont -c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)') -c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1), -c & gradcorr5ij, -c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl -cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1) - gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1) - gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1) - gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1) - gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij - gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij -cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k) -cgrad ghalf=0.5d0*ggg2(ll) -cd ghalf=0.0d0 - gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2) - gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2) - gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2) - gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2) - gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl - gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i) -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k) -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -c1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr5_loc(iii) -cd enddo - eello5=ekont*eel5 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello5',ekont*eel5 - return - end -c-------------------------------------------------------------------------- - double precision function eello6(i,j,k,l,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision ggg1(3),ggg2(3) -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l - eello6_1=0.0d0 - eello6_2=0.0d0 - eello6_3=0.0d0 - eello6_4=0.0d0 - eello6_5=0.0d0 - eello6_6=0.0d0 -cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num, -cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=facont_hb(jj,i) -cd ekl=facont_hb(kk,k) -cd ekont=eij*ekl -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - if (l.eq.j+1) then - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(j,i,l,k,2,.false.) - eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.) - eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.) - else - eello6_1=eello6_graph1(i,j,k,l,1,.false.) - eello6_2=eello6_graph1(l,k,j,i,2,.true.) - eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.) - eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.) - if (wturn6.eq.0.0d0 .or. j.ne.i+4) then - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) - else - eello6_5=0.0d0 - endif - eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.) - endif -C If turn contributions are considered, they will be handled separately. - eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6 -cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num -cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num -cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num -cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num -cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num -cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num -cd goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel6*g_contij(ll,1) -cgrad ggg2(ll)=eel6*g_contij(ll,2) -cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1) - gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2) - gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1) - gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1) - gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1) - gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1) - gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij - gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij -cgrad ghalf=0.5d0*ggg2(ll) -cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k) -cd ghalf=0.0d0 - gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2) - gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2) - gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2) - gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2) - gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl - gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i) -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k) -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr6_loc(iii) -cd enddo - eello6=ekont*eel6 -cd write (2,*) 'ekont',ekont -cd write (iout,*) 'eello6',ekont*eel6 - return - end -c-------------------------------------------------------------------------- - double precision function eello6_graph1(i,j,k,l,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2) - logical swap - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ /j\ C -C / \ / \ C -C /| o | | o |\ C -C \ j|/k\| / \ |/k\|l / C -C \ / \ / \ / \ / C -C o o o o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - itk=itortyp(itype(k)) - s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk) - vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5 - eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5) - if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) - & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) - & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) - & +scalar2(vv(1),Dtobr2der(1,i))) - call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk) - vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk) - if (l.eq.j+1) then - g_corr6_loc(l-1)=g_corr6_loc(l-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1) - & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) - & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) - & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i)))) - endif - call transpose2(EUgCder(1,1,k),auxmat(1,1)) - call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) - & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) - & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) - & +0.5d0*scalar2(vv1(1),Dtobr2(1,i)))) - do iii=1,2 - if (swap) then - ind=3-iii - else - ind=iii - endif - do kkk=1,5 - do lll=1,3 - s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i)) - s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k)) - s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k)) - call transpose2(EUgC(1,1,k),auxmat(1,1)) - call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda1(1,1)) - vv1(1)=pizda1(1,1)-pizda1(2,2) - vv1(2)=pizda1(1,2)+pizda1(2,1) - s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i)) - vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) - & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk) - vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) - & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk) - s5=scalar2(vv(1),Dtobr2(1,i)) - derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5) - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph2(i,j,k,l,jj,kk,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - logical swap - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxvec2(1),auxmat1(2,2) - logical lprn - common /kutas/ lprn -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C \ /l\ /j\ / C -C \ / \ / \ / C -C o| o | | o |o C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l -C AL 7/4/01 s1 would occur in the sixth-order moment, -C but not in a cluster cumulant -#ifdef MOMENT - s1=dip(1,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph2=-(s1+s2+s3+s4) -#else - eello6_graph2=-(s2+s3+s4) -#endif -c eello6_graph2=-s3 -C Derivatives in gamma(i-1) - if (i.gt.1) then -#ifdef MOMENT - s1=dipderg(1,jj,i)*dip(1,kk,k) -#endif - s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1)) - call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i)) -#ifdef MOMENT - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) -#endif -c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3 - endif -C Derivatives in gamma(k-1) -#ifdef MOMENT - s1=dip(1,jj,i)*dipderg(1,kk,k) -#endif - call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif -c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3 -C Derivatives in gamma(j-1) or gamma(l-1) - if (j.gt.1) then -#ifdef MOMENT - s1=dipderg(3,jj,i)*dip(1,kk,k) -#endif - call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1)) - call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - if (swap) then - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 - else - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 - endif -#endif - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4) -c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3 - endif -C Derivatives in gamma(l-1) or gamma(j-1) - if (l.gt.1) then -#ifdef MOMENT - s1=dip(1,jj,i)*dipderg(3,kk,k) -#endif - call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1)) - call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1)) - call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -#ifdef MOMENT - if (swap) then - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1 - else - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1 - endif -#endif - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4) -c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3 - endif -C Cartesian derivatives. - if (lprn) then - write (2,*) 'In eello6_graph2' - do iii=1,2 - write (2,*) 'iii=',iii - do kkk=1,5 - write (2,*) 'kkk=',kkk - do jjj=1,2 - write (2,'(3(2f10.5),5x)') - & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3) - enddo - enddo - enddo - endif - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k) - else - s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k) - endif -#endif - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k), - & auxvec(1)) - s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l), - & auxvec(1)) - s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1)) - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(1,2)+pizda(2,1) - s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph3(i,j,k,l,jj,kk,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C j|/k\| / |/k\|l / C -C / \ / / \ / C -C / o / o C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. - iti=itortyp(itype(i)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -#ifdef MOMENT - s1=dip(4,jj,i)*dip(4,kk,k) -#endif - call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call transpose2(EE(1,1,itk),auxmat(1,1)) - call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4, -cd & "sum",-(s2+s3+s4) -#ifdef MOMENT - eello6_graph3=-(s1+s2+s3+s4) -#else - eello6_graph3=-(s2+s3+s4) -#endif -c eello6_graph3=-s4 -C Derivatives in gamma(k-1) - call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k)) - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4) -C Derivatives in gamma(l-1) - call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) -C Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k) - else - s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k) - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1), - & auxvec(1)) - s2=0.5d0*scalar2(b1(1,itk),auxvec(1)) - call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1), - & auxvec(1)) - s3=0.5d0*scalar2(b1(1,itj1),auxvec(1)) - call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1), - & pizda(1,1)) - vv(1)=pizda(1,1)+pizda(2,2) - vv(2)=pizda(2,1)-pizda(1,2) - s4=-0.25d0*scalar2(vv(1),Ctobr(1,k)) -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (swap) then - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif -c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4 - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.FFIELD' - double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2), - & auxvec1(2),auxmat1(2,2) - logical swap -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C C -C Parallel Antiparallel C -C C -C o o C -C /l\ / \ /j\ C -C / \ / \ / \ C -C /| o |o o| o |\ C -C \ j|/k\| \ |/k\|l C -C \ / \ \ / \ C -C o \ o \ C -C i i C -C C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C 4/7/01 AL Component s1 was removed, because it pertains to the respective -C energy moment and not to the cluster cumulant. -cd write (2,*) 'eello_graph4: wturn6',wturn6 - iti=itortyp(itype(i)) - itj=itortyp(itype(j)) - if (j.lt.nres-1) then - itj1=itortyp(itype(j+1)) - else - itj1=ntortyp+1 - endif - itk=itortyp(itype(k)) - if (k.lt.nres-1) then - itk1=itortyp(itype(k+1)) - else - itk1=ntortyp+1 - endif - itl=itortyp(itype(l)) - if (l.lt.nres-1) then - itl1=itortyp(itype(l+1)) - else - itl1=ntortyp+1 - endif -cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l -cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk, -cd & ' itl',itl,' itl1',itl1 -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dip(3,kk,k) - else - s1=dip(2,jj,j)*dip(2,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUg(1,1,k),auxmat(1,1)) - call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) -cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4 -#ifdef MOMENT - eello6_graph4=-(s1+s2+s3+s4) -#else - eello6_graph4=-(s2+s3+s4) -#endif -C Derivatives in gamma(i-1) - if (i.gt.1) then -#ifdef MOMENT - if (imat.eq.1) then - s1=dipderg(2,jj,i)*dip(3,kk,k) - else - s1=dipderg(4,jj,j)*dip(2,kk,l) - endif -#endif - s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -cd write (2,*) 'turn6 derivatives' -#ifdef MOMENT - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4) -#endif - endif - endif -C Derivatives in gamma(k-1) -#ifdef MOMENT - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderg(2,kk,k) - else - s1=dip(2,jj,j)*dipderg(4,kk,l) - endif -#endif - call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1)) - else - call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1)) - endif - call transpose2(EUgder(1,1,k),auxmat1(1,1)) - call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4) -#else - gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4) -#endif - else -#ifdef MOMENT - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4) -#else - g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4) -#endif - endif -C Derivatives in gamma(j-1) or gamma(l-1) - if (l.eq.j+1 .and. l.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4) - else if (j.gt.1) then - call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then - gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4) - else - g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4) - endif - endif -C Cartesian derivatives. - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - if (iii.eq.1) then - if (imat.eq.1) then - s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k) - else - s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l) - endif - else - if (imat.eq.1) then - s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k) - else - s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l) - endif - endif -#endif - call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k), - & auxvec(1)) - s2=0.5d0*scalar2(Ub2(1,i),auxvec(1)) - if (j.eq.l+1) then - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), - & b1(1,itj1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itj),auxvec(1)) - else - call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat), - & b1(1,itl1),auxvec(1)) - s3=-0.5d0*scalar2(b1(1,itl),auxvec(1)) - endif - call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1), - & pizda(1,1)) - vv(1)=pizda(1,1)-pizda(2,2) - vv(2)=pizda(2,1)+pizda(1,2) - s4=0.25d0*scalar2(vv(1),Dtobr2(1,i)) - if (swap) then - if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then -#ifdef MOMENT - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s1+s2+s4) -#else - derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) - & -(s2+s4) -#endif - derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3 - else -#ifdef MOMENT - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4) -#else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4) -#endif - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - endif - else -#ifdef MOMENT - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4) -#else - derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4) -#endif - if (l.eq.j+1) then - derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3 - else - derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3 - endif - endif - enddo - enddo - enddo - return - end -c---------------------------------------------------------------------------- - double precision function eello_turn6(i,jj,kk) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.IOUNITS' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' - include 'COMMON.TORSION' - include 'COMMON.VAR' - include 'COMMON.GEO' - double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2), - & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2), - & ggg1(3),ggg2(3) - double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2), - & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2) -C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to -C the respective energy moment and not to the cluster cumulant. - s1=0.0d0 - s8=0.0d0 - s13=0.0d0 -c - eello_turn6=0.0d0 - j=i+4 - k=i+1 - l=i+3 - iti=itortyp(itype(i)) - itk=itortyp(itype(k)) - itk1=itortyp(itype(k+1)) - itl=itortyp(itype(l)) - itj=itortyp(itype(j)) -cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj -cd write (2,*) 'i',i,' k',k,' j',j,' l',l -cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then -cd eello6=0.0d0 -cd return -cd endif -cd write (iout,*) -cd & 'EELLO6: Contacts have occurred for peptide groups',i,j, -cd & ' and',k,l -cd call checkint_turn6(i,jj,kk,eel_turn6_num) - do iii=1,2 - do kkk=1,5 - do lll=1,3 - derx_turn(lll,kkk,iii)=0.0d0 - enddo - enddo - enddo -cd eij=1.0d0 -cd ekl=1.0d0 -cd ekont=1.0d0 - eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.) -cd eello6_5=0.0d0 -cd write (2,*) 'eello6_5',eello6_5 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmat(1,1)) - call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1)) - ss1=scalar2(Ub2(1,i+2),b1(1,itl)) - s1 = (auxmat(1,1)+auxmat(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1)) - s2 = scalar2(b1(1,itk),vtemp1(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atemp(1,1)) - call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1)) - call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1)) - s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1)) - call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1)) - s12 = scalar2(Ub2(1,i+2),vtemp3(1)) -#ifdef MOMENT - call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1)) - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1)) - call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1)) - call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1)) - ss13 = scalar2(b1(1,itk),vtemp4(1)) - s13 = (gtemp(1,1)+gtemp(2,2))*ss13 -#endif -c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13 -c s1=0.0d0 -c s2=0.0d0 -c s8=0.0d0 -c s12=0.0d0 -c s13=0.0d0 - eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13) -C Derivatives in gamma(i+2) - s1d =0.0d0 - s8d =0.0d0 -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 - call transpose2(AEAderg(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 - gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d) -C Derivatives in gamma(i+3) -#ifdef MOMENT - call transpose2(AEA(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - ss1d=scalar2(Ub2der(1,i+2),b1(1,itl)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d -#endif - call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1)) - s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1)) -#endif - s12d = scalar2(Ub2der(1,i+2),vtemp3(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) - & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+1)=gel_loc_turn6(i+1) - & -0.5d0*ekont*(s2d+s12d) -#endif -C Derivatives in gamma(i+4) - call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1)) - s13d = (gtempd(1,1)+gtempd(2,2))*ss13 -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -C s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d) -#else - gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d) -#endif -C Derivatives in gamma(i+5) -#ifdef MOMENT - call transpose2(AEAderg(1,1,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1)) - call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEA(1,1,2),atempd(1,1)) - call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -#ifdef MOMENT - call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d -#endif -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) - & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d) -#else - gel_loc_turn6(i+3)=gel_loc_turn6(i+3) - & -0.5d0*ekont*(s2d+s12d) -#endif -C Cartesian derivatives - do iii=1,2 - do kkk=1,5 - do lll=1,3 -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1)) - call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1)) - s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1 -#endif - call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1)) - call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1), - & vtemp1d(1)) - s2d = scalar2(b1(1,itk),vtemp1d(1)) -#ifdef MOMENT - call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1)) - call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1)) - s8d = -(atempd(1,1)+atempd(2,2))* - & scalar2(cc(1,1,itl),vtemp2(1)) -#endif - call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2), - & auxmatd(1,1)) - call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1)) - s12d = scalar2(Ub2(1,i+2),vtemp3d(1)) -c s1d=0.0d0 -c s2d=0.0d0 -c s8d=0.0d0 -c s12d=0.0d0 -c s13d=0.0d0 -#ifdef MOMENT - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) - & - 0.5d0*(s1d+s2d) -#else - derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) - & - 0.5d0*s2d -#endif -#ifdef MOMENT - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) - & - 0.5d0*(s8d+s12d) -#else - derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) - & - 0.5d0*s12d -#endif - enddo - enddo - enddo -#ifdef MOMENT - do kkk=1,5 - do lll=1,3 - call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1), - & achuj_tempd(1,1)) - call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1)) - call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1)) - s13d=(gtempd(1,1)+gtempd(2,2))*ss13 - derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d - call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4), - & vtemp4d(1)) - ss13d = scalar2(b1(1,itk),vtemp4d(1)) - s13d = (gtemp(1,1)+gtemp(2,2))*ss13d - derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d - enddo - enddo -#endif -cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num', -cd & 16*eel_turn6_num -cd goto 1112 - if (j.lt.nres-1) then - j1=j+1 - j2=j-1 - else - j1=j-1 - j2=j-2 - endif - if (l.lt.nres-1) then - l1=l+1 - l2=l-1 - else - l1=l-1 - l2=l-2 - endif - do ll=1,3 -cgrad ggg1(ll)=eel_turn6*g_contij(ll,1) -cgrad ggg2(ll)=eel_turn6*g_contij(ll,2) -cgrad ghalf=0.5d0*ggg1(ll) -cd ghalf=0.0d0 - gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1) - gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2) - gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf - & +ekont*derx_turn(ll,2,1) - gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1) - gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf - & +ekont*derx_turn(ll,4,1) - gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1) - gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij - gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij -cgrad ghalf=0.5d0*ggg2(ll) -cd ghalf=0.0d0 - gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf - & +ekont*derx_turn(ll,2,2) - gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2) - gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf - & +ekont*derx_turn(ll,4,2) - gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2) - gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl - gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl - enddo -cd goto 1112 -cgrad do m=i+1,j-1 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll) -cgrad enddo -cgrad enddo -cgrad do m=k+1,l-1 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll) -cgrad enddo -cgrad enddo -cgrad1112 continue -cgrad do m=i+2,j2 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1) -cgrad enddo -cgrad enddo -cgrad do m=k+2,l2 -cgrad do ll=1,3 -cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2) -cgrad enddo -cgrad enddo -cd do iii=1,nres-3 -cd write (2,*) iii,g_corr6_loc(iii) -cd enddo - eello_turn6=ekont*eel_turn6 -cd write (2,*) 'ekont',ekont -cd write (2,*) 'eel_turn6',ekont*eel_turn6 - return - end - -C----------------------------------------------------------------------------- - double precision function scalar(u,v) -!DIR$ INLINEALWAYS scalar -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::scalar -#endif - implicit none - double precision u(3),v(3) -cd double precision sc -cd integer i -cd sc=0.0d0 -cd do i=1,3 -cd sc=sc+u(i)*v(i) -cd enddo -cd scalar=sc - - scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3) - return - end -crc------------------------------------------------- - SUBROUTINE MATVEC2(A1,V1,V2) -!DIR$ INLINEALWAYS MATVEC2 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2 -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),V1(2),V2(2) -c DO 1 I=1,2 -c VI=0.0 -c DO 3 K=1,2 -c 3 VI=VI+A1(I,K)*V1(K) -c Vaux(I)=VI -c 1 CONTINUE - - vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2) - vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2) - - v2(1)=vaux1 - v2(2)=vaux2 - END -C--------------------------------------- - SUBROUTINE MATMAT2(A1,A2,A3) -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2 -#endif - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - DIMENSION A1(2,2),A2(2,2),A3(2,2) -c DIMENSION AI3(2,2) -c DO J=1,2 -c A3IJ=0.0 -c DO K=1,2 -c A3IJ=A3IJ+A1(I,K)*A2(K,J) -c enddo -c A3(I,J)=A3IJ -c enddo -c enddo - - ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1) - ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2) - ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1) - ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2) - - A3(1,1)=AI3_11 - A3(2,1)=AI3_21 - A3(1,2)=AI3_12 - A3(2,2)=AI3_22 - END - -c------------------------------------------------------------------------- - double precision function scalar2(u,v) -!DIR$ INLINEALWAYS scalar2 - implicit none - double precision u(2),v(2) - double precision sc - integer i - scalar2=u(1)*v(1)+u(2)*v(2) - return - end - -C----------------------------------------------------------------------------- - - subroutine transpose2(a,at) -!DIR$ INLINEALWAYS transpose2 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::transpose2 -#endif - implicit none - double precision a(2,2),at(2,2) - at(1,1)=a(1,1) - at(1,2)=a(2,1) - at(2,1)=a(1,2) - at(2,2)=a(2,2) - return - end -c-------------------------------------------------------------------------- - subroutine transpose(n,a,at) - implicit none - integer n,i,j - double precision a(n,n),at(n,n) - do i=1,n - do j=1,n - at(j,i)=a(i,j) - enddo - enddo - return - end -C--------------------------------------------------------------------------- - subroutine prodmat3(a1,a2,kk,transp,prod) -!DIR$ INLINEALWAYS prodmat3 -#ifndef OSF -cDEC$ ATTRIBUTES FORCEINLINE::prodmat3 -#endif - implicit none - integer i,j - double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2) - logical transp -crc double precision auxmat(2,2),prod_(2,2) - - if (transp) then -crc call transpose2(kk(1,1),auxmat(1,1)) -crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) - & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) - & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2) - - else -crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1)) -crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1)) - - prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1) - prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) - & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2) - prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1) - prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) - & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2) - - endif -c call transpose2(a2(1,1),a2t(1,1)) - -crc print *,transp -crc print *,((prod_(i,j),i=1,2),j=1,2) -crc print *,((prod(i,j),i=1,2),j=1,2) - - return - end - diff --git a/source/unres/src-HCD-5D/energy_split-sep.F b/source/unres/src-HCD-5D/energy_split-sep.F index 9abad39..1b033a5 100644 --- a/source/unres/src-HCD-5D/energy_split-sep.F +++ b/source/unres/src-HCD-5D/energy_split-sep.F @@ -1,5 +1,5 @@ subroutine etotal_long(energia) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' c c Compute the long-range slow-varying contributions to the energy @@ -13,6 +13,8 @@ cMS$ATTRIBUTES C :: proc_proc #ifdef MPI include "mpif.h" double precision weights_(n_ene) + double precision time00,time_Bcast,time_BcastW + integer ierror,ierr #endif include 'COMMON.SETUP' include 'COMMON.IOUNITS' @@ -24,8 +26,15 @@ cMS$ATTRIBUTES C :: proc_proc include 'COMMON.CHAIN' include 'COMMON.VAR' include 'COMMON.LOCAL' + include 'COMMON.QRESTR' include 'COMMON.MD' include 'COMMON.CONTROL' + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6, + & eliptran,Eafmforce,Etube, + & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet + integer i,n_corr,n_corr1 c write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot if (modecalc.eq.12.or.modecalc.eq.14) then #ifdef MPI @@ -66,7 +75,13 @@ C FG slaves as WEIGHTS array. weights_(17)=wbond weights_(18)=scal14 weights_(21)=wsccor + weights_(22)=wliptran + weights_(25)=wtube weights_(26)=wsaxs + weights_(28)=wdfa_dist + weights_(29)=wdfa_tor + weights_(30)=wdfa_nei + weights_(31)=wdfa_beta C FG Master broadcasts the WEIGHTS_ array call MPI_Bcast(weights_(1),n_ene, & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR) @@ -93,7 +108,13 @@ C FG slaves receive the WEIGHTS array wbond=weights(17) scal14=weights(18) wsccor=weights(21) + wliptran=weights(22) + wtube=weights(25) wsaxs=weights(26) + wdfa_dist=weights_(28) + wdfa_tor=weights_(29) + wdfa_nei=weights_(30) + wdfa_beta=weights_(31) endif call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION, & king,FG_COMM,IERR) @@ -181,6 +202,7 @@ C else call escp_soft_sphere(evdw2,evdw2_14) endif +#ifdef FOURBODY C C 12/1/95 Multi-body terms C @@ -200,6 +222,7 @@ c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) endif +#endif C C If performing constraint dynamics, call the constraint energy C after the equilibration time @@ -269,6 +292,8 @@ cMS$ATTRIBUTES C :: proc_proc #ifdef MPI include "mpif.h" double precision weights_(n_ene) + double precision time00 + integer ierror,ierr #endif include 'COMMON.SETUP' include 'COMMON.IOUNITS' @@ -281,8 +306,14 @@ cMS$ATTRIBUTES C :: proc_proc include 'COMMON.VAR' include 'COMMON.LOCAL' include 'COMMON.CONTROL' + include 'COMMON.SAXS' include 'COMMON.TORCNSTR' - + double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc, + & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr, + & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6, + & eliptran,Eafmforce,Etube, + & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet + integer i,n_corr,n_corr1 c write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot c call flush(iout) if (modecalc.eq.12.or.modecalc.eq.14) then @@ -479,6 +510,13 @@ C energy function etors=0.0d0 endif edihcnstr=0.0d0 +c Lipid transfer + if (wliptran.gt.0) then + call Eliptransfer(eliptran) + else + eliptran=0.0d0 + endif + if (ndih_constr.gt.0) call etor_constr(edihcnstr) c print *,"Processor",myrank," computed Utor" C diff --git a/source/unres/src-HCD-5D/gen_rand_conf.F b/source/unres/src-HCD-5D/gen_rand_conf.F index 8f98ffc..3e662cc 100644 --- a/source/unres/src-HCD-5D/gen_rand_conf.F +++ b/source/unres/src-HCD-5D/gen_rand_conf.F @@ -1,6 +1,6 @@ subroutine gen_rand_conf(nstart,*) C Generate random conformation or chain cut and regrowth. - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.LOCAL' @@ -11,6 +11,9 @@ C Generate random conformation or chain cut and regrowth. include 'COMMON.GEO' include 'COMMON.CONTROL' logical overlap,back,fail + integer nstart + integer i,j,k,it,it1,it2,nit,niter,nsi,maxsi,maxnit + double precision gen_theta,gen_phi,dist cd print *,' CG Processor',me,' maxgen=',maxgen maxsi=100 cd write (iout,*) 'Gen_Rand_conf: nstart=',nstart @@ -125,12 +128,15 @@ c print *,'phi(',i,')=',phi(i) end c------------------------------------------------------------------------- logical function overlap(i) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.INTERACT' include 'COMMON.FFIELD' - data redfac /0.5D0/ + double precision redfac /0.5D0/ + integer i,j,k,iti,itj,iteli,itelj + double precision rcomp + double precision dist overlap=.false. iti=iabs(itype(i)) if (iti.gt.ntyp) return @@ -798,8 +804,8 @@ c overlapping residues left, or false otherwise (success) call chainbuild_extconf call overlap_sc_list(ioverlap,ioverlap_last) -c write (iout,*) 'Overlaping residues ',ioverlap_last, -c & (ioverlap(j),j=1,ioverlap_last) + write (iout,*) 'Overlaping residues ',ioverlap_last, + & (ioverlap(j),j=1,ioverlap_last) enddo if (k.le.1000.and.ioverlap_last.eq.0) then @@ -839,6 +845,7 @@ c & (ioverlap(j),j=1,ioverlap_last) integer ioverlap(maxres),ioverlap_last data redfac /0.5D0/ + write (iout,*) "overlap_sc_list" ioverlap_last=0 C Check for SC-SC overlaps and mark residues c print *,'>>overlap_sc nnt=',nnt,' nct=',nct @@ -895,11 +902,11 @@ c & ,rcomp ct if ( 1.0/rij .lt. redfac*rcomp .or. ct & rij_shift.le.0.0D0 ) then +c write (iout,'(a,i3,a,i3,a,f10.5,a,3f10.5)') +c & 'overlap SC-SC: i=',i,' j=',j, +c & ' dist=',dist(nres+i,nres+j),' rcomp=', +c & rcomp,1.0/rij,rij_shift if ( rij_shift.le.0.0D0 ) then -cd write (iout,'(a,i3,a,i3,a,f10.5,a,3f10.5)') -cd & 'overlap SC-SC: i=',i,' j=',j, -cd & ' dist=',dist(nres+i,nres+j),' rcomp=', -cd & rcomp,1.0/rij,rij_shift ioverlap_last=ioverlap_last+1 ioverlap(ioverlap_last)=i do k=1,ioverlap_last-1 diff --git a/source/unres/src-HCD-5D/geomout.F b/source/unres/src-HCD-5D/geomout.F index 09ad28e..dd45a7d 100644 --- a/source/unres/src-HCD-5D/geomout.F +++ b/source/unres/src-HCD-5D/geomout.F @@ -1,5 +1,5 @@ subroutine pdbout(etot,tytul,iunit) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.INTERACT' @@ -7,11 +7,19 @@ include 'COMMON.IOUNITS' include 'COMMON.HEADER' include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif character*50 tytul + integer iunit character*1 chainid(10) /'A','B','C','D','E','F','G','H','I','J'/ - dimension ica(maxres) + integer ica(maxres) + integer i,j,k,iti,itj,itk,itl,iatom,ichain,ires + double precision etot write (iunit,'(3a,1pe15.5)') 'REMARK ',tytul,' ENERGY ',etot cmodel write (iunit,'(a5,i6)') 'MODEL',1 if (nhfrag.gt.0) then @@ -159,6 +167,7 @@ C format. character*32 tytul,fd character*3 zahl character*6 res_num,pom,ucase + double precision etot #ifdef AIX call fdate_(fd) #elif (defined CRAY) @@ -203,7 +212,7 @@ C format. end c------------------------------------------------------------------------ subroutine intout - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' @@ -213,6 +222,7 @@ c------------------------------------------------------------------------ include 'COMMON.NAMES' include 'COMMON.GEO' include 'COMMON.TORSION' + integer i,iti write (iout,'(/a)') 'Geometry of the virtual chain.' write (iout,'(7a)') ' Res ',' d',' Theta', & ' Phi',' Dsc',' Alpha',' Omega' @@ -226,7 +236,7 @@ c------------------------------------------------------------------------ end c--------------------------------------------------------------------------- subroutine briefout(it,ener) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.CHAIN' @@ -236,6 +246,7 @@ c--------------------------------------------------------------------------- include 'COMMON.NAMES' include 'COMMON.GEO' include 'COMMON.SBRIDGE' + integer it,ener,i c print '(a,i5)',intname,igeom #if defined(AIX) || defined(PGI) || defined(CRAY) open (igeom,file=intname,position='append') @@ -274,7 +285,7 @@ c---------------------------------------------------------------- #else subroutine cartoutx(time) #endif - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.INTERACT' @@ -282,8 +293,10 @@ c---------------------------------------------------------------- include 'COMMON.IOUNITS' include 'COMMON.HEADER' include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.MD' + include 'COMMON.QRESTR' + integer i,j,k double precision time #if defined(AIX) || defined(PGI) || defined(CRAY) open(icart,file=cartname,position="append") @@ -310,7 +323,7 @@ c---------------------------------------------------------------- c----------------------------------------------------------------- #ifndef NOXDR subroutine cartout(time) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -324,11 +337,13 @@ c----------------------------------------------------------------- include 'COMMON.IOUNITS' include 'COMMON.HEADER' include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.MD' + include 'COMMON.QRESTR' double precision time integer iret,itmp real xcoord(3,maxres2+2),prec + integer i,j,ixdrf #ifdef AIX call xdrfopen_(ixdrf,cartname, "a", iret) @@ -426,8 +441,9 @@ c----------------------------------------------------------------- include 'COMMON.IOUNITS' include 'COMMON.HEADER' include 'COMMON.SBRIDGE' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.MD' + include 'COMMON.QRESTR' include 'COMMON.REMD' include 'COMMON.SETUP' integer itime @@ -450,7 +466,7 @@ c----------------------------------------------------------------- #endif #endif if (AFMlog.gt.0) then - if (refstr) then + if (refstr) then call rms_nac_nnc(rms,frac,frac_nn,co,.false.) write (line1,'(i10,f15.2,3f12.3,f7.2,2f6.3,4f12.3,i5,$)') & itime,totT,EK,potE+potEcomp(27),totE+potEcomp(27), @@ -464,14 +480,14 @@ C print *,'A CHUJ',potEcomp(23) & kinetic_T,t_bath,gyrate(), & potEcomp(23),me format1="a114" - endif + endif else if (selfguide.gt.0) then distance=0.0 do j=1,3 distance=distance+(c(j,afmend)-c(j,afmbeg))**2 enddo distance=dsqrt(distance) - if (refstr) then + if (refstr) then call rms_nac_nnc(rms,frac,frac_nn,co,.false.) write (line1,'(i10,f15.2,3f12.3,f7.2,2f6.3,f12.3,f10.1,2f8.2, & f9.3,i5,$)') @@ -480,7 +496,7 @@ C print *,'A CHUJ',potEcomp(23) & distance,potEcomp(23),me format1="a133" C print *,"CHUJOWO" - else + else C print *,'A CHUJ',potEcomp(23) write (line1,'(i10,f15.2,8f12.3,i5,$)') & itime,totT,EK,potE+potEcomp(27),totE+potEcomp(27), @@ -489,7 +505,7 @@ C print *,'A CHUJ',potEcomp(23) format1="a114" endif else - if (refstr) then + if (refstr) then call rms_nac_nnc(rms,frac,frac_nn,co,.false.) write (line1,'(i10,f15.2,3f12.3,f7.2,4f6.3,3f12.3,i5,$)') & itime,totT,EK,potE+potEcomp(27),totE+potEcomp(27), @@ -501,8 +517,8 @@ C print *,'A CHUJ',potEcomp(23) & amax,kinetic_T,t_bath,gyrate(),me format1="a114" endif - endif - if(usampl.and.totT.gt.eq_time) then + endif + if(usampl.and.totT.gt.eq_time) then if (loc_qlike) then write(line2,'(i5,2f9.4,300f7.4)') iset,uconst,uconst_back, & (qfrag(ii1),ii1=1,nfrag),(qpair(ii2),ii2=1,npair), @@ -517,25 +533,25 @@ C print *,'A CHUJ',potEcomp(23) write(format2,'(a1,i3.3)') "a",23+7*nfrag+7*npair & +21*nfrag_back endif - else + else format2="a001" line2=' ' - endif - if (print_compon) then + endif + if (print_compon) then if(itime.eq.0) then write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2, - & ",100a12)" - write (istat,format) "#"," ", + & ",31a12)" + write (istat,format) "#","", & (ename(print_order(i)),i=1,nprint_ene) endif write(format,'(a1,a4,a1,a4,a10)') "(",format1,",",format2, - & ",100f12.3)" + & ",31f12.3)" write (istat,format) line1,line2, & (potEcomp(print_order(i)),i=1,nprint_ene) - else + else write(format,'(a1,a4,a1,a4,a1)') "(",format1,",",format2,")" write (istat,format) line1,line2 - endif + endif #if defined(AIX) call flush(istat) #else @@ -545,10 +561,11 @@ C print *,'A CHUJ',potEcomp(23) end c--------------------------------------------------------------- double precision function gyrate() - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.INTERACT' include 'COMMON.CHAIN' + integer i,ii,j double precision cen(3),rg do j=1,3 diff --git a/source/unres/src-HCD-5D/gradient_p.F b/source/unres/src-HCD-5D/gradient_p.F index 75192e9..adafa53 100644 --- a/source/unres/src-HCD-5D/gradient_p.F +++ b/source/unres/src-HCD-5D/gradient_p.F @@ -1,17 +1,24 @@ +#ifndef LBFGS subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' + include 'COMMON.CONTROL' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.VAR' include 'COMMON.INTERACT' include 'COMMON.FFIELD' include 'COMMON.MD' + include 'COMMON.QRESTR' include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm external ufparm integer uiparm(1) double precision urparm(1) - dimension x(n),g(n) + double precision x(n),g(n) + integer i,j,k,ind,ind1 + double precision f,gthetai,gphii,galphai,gomegai c c This subroutine calculates total internal coordinate gradient. c Depending on the number of function evaluations, either whole energy @@ -30,60 +37,12 @@ c write (iout,*) 'grad 20' if (nf.eq.0) return goto 40 30 call var_to_geom(n,x) - call chainbuild + call chainbuild_extconf c write (iout,*) 'grad 30' C -C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. -C - 40 call cartder -c write (iout,*) 'grad 40' -c print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon +C Transform the gradient to the gradient in angles. C -C Convert the Cartesian gradient into internal-coordinate gradient. -C - ind=0 - ind1=0 - do i=1,nres-2 - gthetai=0.0D0 - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 -c ind=indmat(i,j) -c print *,'GRAD: i=',i,' jc=',j,' ind=',ind - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - enddo - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - enddo - enddo - do j=i+1,nres-1 - ind1=ind1+1 -c ind1=indmat(i,j) -c print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1 - do k=1,3 - gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg) - gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg) - enddo - enddo - if (i.gt.1) g(i-1)=gphii - if (n.gt.nphi) g(nphi+i)=gthetai - enddo - if (n.le.nphi+ntheta) goto 10 - do i=2,nres-1 - if (itype(i).ne.10) then - galphai=0.0D0 - gomegai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ialph(i,1))=galphai - g(ialph(i,1)+nside)=gomegai - endif - enddo + 40 call cart2intgrad(n,g) C C Add the components corresponding to local energy terms. C @@ -109,7 +68,7 @@ cd write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n) end C------------------------------------------------------------------------- subroutine grad_restr(n,x,nf,g,uiparm,urparm,ufparm) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.DERIV' @@ -117,10 +76,14 @@ C------------------------------------------------------------------------- include 'COMMON.INTERACT' include 'COMMON.FFIELD' include 'COMMON.IOUNITS' + integer n,nf + double precision ufparm external ufparm integer uiparm(1) double precision urparm(1) - dimension x(maxvar),g(maxvar) + double precision x(maxvar),g(maxvar),gg(maxvar) + integer i,j,k,ig,ind,ij,igall + double precision f,gthetai,gphii,galphai,gomegai icg=mod(nf,2)+1 if (nf-nfl+1) 20,30,40 @@ -148,58 +111,33 @@ c write(iout,*) (var(i),i=1,nvar) C C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. C - 40 call cartder + 40 call cart2intgrad(n,gg) C C Convert the Cartesian gradient into internal-coordinate gradient. C ig=0 - ind=nres-2 + ind=nres-2 do i=2,nres-2 - IF (mask_phi(i+2).eq.1) THEN - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) - enddo - enddo + IF (mask_phi(i+2).eq.1) THEN ig=ig+1 - g(ig)=gphii - ELSE - ind=ind+nres-1-i + g(ig)=gg(i-1) ENDIF enddo - ind=0 do i=1,nres-2 IF (mask_theta(i+2).eq.1) THEN ig=ig+1 - gthetai=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) - enddo - enddo - g(ig)=gthetai - ELSE - ind=ind+nres-1-i + g(ig)=gg(nphi+i) ENDIF enddo do i=2,nres-1 - if (itype(i).ne.10) then + if (itype(i).ne.10) then IF (mask_side(i).eq.1) THEN ig=ig+1 - galphai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - g(ig)=galphai + g(ig)=gg(ialph(i,1)) ENDIF endif enddo @@ -209,11 +147,7 @@ C if (itype(i).ne.10) then IF (mask_side(i).eq.1) THEN ig=ig+1 - gomegai=0.0D0 - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ig)=gomegai + g(ig)=gg(ialph(i,1)+nside) ENDIF endif enddo @@ -257,21 +191,25 @@ cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) cd enddo return end +#endif C------------------------------------------------------------------------- subroutine cartgrad - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' #endif + include 'COMMON.CONTROL' include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.VAR' include 'COMMON.INTERACT' include 'COMMON.FFIELD' include 'COMMON.MD' + include 'COMMON.QRESTR' include 'COMMON.IOUNITS' include 'COMMON.TIME1' + integer i,j,kk c c This subrouting calculates total Cartesian coordinate gradient. c The subroutine chainbuild_cart and energy MUST be called beforehand. @@ -376,9 +314,73 @@ cd write(iout,*) 'calling int_to_cart' #endif return end +c--------------------------------------------------------------------------- +#ifdef FIVEDIAG + subroutine grad_transform + implicit none + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.TIME1' + integer i,j,kk +#ifdef DEBUG + write (iout,*)"Converting virtual-bond gradient to CA/SC gradient" + write (iout,*) "dC/dX gradient" + do i=0,nres + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo +#endif + do i=nres,1,-1 + do j=1,3 + gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i) +! gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i) + enddo +! write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), & +! (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3) + enddo +! Correction: dummy residues + do i=2,nres + if (itype(i-1).eq.ntyp1 .and. itype(i).ne.ntyp1) then + gcart(:,i)=gcart(:,i)+gcart(:,i-1) + else if (itype(i-1).ne.ntyp1 .and. itype(i).eq.ntyp1) then + gcart(:,i-1)=gcart(:,i-1)+gcart(:,i) + endif + enddo +c if (nnt.gt.1) then +c do j=1,3 +c gcart(j,nnt)=gcart(j,nnt)+gcart(j,1) +c enddo +c endif +c if (nct.lt.nres) then +c do j=1,3 +c! gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres) +c gcart(j,nct)=gcart(j,nct)+gcart(j,nres) +c enddo +c endif +#ifdef DEBUG + write (iout,*) "CA/SC gradient" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), + & (gxcart(j,i),j=1,3) + enddo +#endif + return + end +#endif C------------------------------------------------------------------------- subroutine zerograd - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.DERIV' include 'COMMON.CHAIN' @@ -386,6 +388,7 @@ C------------------------------------------------------------------------- include 'COMMON.MD' include 'COMMON.SCCOR' include 'COMMON.SHIELD' + integer i,j,kk,intertyp,maxshieldlist maxshieldlist=0 C C Initialize Cartesian-coordinate gradient @@ -461,14 +464,18 @@ C grad_shield_side_ca(j,kk,i)=0.0d0 do intertyp=1,3 gloc_sc(intertyp,i,icg)=0.0d0 enddo + enddo + enddo #ifndef DFA + do i=1,nres + do j=1,3 gdfad(j,i)=0.0d0 gdfat(j,i)=0.0d0 gdfan(j,i)=0.0d0 gdfab(j,i)=0.0d0 -#endif enddo enddo +#endif C C Initialize the gradient of local energy terms. C diff --git a/source/unres/src-HCD-5D/initialize_p.F b/source/unres/src-HCD-5D/initialize_p.F index dd473ed..c73426c 100644 --- a/source/unres/src-HCD-5D/initialize_p.F +++ b/source/unres/src-HCD-5D/initialize_p.F @@ -1,8 +1,16 @@ block data - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.MCM' - include 'COMMON.MD' +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif data MovTypID & /'pool','chain regrow','multi-bond','phi','theta','side chain', & 'total'/ @@ -14,7 +22,7 @@ c-------------------------------------------------------------------------- C C Define constants and zero out tables. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -37,13 +45,19 @@ cMS$ATTRIBUTES C :: proc_proc include 'COMMON.MINIM' include 'COMMON.DERIV' include 'COMMON.SPLITELE' + include 'COMMON.VAR' c Common blocks from the diagonalization routines + integer IR,IW,IP,IJK,IPK,IDAF,NAV,IODA,KDIAG,ICORFL,IXDR + integer i,idumm,j,k,l,ichir1,ichir2,iblock,m + double precision rr COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400) COMMON /MACHSW/ KDIAG,ICORFL,IXDR - logical mask_r c real*8 text1 /'initial_i'/ mask_r=.false. + mask_theta=1 + mask_phi=1 + mask_side=1 #ifndef ISNAN c NaNQ initialization i=-1 @@ -126,12 +140,12 @@ C input file for transfer sidechain and peptide group inside the C lipidic environment if lipid is implicite C DNA input files for parameters range 80-99 -C Suger input files for parameters range 100-119 +C Sugar input files for parameters range 100-119 C All-atom input files for parameters range 120-149 C C Set default weights of the energy terms. C - wlong=1.0D0 + wsc=1.0D0 welec=1.0D0 wtor =1.0D0 wang =1.0D0 @@ -291,8 +305,8 @@ C Initialize variables used in minimization. C c maxfun=5000 c maxit=2000 - maxfun=500 - maxit=200 + maxfun=1000 + maxmin=500 tolf=1.0D-2 rtolf=5.0D-4 C @@ -300,6 +314,7 @@ C Initialize the variables responsible for the mode of gradient storage. C nfl=0 icg=1 + sideonly=.false. C C Initialize constants used to split the energy into long- and short-range C components @@ -313,7 +328,7 @@ C rlamb=0.3d0 end c------------------------------------------------------------------------- block data nazwy - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.NAMES' include 'COMMON.FFIELD' @@ -413,13 +428,15 @@ c------------------------------------------------------------------------- end c--------------------------------------------------------------------------- subroutine init_int_table - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' + integer ierr,ierror integer blocklengths(15),displs(15) #endif include 'COMMON.CONTROL' + include 'COMMON.SAXS' include 'COMMON.SETUP' include 'COMMON.CHAIN' include 'COMMON.INTERACT' @@ -428,7 +445,12 @@ c--------------------------------------------------------------------------- include 'COMMON.TORCNSTR' include 'COMMON.IOUNITS' include 'COMMON.DERIV' - include 'COMMON.CONTACTS' + include 'COMMON.CORRMAT' + integer iturn3_start_all,iturn3_end_all,iturn4_start_all, + & iturn4_end_all,iatel_s_all, + & iatel_e_all,ielstart_all,ielend_all,ntask_cont_from_all, + & itask_cont_from_all,ntask_cont_to_all,itask_cont_to_all, + & n_sc_int_tot,my_sc_inds,my_sc_inde,ind_sctint,ind_scint_old common /przechowalnia/ iturn3_start_all(0:max_fg_procs), & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs), & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs), @@ -440,15 +462,23 @@ c--------------------------------------------------------------------------- & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1) integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP logical scheck,lprint,flag + integer i,j,k,ii,jj,iint,npept,nele_int_tot,ind_eleint,ind_scint, + & my_ele_inds,my_ele_inde,ind_eleint_old,nele_int_tot_vdw, + & my_ele_inds_vdw,my_ele_inde_vdw,ind_eleint_vdw,ijunk, + & ind_eleint_vdw_old,nscp_int_tot,my_scp_inds,my_scp_inde, + & ind_scpint,ind_scpint_old,nsumgrad,nlen,ngrad_start,ngrad_end, + & iaux,ind_typ,ncheck_from,ncheck_to,ichunk #ifdef MPI integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs), & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs) C... Determine the numbers of start and end SC-SC interaction C... to deal with by current processor. +#ifdef FOURBODY do i=0,nfgtasks-1 itask_cont_from(i)=fg_rank itask_cont_to(i)=fg_rank enddo +#endif lprint=energy_dec if (lprint) &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct @@ -866,6 +896,7 @@ c nlen=nres-nnt+1 enddo call flush(iout) endif +#ifdef FOURBODY ntask_cont_from=0 ntask_cont_to=0 itask_cont_from(0)=fg_rank @@ -1066,6 +1097,7 @@ c call flush(iout) call MPI_Group_free(fg_group,ierr) call MPI_Group_free(cont_from_group,ierr) call MPI_Group_free(cont_to_group,ierr) +#endif call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR) call MPI_Type_commit(MPI_UYZ,IERROR) call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD, @@ -1442,12 +1474,13 @@ c--------------------------------------------------------------------------- end c--------------------------------------------------------------------------- subroutine int_bounds(total_ints,lower_bound,upper_bound) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'mpif.h' include 'COMMON.SETUP' integer total_ints,lower_bound,upper_bound integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs) + integer i,nint,nexcess nint=total_ints/nfgtasks do i=1,nfgtasks int4proc(i-1)=nint @@ -1466,12 +1499,13 @@ c--------------------------------------------------------------------------- end c--------------------------------------------------------------------------- subroutine int_bounds1(total_ints,lower_bound,upper_bound) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'mpif.h' include 'COMMON.SETUP' integer total_ints,lower_bound,upper_bound integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs) + integer i,nint,nexcess nint=total_ints/nfgtasks1 do i=1,nfgtasks1 int4proc(i-1)=nint @@ -1491,11 +1525,11 @@ c--------------------------------------------------------------------------- c--------------------------------------------------------------------------- subroutine int_partition(int_index,lower_index,upper_index,atom, & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' integer int_index,lower_index,upper_index,atom,at_start,at_end, - & first_atom,last_atom,int_gr,jat_start,jat_end + & first_atom,last_atom,int_gr,jat_start,jat_end,int_index_old logical lprn lprn=.false. if (lprn) write (iout,*) 'int_index=',int_index @@ -1531,7 +1565,7 @@ c--------------------------------------------------------------------------- #endif c------------------------------------------------------------------------------ subroutine hpb_partition - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -1553,7 +1587,7 @@ c------------------------------------------------------------------------------ end c------------------------------------------------------------------------------ subroutine homology_partition - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -1562,8 +1596,8 @@ c------------------------------------------------------------------------------ include 'COMMON.IOUNITS' include 'COMMON.SETUP' include 'COMMON.CONTROL' - include 'COMMON.MD' include 'COMMON.INTERACT' + include 'COMMON.HOMOLOGY' cd write(iout,*)"homology_partition: lim_odl=",lim_odl, cd & " lim_dih",lim_dih #ifdef MPI @@ -1596,7 +1630,7 @@ cd & " lim_dih",lim_dih end c------------------------------------------------------------------------------ subroutine NMRpeak_partition - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' diff --git a/source/unres/src-HCD-5D/int_to_cart.f b/source/unres/src-HCD-5D/int_to_cart.f index d5ea38a..bf259c8 100644 --- a/source/unres/src-HCD-5D/int_to_cart.f +++ b/source/unres/src-HCD-5D/int_to_cart.f @@ -3,7 +3,7 @@ c-------------------------------------------------------------- c This subroutine converts the energy derivatives from internal c coordinates to cartesian coordinates c------------------------------------------------------------- - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.CHAIN' @@ -15,6 +15,7 @@ c------------------------------------------------------------- include 'COMMON.IOUNITS' include 'COMMON.SCCOR' include 'COMMON.CONTROL' + integer i,j c calculating dE/ddc1 C print *,"wchodze22",ialph(2,1) if (nres.lt.3) go to 18 diff --git a/source/unres/src-HCD-5D/intcor.f b/source/unres/src-HCD-5D/intcor.f index 60c952b..280b484 100644 --- a/source/unres/src-HCD-5D/intcor.f +++ b/source/unres/src-HCD-5D/intcor.f @@ -5,7 +5,11 @@ C c c Calculates the planar angle between atoms (i1), (i2), and (i3). c - implicit real*8 (a-h,o-z) + implicit none + integer i1,i2,i3 + double precision x12,x23,y12,y23,z12,z23,vnorm,wnorm,scalar,angle + double precision arcos + external arcos include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.CHAIN' @@ -17,8 +21,8 @@ c z23=c(3,i3)-c(3,i2) vnorm=dsqrt(x12*x12+y12*y12+z12*z12) wnorm=dsqrt(x23*x23+y23*y23+z23*z23) - if ((vnorm.eq.0.0).or.(wnorm.eq.0.0)) then - scalar=1.0 + if ((vnorm.eq.0.0d0).or.(wnorm.eq.0.0d0)) then + scalar=1.0d0 else scalar=(x12*x23+y12*y23+z12*z23)/(vnorm*wnorm) endif @@ -32,7 +36,10 @@ C c c Calculates the dihedral angle between atoms (i1), (i2), (i3) and (i4) c - implicit real*8 (a-h,o-z) + implicit none + integer i1,i2,i3,i4 + double precision x12,x23,x34,y12,y23,y34,z12,z23,z34,vnorm,wnorm, + & vx,vy,vz,wx,wy,wz,tx,ty,tz,scalar,angle include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.CHAIN' @@ -82,7 +89,9 @@ C c c Calculates the distance between atoms (i1) and (i2). c - implicit real*8 (a-h,o-z) + implicit none + integer i1,i2 + double precision x12,y12,z12 include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.CHAIN' diff --git a/source/unres/src-HCD-5D/intlocal.f b/source/unres/src-HCD-5D/intlocal.f deleted file mode 100644 index 2dbcc88..0000000 --- a/source/unres/src-HCD-5D/intlocal.f +++ /dev/null @@ -1,517 +0,0 @@ - subroutine integral(gamma1,gamma2,gamma3,gamma4,ity1,ity2,a1,a2, - & si1,si2,si3,si4,transp,q) - implicit none - integer ity1,ity2 - integer ilam1,ilam2,ilam3,ilam4,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4 - logical transp - double precision elocal,ele - double precision delta,delta2,sum,ene,sumene,boltz - double precision q,a1(2,2),a2(2,2),si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=20 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) gamma1,gamma2,ity1,ity2,a1,a2,si1,si2,si3,si4,transp - -cd do ilam1=-180,180,5 -cd do ilam2=-180,180,5 -cd lambda1=ilam1*conv+delta2 -cd lambda2=ilam2*conv+delta2 -cd write(2,'(2i5,2f10.5)') ilam1,ilam2,elocal(2,lambda1,lambda2), -cd & ele(lambda1,lambda2,a1,1.0d0,1.d00) -cd enddo -cd enddo -cd stop - - sum=0.0d0 - sumene=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 -cd write (2,*) ilam1,ilam2,ilam3,ilam4 -cd write (2,*) lambda1,lambda2,lambda3,lambda4 - ene= - & -elocal(ity1,lambda1,lambda2,.false.)* - & elocal(ity2,lambda3,lambda4,transp)* - & ele(si1*lambda1+gamma1,si3*lambda3+gamma3,a1)* - & ele(si2*lambda2+gamma2,si4*lambda4+gamma4,a2) -cd write (2,*) elocal(ity1,lambda1,gamma1-pi-lambda2), -cd & elocal(ity2,lambda3,gamma2-pi-lambda4), -cd & ele(lambda1,lambda2,a1,si1,si3), -cd & ele(lambda3,lambda4,a2,si2,si4) - sum=sum+ene - enddo - enddo - enddo - enddo - q=sum/(2*pi)**4*delta**4 - write (2,* )'sum',sum,' q',q - return - end -c--------------------------------------------------------------------------- - subroutine integral3(gamma1,gamma2,ity1,ity2,ity3,ity4, - & a1,koniec,q1,q2,q3,q4) - implicit none - integer ity1,ity2,ity3,ity4 - integer ilam1,ilam2,ilam3,ilam4,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,lambda1, - & lambda2,lambda3,lambda4 - logical koniec - double precision elocal,ele - double precision delta,delta2,sum1,sum2,sum3,sum4, - & ene1,ene2,ene3,ene4,boltz - double precision q1,q2,q3,q4,a1(2,2),a2(2,2) - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta - write(2,*) gamma1,gamma2,ity1,ity2,ity3,ity4,a1,koniec - -cd do ilam1=-180,180,5 -cd do ilam2=-180,180,5 -cd lambda1=ilam1*conv+delta2 -cd lambda2=ilam2*conv+delta2 -cd write(2,'(2i5,2f10.5)') ilam1,ilam2,elocal(2,lambda1,lambda2), -cd & ele(lambda1,lambda2,a1,1.0d0,1.d00) -cd enddo -cd enddo -cd stop - - sum1=0.0d0 - sum2=0.0d0 - sum3=0.0d0 - sum4=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 -cd write (2,*) ilam1,ilam2,ilam3,ilam4 -cd write (2,*) lambda1,lambda2,lambda3,lambda4 - if (.not.koniec) then - ene1= - & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)* - & elocal(ity3,lambda3,gamma2-pi-lambda4,.false.)* - & ele(lambda2,lambda4,a1) - else - ene1= - & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)* - & elocal(ity3,lambda3,lambda4,.false.)* - & ele(lambda2,-lambda4,a1) - endif - ene2= - & elocal(ity1,lambda1,gamma1-pi-lambda2,.false.)* - & elocal(ity4,lambda3,lambda4,.false.)* - & ele(lambda2,lambda3,a1) - if (.not.koniec) then - ene3= - & elocal(ity2,lambda1,lambda2,.false.)* - & elocal(ity3,lambda3,gamma2-pi-lambda4,.false.)* - & ele(lambda1,lambda4,a1) - else - ene3= - & elocal(ity2,lambda1,lambda2,.false.)* - & elocal(ity3,lambda3,lambda4,.false.)* - & ele(lambda1,-lambda4,a1) - endif - ene4= - & elocal(ity2,lambda1,lambda2,.false.)* - & elocal(ity4,lambda3,lambda4,.false.)* - & ele(lambda1,lambda3,a1) - sum1=sum1+ene1 - sum2=sum2+ene2 - sum3=sum3+ene3 - sum4=sum4+ene4 - enddo - enddo - enddo - enddo - q1=sum1/(2*pi)**4*delta**4 - q2=sum2/(2*pi)**4*delta**4 - q3=sum3/(2*pi)**4*delta**4 - q4=sum4/(2*pi)**4*delta**4 - write (2,* )'sum',sum1,sum2,sum3,sum4,' q',q1,q2,q3,q4 - return - end -c------------------------------------------------------------------------- - subroutine integral5(gamma1,gamma2,gamma3,gamma4,ity1,ity2,ity3, - & ity4,ity5,ity6,a1,a2,si1,si2,si3,si4,transp,ene1,ene2,ene3,ene4) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc5,eloc6,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,sum1,sum2,sum3,sum4, - & a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, -cd & ' gamma3=',gamma3,' gamma4=',gamma4 -cd write(2,*) ity1,ity2,ity3,ity4,ity5,ity6 -cd write(2,*) 'a1=',a1 -cd write(2,*) 'a2=',a2 -cd write(2,*) si1,si2,si3,si4,transp - - sum1=0.0d0 - sum2=0.0d0 - sum3=0.0d0 - sum4=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - do ilam5=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - lambda5=ilam5*conv+delta2 - if (transp) then - ele1=ele(lambda1,si4*lambda4,a1) - ele2=ele(lambda2,lambda3,a2) - else - ele1=ele(lambda1,lambda3,a1) - ele2=ele(lambda2,si4*lambda4,a2) - endif - eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.) - eloc5=elocal(ity5,lambda3,gamma4-pi-si4*lambda4,.false.) - pom=ele1*ele2*eloc2*eloc5 - if (si1.gt.0) then - eloc1=elocal(ity1,lambda5,gamma1-pi-lambda1,.false.) - sum1=sum1+pom*eloc1 - endif - eloc3=elocal(ity3,lambda2,lambda5,.false.) - sum2=sum2+pom*eloc3 - eloc4=elocal(ity4,lambda5,gamma3-pi-lambda3,.false.) - sum3=sum3+pom*eloc4 - if (si4.gt.0) then - eloc6=elocal(ity6,lambda4,lambda5,.false.) - sum4=sum4+pom*eloc6 - endif - enddo - enddo - enddo - enddo - enddo - pom=1.0d0/(2*pi)**5*delta**5 - ene1=sum1*pom - ene2=sum2*pom - ene3=sum3*pom - ene4=sum4*pom -c write (2,* )'sum',sum1,sum2,sum3,sum4,' q',ene1,ene2,ene3,ene4 - return - end -c------------------------------------------------------------------------- - subroutine integral_turn6(gamma1,gamma2,gamma3,gamma4,ity1,ity2, - & ity3,ity4,ity5,ity6,a1,a2,ene_turn6) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom,ene5 - double precision ene_turn6,sum5,a1(2,2),a2(2,2) - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta - write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, - & ' gamma3=',gamma3,' gamma4=',gamma4 - write(2,*) ity1,ity2,ity3,ity4,ity5,ity6 - write(2,*) 'a1=',a1 - write(2,*) 'a2=',a2 - - sum5=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - do ilam5=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - lambda5=ilam5*conv+delta2 - ele1=ele(lambda1,-lambda4,a1) - ele2=ele(lambda2,lambda3,a2) - eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.) - eloc5=elocal(ity5,lambda3,lambda4,.false.) - pom=ele1*ele2*eloc2*eloc5 - eloc3=elocal(ity3,lambda2,gamma3-pi-lambda5,.false.) - eloc4=elocal(ity4,lambda5,gamma4-pi-lambda3,.false.) - sum5=sum5+pom*eloc3*eloc4 - enddo - enddo - enddo - enddo - enddo - pom=-1.0d0/(2*pi)**5*delta**5 - ene_turn6=sum5*pom -c print *,'sum6',sum6,' ene6',ene6 - return - end -c------------------------------------------------------------------------- - subroutine integral6(gamma1,gamma2,gamma3,gamma4,ity1,ity2,ity3, - & ity4,ity5,ity6,a1,a2,si1,si2,si3,si4,transp,ene1,ene2,ene3,ene4, - & ene5,ene6) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3, - & sum4,sum5,sum6,a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, -cd & ' gamma3=',gamma3,' gamma4=',gamma4 -cd write(2,*) ity1,ity2,ity3,ity4,ity5,ity6 -cd write(2,*) 'a1=',a1 -cd write(2,*) 'a2=',a2 -cd write(2,*) si1,si2,si3,si4,transp - - sum1=0.0d0 - sum2=0.0d0 - sum3=0.0d0 - sum4=0.0d0 - sum5=0.0d0 - sum6=0.0d0 - eloc1=0.0d0 - eloc6=0.0d0 - eloc61=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - do ilam5=-180,179,iincr - do ilam6=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - lambda5=ilam5*conv+delta2 - lambda6=ilam6*conv+delta2 - if (transp) then - ele1=ele(lambda1,si4*lambda4,a1) - ele2=ele(lambda2,lambda3,a2) - else - ele1=ele(lambda1,lambda3,a1) - ele2=ele(lambda2,si4*lambda4,a2) - endif - eloc2=elocal(ity2,lambda1,gamma2-pi-lambda2,.false.) - eloc5=elocal(ity5,lambda3,gamma4-pi-si4*lambda4,.false.) - pom=ele1*ele2*eloc2*eloc5 - if (si1.gt.0) then - eloc1=elocal(ity1,lambda5,gamma1-pi-lambda1,.false.) - endif - eloc3=elocal(ity3,lambda2,lambda6,.false.) - sum1=sum1+pom*eloc1*eloc3 - eloc4=elocal(ity4,lambda5,gamma3-pi-lambda3,.false.) - if (si4.gt.0) then - eloc6=elocal(ity6,lambda4,lambda6,.false.) - eloc61=elocal(ity6,lambda4,lambda5,.false.) - endif - sum2=sum2+pom*eloc4*eloc6 - eloc41=elocal(ity4,lambda6,gamma3-pi-lambda3,.false.) - sum3=sum3+pom*eloc1*eloc41 - sum4=sum4+pom*eloc1*eloc6 - sum5=sum5+pom*eloc3*eloc4 - sum6=sum6+pom*eloc3*eloc61 - enddo - enddo - enddo - enddo - enddo - enddo - pom=-1.0d0/(2*pi)**6*delta**6 - ene1=sum1*pom - ene2=sum2*pom - ene3=sum3*pom - ene4=sum4*pom - ene5=sum5*pom - ene6=sum6*pom -c print *,'sum6',sum6,' ene6',ene6 - return - end -c------------------------------------------------------------------------- - subroutine integral3a(gamma1,gamma2,ity1,ity2,a1,si1,ene1) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3, - & sum4,sum5,sum6,a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2 -cd write(2,*) ity1,ity2 -cd write(2,*) 'a1=',a1 -cd write(2,*) si1, - - sum1=0.0d0 - eloc1=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - ele1=ele(lambda1,si1*lambda3,a1) - eloc1=elocal(ity1,lambda1,gamma1-pi-lambda2,.false.) - if (si1.gt.0) then - eloc2=elocal(ity2,lambda2,gamma2-pi-lambda3,.false.) - else - eloc2=elocal(ity2,lambda2,lambda3,.false.) - endif - sum1=sum1+ele1*eloc1*eloc2 - enddo - enddo - enddo - pom=1.0d0/(2*pi)**3*delta**3 - ene1=sum1*pom - return - end -c------------------------------------------------------------------------- - subroutine integral4a(gamma1,gamma2,gamma3,ity1,ity2,ity3,a1,si1, - & ene1) - implicit none - integer ity1,ity2,ity3,ity4,ity5,ity6 - integer ilam1,ilam2,ilam3,ilam4,ilam5,ilam6,iincr - double precision gamma1,gamma2,gamma3,gamma4,beta,b(2,90),lambda1, - & lambda2,lambda3,lambda4,lambda5,lambda6 - logical transp - double precision elocal,ele - double precision eloc1,eloc2,eloc3,eloc4,eloc41,eloc5,eloc6, - & eloc61,ele1,ele2 - double precision delta,delta2,sum,ene,sumene,pom - double precision ene1,ene2,ene3,ene4,ene5,ene6,sum1,sum2,sum3, - & sum4,sum5,sum6,a1(2,2),a2(2,2) - integer si1,si2,si3,si4 - double precision conv /.01745329252d0/,pi /3.141592654d0/ - - iincr=60 - delta=iincr*conv - delta2=0.5d0*delta -cd print *,'iincr',iincr,' delta',delta -cd write(2,*) 'gamma1=',gamma1,' gamma2=',gamma2, -cd & ' gamma3=',gamma3 -cd write(2,*) ity1,ity2,ity3 -cd write(2,*) 'a1=',a1 -cd write(2,*) 'si1=',si1 - sum1=0.0d0 - do ilam1=-180,179,iincr - do ilam2=-180,179,iincr - do ilam3=-180,179,iincr - do ilam4=-180,179,iincr - lambda1=ilam1*conv+delta2 - lambda2=ilam2*conv+delta2 - lambda3=ilam3*conv+delta2 - lambda4=ilam4*conv+delta2 - ele1=ele(lambda1,si1*lambda4,a1) - eloc1=elocal(ity1,lambda1,gamma1-pi-lambda2,.false.) - eloc2=elocal(ity2,lambda2,gamma2-pi-lambda3,.false.) - if (si1.gt.0) then - eloc3=elocal(ity3,lambda3,gamma3-pi-lambda4,.false.) - else - eloc3=elocal(ity3,lambda3,lambda4,.false.) - endif - sum1=sum1+ele1*eloc1*eloc2*eloc3 - enddo - enddo - enddo - enddo - pom=-1.0d0/(2*pi)**4*delta**4 - ene1=sum1*pom - return - end -c------------------------------------------------------------------------- - double precision function elocal(i,x,y,transp) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.TORSION' - integer i - double precision x,y,u(2),v(2),cu(2),dv(2),ev(2) - double precision scalar2 - logical transp - u(1)=dcos(x) - u(2)=dsin(x) - v(1)=dcos(y) - v(2)=dsin(y) - if (transp) then - call matvec2(cc(1,1,i),v,cu) - call matvec2(dd(1,1,i),u,dv) - call matvec2(ee(1,1,i),u,ev) - elocal=scalar2(b1(1,i),v)+scalar2(b2(1,i),u)+scalar2(cu,v)+ - & scalar2(dv,u)+scalar2(ev,v) - else - call matvec2(cc(1,1,i),u,cu) - call matvec2(dd(1,1,i),v,dv) - call matvec2(ee(1,1,i),v,ev) - elocal=scalar2(b1(1,i),u)+scalar2(b2(1,i),v)+scalar2(cu,u)+ - & scalar2(dv,v)+scalar2(ev,u) - endif - return - end -c------------------------------------------------------------------------- - double precision function ele(x,y,a) - implicit none - double precision x,y,a(2,2),si1,si2,u(2),v(2),av(2) - double precision scalar2 - u(1)=-cos(x) - u(2)= sin(x) - v(1)=-cos(y) - v(2)= sin(y) - call matvec2(a,v,av) - ele=scalar2(u,av) - return - end diff --git a/source/unres/src-HCD-5D/kinetic_lesyng.f b/source/unres/src-HCD-5D/kinetic_lesyng.f deleted file mode 100644 index db959b3..0000000 --- a/source/unres/src-HCD-5D/kinetic_lesyng.f +++ /dev/null @@ -1,104 +0,0 @@ - subroutine kinetic(KE_total) -c---------------------------------------------------------------- -c This subroutine calculates the total kinetic energy of the chain -c----------------------------------------------------------------- - 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' - include 'COMMON.IOUNITS' - double precision KE_total - - integer i,j,k - double precision KEt_p,KEt_sc,KEr_p,KEr_sc,incr(3), - & mag1,mag2,v(3) - - KEt_p=0.0d0 - KEt_sc=0.0d0 -c write (iout,*) "ISC",(isc(itype(i)),i=1,nres) -c The translational part for peptide virtual bonds - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct-1 -c write (iout,*) "Kinetic trp:",i,(incr(j),j=1,3) - do j=1,3 - v(j)=incr(j)+0.5d0*d_t(j,i) - enddo - vtot(i)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) - KEt_p=KEt_p+(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - enddo -c write(iout,*) 'KEt_p', KEt_p -c The translational part for the side chain virtual bond -c Only now we can initialize incr with zeros. It must be equal -c to the velocities of the first Calpha. - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct - iti=iabs(itype(i)) - if (itype(i).eq.10) then - do j=1,3 - v(j)=incr(j) - enddo - else - do j=1,3 - v(j)=incr(j)+d_t(j,nres+i) - enddo - endif -c write (iout,*) "Kinetic trsc:",i,(incr(j),j=1,3) -c write (iout,*) "i",i," msc",msc(iti)," v",(v(j),j=1,3) - KEt_sc=KEt_sc+msc(iti)*(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) - vtot(i+nres)=v(1)*v(1)+v(2)*v(2)+v(3)*v(3) - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - enddo -c goto 111 -c write(iout,*) 'KEt_sc', KEt_sc -c The part due to stretching and rotation of the peptide groups - KEr_p=0.0D0 - do i=nnt,nct-1 -c write (iout,*) "i",i -c write (iout,*) "i",i," mag1",mag1," mag2",mag2 - do j=1,3 - incr(j)=d_t(j,i) - enddo -c write (iout,*) "Kinetic rotp:",i,(incr(j),j=1,3) - KEr_p=KEr_p+(incr(1)*incr(1)+incr(2)*incr(2) - & +incr(3)*incr(3)) - enddo -c goto 111 -c write(iout,*) 'KEr_p', KEr_p -c The rotational part of the side chain virtual bond - KEr_sc=0.0D0 - do i=nnt,nct - iti=iabs(itype(i)) - if (itype(i).ne.10) then - do j=1,3 - incr(j)=d_t(j,nres+i) - enddo -c write (iout,*) "Kinetic rotsc:",i,(incr(j),j=1,3) - KEr_sc=KEr_sc+Isc(iti)*(incr(1)*incr(1)+incr(2)*incr(2)+ - & incr(3)*incr(3)) - endif - enddo -c The total kinetic energy - 111 continue -c write(iout,*) 'KEr_sc', KEr_sc - KE_total=0.5d0*(mp*KEt_p+KEt_sc+0.25d0*Ip*KEr_p+KEr_sc) -c write (iout,*) "KE_total",KE_total - return - end - - - - diff --git a/source/unres/src-HCD-5D/lagrangian_lesyng.F b/source/unres/src-HCD-5D/lagrangian_lesyng.F index 024c6d1..f57a432 100644 --- a/source/unres/src-HCD-5D/lagrangian_lesyng.F +++ b/source/unres/src-HCD-5D/lagrangian_lesyng.F @@ -4,10 +4,11 @@ c This subroutine contains the total lagrangain from which the accelerations c are obtained. For numerical gradient checking, the derivetive of the c lagrangian in the velocities and coordinates are calculated seperately c------------------------------------------------------------------------- - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' + integer time00 #endif include 'COMMON.VAR' include 'COMMON.CHAIN' @@ -16,6 +17,20 @@ c------------------------------------------------------------------------- include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif include 'COMMON.IOUNITS' include 'COMMON.CONTROL' include 'COMMON.MUCA' @@ -24,11 +39,185 @@ c------------------------------------------------------------------------- integer i,j,ind double precision zapas(MAXRES6),muca_factor logical lprn /.false./ + integer itime common /cipiszcze/ itime +#ifdef FIVEDIAG + double precision rs(maxres2_chain),xsolv(maxres2_chain),ip4 + double precision aaux(3) + integer nind,innt,inct,inct_prev,ichain,n,mark +#ifdef CHECK5DSOL + double precision rscheck(maxres2_chain),rsold(maxres2_chain) +#endif +#endif #ifdef TIMING time00=MPI_Wtime() #endif +#ifdef FIVEDIAG + call grad_transform + d_a=0.0d0 + if (lprn) then + write (iout,*) "Potential forces backbone" + do i=1,nres + write (iout,'(i5,3e15.5,5x,3e15.5)')i,(-gcart(j,i),j=1,3) + enddo + write (iout,*) "Potential forces sidechain" + do i=nnt,nct +! if (itype(i).ne.10 .and. itype(i).ne.ntyp1) & + write (iout,'(i5,3e15.5,5x,3e15.5)') i,(-gxcart(j,i),j=1,3) + enddo + endif + do ichain=1,nchain + n=dimen_chain(ichain) + innt=iposd_chain(ichain) + do j=1,3 + ind=1 + do i=chain_border(1,ichain),chain_border(2,ichain) + if (itype(i).eq.10)then + rs(ind)=-gcart(j,i)-gxcart(j,i) + ind=ind+1 + else + rs(ind)=-gcart(j,i) + rs(ind+1)=-gxcart(j,i) + ind=ind+2 + end if + enddo +#ifdef CHECK5DSOL + rsold=rs +#endif + if (lprn) then + write(iout,*) + & "RHS of the 5-diag equations system, chain",ichain," j",j + do i=1,n + write(iout,'(i5,f10.5)') i,rs(i) + enddo + endif + call FDISYS (n,DM(innt),DU1(innt),DU2(innt),rs,xsolv) + if (lprn) then + write (iout,*) "Solution of the 5-diagonal equations system" + do i=1,n + write (iout,'(i5,f10.5)') i,xsolv(i) + enddo + endif +#ifdef CHECK5DSOL +! Check the solution + call fivediagmult(n,DMorig(innt),DU1orig(innt),DU2orig(innt), + & xsolv,rscheck) + do i=1,n + write(iout,*) "i",i,"rsold",rsold(i),"rscheck",rscheck(i), + & "ratio",rscheck(i)/rsold(i) + enddo +! end check +#endif +#undef CHECK5DSOL + ind=1 + do i=chain_border(1,ichain),chain_border(2,ichain) + if (itype(i).eq.10) then + d_a(j,i)=xsolv(ind) + ind=ind+1 + else + d_a(j,i)=xsolv(ind) + d_a(j,i+nres)=xsolv(ind+1) + ind=ind+2 + end if + enddo + enddo ! j + enddo ! ichain + if (lprn) then + write (iout,*) "Acceleration in CA and SC oordinates" + do i=1,nres + write (iout,'(i3,3f10.5)') i,(d_a(j,i),j=1,3) + enddo + do i=nnt,nct + write (iout,'(i3,3f10.5)') i,(d_a(j,i+nres),j=1,3) + enddo + endif +C Conevert d_a to virtual-bon-vector basis +#define WLOS +#ifdef WLOS +c write (iout,*) "WLOS" + if (nnt.eq.1) then + d_a(:,0)=d_a(:,1) + endif + do i=1,nres + if (itype(i).eq.10 .or. itype(i).eq.ntyp1) then + do j=1,3 + d_a(j,i)=d_a(j,i+1)-d_a(j,i) + enddo + else + do j=1,3 + d_a(j,i+nres)=d_a(j,i+nres)-d_a(j,i) + d_a(j,i)=d_a(j,i+1)-d_a(j,i) + enddo + end if + enddo + d_a(:,nres)=0.0d0 + d_a(:,nct)=0.0d0 + d_a(:,2*nres)=0.0d0 +c d_a(:,0)=d_a(:,1) +c d_a(:,1)=0.0d0 +c write (iout,*) "Shifting accelerations" + if (nnt.gt.1) then + d_a(:,0)=d_a(:,1) + d_a(:,1)=0.0d0 + endif +#define CHUJ +#ifdef CHUJ + do ichain=2,nchain +c write (iout,*) "ichain",chain_border1(1,ichain)-1, +c & chain_border1(1,ichain) + d_a(:,chain_border1(1,ichain)-1)=d_a(:,chain_border1(1,ichain)) + d_a(:,chain_border1(1,ichain))=0.0d0 + enddo +c write (iout,*) "Adding accelerations" + do ichain=2,nchain +c write (iout,*) "chain",ichain,chain_border1(1,ichain)-1, +c & chain_border(2,ichain-1) + d_a(:,chain_border1(1,ichain)-1)= + & d_a(:,chain_border1(1,ichain)-1)+d_a(:,chain_border(2,ichain-1)) + d_a(:,chain_border(2,ichain-1))=0.0d0 + enddo +#endif +#else + inct_prev=0 + do j=1,3 + aaux(j)=0.0d0 + enddo + do ichain=1,nchain + innt=chain_border(1,ichain) + inct=chain_border(2,ichain) + do j=1,3 + d_a(j,inct_prev)=d_a(j,innt)-aaux(j) + enddo + inct_prev=inct+1 + do i=innt,inct + if (itype(i).ne.10) then + do j=1,3 + d_a(j,i+nres)=d_a(j,i+nres)-d_a(j,i) + enddo + endif + enddo + do j=1,3 + aaux(j)=d_a(j,inct) + enddo + do i=innt,inct + do j=1,3 + d_a(j,i)=d_a(j,i+1)-d_a(j,i) + enddo + enddo + enddo +#endif + if (lprn) then + write(iout,*) 'acceleration 3D FIVEDIAG in dC and dX' + do i=0,nres + write (iout,'(i3,3f10.5,3x,3f10.5)') i,(d_a(j,i),j=1,3) + enddo + do i=nnt,nct + write (iout,'(i3,3f10.5,3x,3f10.5)') + & i,(d_a(j,i+nres),j=1,3) + enddo + endif +#else do j=1,3 zapas(j)=-gcart(j,0) enddo @@ -110,19 +299,22 @@ cd print *,'lmuca ',factor,potE & i+nres,(d_a(j,i+nres),j=1,3) enddo endif +#endif #ifdef TIMING time_lagrangian=time_lagrangian+MPI_Wtime()-time00 #endif return - end + end c------------------------------------------------------------------ subroutine setup_MD_matrices - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' - integer ierror + integer ierror,ierr + double precision time00 #endif + include 'COMMON.CONTROL' include 'COMMON.SETUP' include 'COMMON.VAR' include 'COMMON.CHAIN' @@ -131,30 +323,206 @@ c------------------------------------------------------------------ include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.IOUNITS' include 'COMMON.TIME1' - integer i,j + integer i,j,k,m,m1,ind,ind1,ii,iti,ii1,jj + double precision coeff logical lprn /.false./ logical osob - double precision dtdi,massvec(maxres2),Gcopy(maxres2,maxres2), - & Ghalf(mmaxres2),sqreig(maxres2) + double precision dtdi,massvec(maxres2) +#ifdef FIVEDIAG + integer ichain,innt,inct,nind,mark,n + double precision ip4 +#else + double precision Gcopy(maxres2,maxres2),Ghalf(mmaxres2), + & sqreig(maxres2) double precision work(8*maxres6) integer iwork(maxres6) common /przechowalnia/ Gcopy,Ghalf +#endif c c Set up the matrix of the (dC,dX)-->(C,X) transformation (A), the c inertia matrix (Gmat) and the inverse of the inertia matrix (Ginv) c c Determine the number of degrees of freedom (dimen) and the number of c sites (dimen1) +#ifdef FIVEDIAG + dimen=0 + dimen1=0 + do ichain=1,nchain + dimen=dimen+chain_length(ichain) + dimen1=dimen1+2*chain_length(ichain)-1 + dimenp=dimenp+chain_length(ichain)-1 + enddo + write (iout,*) "Number of Calphas",dimen + write (iout,*) "Number of sidechains",nside + write (iout,*) "Number of peptide groups",dimenp + dimen=dimen+nside ! number of centers + dimen3=3*dimen ! degrees of freedom + write (iout,*) "Number of centers",dimen + write (iout,*) "Degrees of freedom:",dimen3 + ip4=ip/4 + ind=1 + do ichain=1,nchain + iposd_chain(ichain)=ind + innt=chain_border(1,ichain) + inct=chain_border(2,ichain) + DM(ind)=mp/4+ip4 + if (iabs(itype(innt)).eq.10) then + DM(ind)=DM(ind)+msc(10) + ind=ind+1 + nind=1 + else + DM(ind)=DM(ind)+isc(iabs(itype(innt))) + DM(ind+1)=msc(iabs(itype(innt)))+isc(iabs(itype(innt))) + ind=ind+2 + nind=2 + endif + write (iout,*) "ind",ind," nind",nind + do i=innt+1,inct-1 +! if (iabs(itype(i)).eq.ntyp1) cycle + DM(ind)=2*ip4+mp/2 + if (iabs(itype(i)).eq.10) then + if (iabs(itype(i)).eq.10) DM(ind)=DM(ind)+msc(10) + ind=ind+1 + nind=nind+1 + else + DM(ind)=DM(ind)+isc(iabs(itype(i))) + DM(ind+1)=msc(iabs(itype(i)))+isc(iabs(itype(i))) + ind=ind+2 + nind=nind+2 + endif + write (iout,*) "i",i," ind",ind," nind",nind + enddo + if (inct.gt.innt) then + DM(ind)=ip4+mp/4 + if (iabs(itype(inct)).eq.10) then + DM(ind)=DM(ind)+msc(10) + ind=ind+1 + nind=nind+1 + else + DM(ind)=DM(ind)+isc(iabs(itype(inct))) + DM(ind+1)=msc(iabs(itype(inct)))+isc(iabs(itype(inct))) + ind=ind+2 + nind=nind+2 + endif + endif + write (iout,*) "ind",ind," nind",nind + dimen_chain(ichain)=nind + enddo + + do ichain=1,nchain + ind=iposd_chain(ichain) + innt=chain_border(1,ichain) + inct=chain_border(2,ichain) + do i=innt,inct + if (iabs(itype(i)).ne.10 .and.iabs(itype((i))).ne.ntyp1) then + DU1(ind)=-isc(iabs(itype(i))) + DU1(ind+1)=0.0d0 + ind=ind+2 + else + DU1(ind)=mp/4-ip4 + ind=ind+1 + endif + enddo + enddo + + do ichain=1,nchain + ind=iposd_chain(ichain) + innt=chain_border(1,ichain) + inct=chain_border(2,ichain) + do i=innt,inct-1 +! if (iabs(itype(i)).eq.ntyp1) cycle +c write (iout,*) "i",i," itype",itype(i),ntyp1 + if (iabs(itype(i)).ne.10 .and. iabs(itype(i)).ne.ntyp1) then + DU2(ind)=mp/4-ip4 + DU2(ind+1)=0.0d0 + ind=ind+2 + else + DU2(ind)=0.0d0 + DU2(ind+1)=0.0d0 + ind=ind+1 + endif + enddo + enddo + DMorig=DM + DU1orig=DU1 + DU2orig=DU2 + if (gmatout) then + write (iout,*)"The upper part of the five-diagonal inertia matrix" + endif + do ichain=1,nchain + if (gmatout) write (iout,'(a,i5)') 'Chain',ichain + n=dimen_chain(ichain) + innt=iposd_chain(ichain) + inct=iposd_chain(ichain)+dimen_chain(ichain)-1 + if (gmatout) then + do i=innt,inct + if (i.lt.inct-1) then + write (iout,'(2i3,3f10.5)') i,i-innt+1,DM(i),DU1(i),DU2(i) + else if (i.eq.inct-1) then + write (iout,'(2i3,3f10.5)') i,i-innt+1,DM(i),DU1(i) + else + write (iout,'(2i3,3f10.5)') i,i-innt+1,DM(i) + endif + enddo + endif + call FDISYP (n, DM(innt:inct), DU1(innt:inct-1), + & DU2(innt:inct-1), MARK) + + if (mark.eq.-1) then + write(iout,*) + & "ERROR: the inertia matrix is not positive definite for chain", + & ichain +#ifdef MPI + call MPI_Finalize(ierr) +#endif + stop + else if (mark.eq.0) then + write (iout,*) + & "ERROR: the inertia matrix is singular for chain",ichain +#ifdef MPI + call MPI_Finalize(ierr) +#endif + else if (mark.eq.1) then + if (gmatout) then + write (iout,*) "The transformed five-diagonal inertia matrix" + write (iout,'(a,i5)') 'Chain',ichain + do i=innt,inct + if (i.lt.inct-1) then + write (iout,'(2i3,3f10.5)') i,i-innt+1,DM(i),DU1(i),DU2(i) + else if (i.eq.inct-1) then + write (iout,'(2i3,3f10.5)') i,i-innt+1,DM(i),DU1(i) + else + write (iout,'(2i3,3f10.5)') i,i-innt+1,DM(i) + endif + enddo + endif + endif + enddo +! Diagonalization of the pentadiagonal matrix +#ifdef TIMING + time00=MPI_Wtime() +#endif +#else dimen=(nct-nnt+1)+nside dimen1=(nct-nnt)+(nct-nnt+1) dimen3=dimen*3 + write (iout,*) "Degrees_of_freedom",dimen3 #ifdef MPI if (nfgtasks.gt.1) then time00=MPI_Wtime() @@ -237,7 +605,7 @@ c Off-diagonal elements of the dX part of A A(k+ii,jj)=1.0d0 enddo enddo - if (lprn) then + if (gmatout) then write (iout,*) write (iout,*) "Vector massvec" do i=1,dimen1 @@ -258,7 +626,7 @@ c Calculate the G matrix (store in Gmat) enddo enddo - if (lprn) then + if (gmatout) then write (iout,'(//a)') "Gmat" call matout(dimen,dimen,maxres2,maxres2,Gmat) endif @@ -271,7 +639,7 @@ c Calculate the G matrix (store in Gmat) enddo c Invert the G matrix call MATINVERT(dimen,maxres2,Gcopy,Ginv,osob) - if (lprn) then + if (gmatout) then write (iout,'(//a)') "Ginv" call matout(dimen,dimen,maxres2,maxres2,Ginv) endif @@ -319,7 +687,7 @@ c Compute G**(-1/2) and G**(1/2) enddo call gldiag(maxres2,dimen,dimen,Ghalf,work,Geigen,Gvec, & ierr,iwork) - if (lprn) then + if (gmatout) then write (iout,'(//a)') & "Eigenvectors and eigenvalues of the G matrix" call eigout(dimen,dimen,maxres2,maxres2,Gvec,Geigen) @@ -348,14 +716,16 @@ c Compute G**(-1/2) and G**(1/2) enddo enddo endif +#endif return end c------------------------------------------------------------------------------- SUBROUTINE EIGOUT(NC,NR,LM2,LM3,A,B) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' double precision A(LM2,LM3),B(LM2) + integer nc,nr,lm2,lm3,ka,kb,kc,n,i,j KA=1 KC=6 1 KB=MIN0(KC,NC) @@ -382,10 +752,11 @@ c------------------------------------------------------------------------------- END c------------------------------------------------------------------------------- SUBROUTINE MATOUT(NC,NR,LM2,LM3,A) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' double precision A(LM2,LM3) + integer nc,nr,lm2,lm3,n,ka,kb,kc,i,j KA=1 KC=6 1 KB=MIN0(KC,NC) @@ -410,10 +781,11 @@ c------------------------------------------------------------------------------- END c------------------------------------------------------------------------------- SUBROUTINE MATOUT1(NC,NR,LM2,LM3,A) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' double precision A(LM2,LM3) + integer nc,nr,lm2,lm3,n,ka,kb,kc,i,j KA=1 KC=21 1 KB=MIN0(KC,NC) @@ -438,10 +810,11 @@ c------------------------------------------------------------------------------- END c------------------------------------------------------------------------------- SUBROUTINE MATOUT2(NC,NR,LM2,LM3,A) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' double precision A(LM2,LM3) + integer nc,nr,lm2,lm3,ka,kb,kc,i,j,n KA=1 KC=12 1 KB=MIN0(KC,NC) @@ -464,19 +837,175 @@ c------------------------------------------------------------------------------- 603 FORMAT (I5,4(3F9.3,2x)) 604 FORMAT (1H1) END +c----------------------------------------------------------------------------- + SUBROUTINE MATOUTR(N,A) +c Prints the lower fragment of a symmetric matix + implicit none + integer n + double precision a(n*(n+1)/2) + integer i,j,k,nlim,jlim,jlim1 + CHARACTER*6 LINE6 / '------' / + CHARACTER*12 LINE12 / '------------' / + double precision B(10) + include 'COMMON.IOUNITS' + DO 1 I=1,N,10 + NLIM=MIN0(I+9,N) + WRITE (IOUT,1000) (K,K=I,NLIM) + WRITE (IOUT,1020) LINE6,(LINE12,K=I,NLIM) + 1000 FORMAT (/7X,10(I5,2X)) + 1020 FORMAT (A6,10A7) + DO 2 J=I,N + JLIM=MIN0(J,NLIM) + JLIM1=JLIM-I+1 + DO 3 K=I,JLIM + 3 B(K-I+1)=A(J*(J-1)/2+K) + WRITE (IOUT,1010) J,(B(K),K=1,JLIM1) + 2 CONTINUE + 1 CONTINUE + 1010 FORMAT (I3,3X,10(F7.2)) + RETURN + END +#ifdef FIVEDIAG +c--------------------------------------------------------------------------- + subroutine fivediagmult(n,DM,DU1,DU2,x,y) + implicit none + integer n + double precision DM(n),DU1(n),DU2(n),x(n),y(n) + integer i + y(1)=DM(1)*x(1)+DU1(1)*x(2)+DU2(1)*x(3) + y(2)=DU1(1)*x(1)+DM(2)*x(2)+DU1(2)*x(3)+DU2(2)*x(4) + do i=3,n-2 + y(i)=DU2(i-2)*x(i-2)+DU1(i-1)*x(i-1)+DM(i)*x(i) + & +DU1(i)*x(i+1)+DU2(i)*x(i+2) + enddo + y(n-1)=DU2(n-3)*x(n-3)+DU1(n-2)*x(n-2)+DM(n-1)*x(n-1) + & +DU1(n-1)*x(n) + y(n)=DU2(n-2)*x(n-2)+DU1(n-1)*x(n-1)+DM(n)*x(n) + return + end +c--------------------------------------------------------------------------- + subroutine fivediaginv_mult(ndim,forces,d_a_vec) + implicit none + include 'DIMENSIONS' + include 'COMMON.CHAIN' + include 'COMMON.IOUNITS' + include 'COMMON.LAGRANGE.5diag' + include 'COMMON.INTERACT' + integer ndim + double precision forces(3*ndim),accel(3,0:maxres2),rs(ndim), + & xsolv(ndim),d_a_vec(6*nres) + integer i,j,ind,ichain,n,iposc,innt,inct,inct_prev + do j=1,3 +Compute accelerations in Calpha and SC + do ichain=1,nchain + n=dimen_chain(ichain) + iposc=iposd_chain(ichain) + innt=chain_border(1,ichain) + inct=chain_border(2,ichain) + do i=iposc,iposc+n-1 + rs(i)=forces(3*(i-1)+j) + enddo + call FDISYS (n,DM(iposc),DU1(iposc),DU2(iposc),rs,xsolv) + ind=1 + do i=innt,inct + if (itype(i).eq.10)then + accel(j,i)=xsolv(ind) + ind=ind+1 + else + accel(j,i)=xsolv(ind) + accel(j,i+nres)=xsolv(ind+1) + ind=ind+2 + end if + enddo + enddo + enddo +C Conevert d_a to virtual-bon-vector basis +#ifdef DEBUG + write (iout,*) "accel in CA-SC basis" + do i=1,nres + write (iout,'(i5,3f10.5,5x,3f10.5)') i,(accel(j,i),j=1,3), + & (accel(j,i+nres),j=1,3) + enddo + write (iout,*) "nnt",nnt +#endif + if (nnt.eq.1) then + accel(:,0)=accel(:,1) + endif + do i=1,nres + if (itype(i).eq.10 .or. itype(i).eq.ntyp1) then + do j=1,3 + accel(j,i)=accel(j,i+1)-accel(j,i) + enddo + else + do j=1,3 + accel(j,i+nres)=accel(j,i+nres)-accel(j,i) + accel(j,i)=accel(j,i+1)-accel(j,i) + enddo + end if + enddo + accel(:,nres)=0.0d0 + accel(:,2*nres)=0.0d0 + if (nnt.gt.1) then + accel(:,0)=accel(:,1) + accel(:,1)=0.0d0 + endif + do ichain=2,nchain + accel(:,chain_border1(1,ichain)-1)= + & accel(:,chain_border1(1,ichain)) + accel(:,chain_border1(1,ichain))=0.0d0 + enddo + do ichain=2,nchain + accel(:,chain_border1(1,ichain)-1)= + & accel(:,chain_border1(1,ichain)-1) + & +accel(:,chain_border(2,ichain-1)) + accel(:,chain_border(2,ichain-1))=0.0d0 + enddo +#ifdef DEBUG + write (iout,*) "accel in fivediaginv_mult: 1" + do i=0,2*nres + write(iout,'(i5,3f10.5)') i,(accel(j,i),j=1,3) + enddo +#endif + do j=1,3 + d_a_vec(j)=accel(j,0) + enddo + ind=3 + do i=nnt,nct-1 + do j=1,3 + d_a_vec(ind+j)=accel(j,i) + enddo + ind=ind+3 + enddo + do i=nnt,nct + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + do j=1,3 + d_a_vec(ind+j)=accel(j,i+nres) + enddo + ind=ind+3 + endif + enddo +#ifdef DEBUG + write (iout,*) "d_a_vec" + write (iout,'(3f10.5)') (d_a_vec(j),j=1,dimen3) +#endif + return + end +#else c--------------------------------------------------------------------------- SUBROUTINE ginv_mult(z,d_a_tmp) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' - integer ierr + integer ierr,ierror #endif include 'COMMON.SETUP' include 'COMMON.TIME1' include 'COMMON.MD' + include 'COMMON.LAGRANGE' double precision z(dimen3),d_a_tmp(dimen3),temp(maxres6),time00 &,time01,zcopy(dimen3) + integer i,j,k,ind #ifdef MPI if (nfgtasks.gt.1) then if (fg_rank.eq.0) then @@ -573,9 +1102,9 @@ c & +Ginv(i,j)*z((j-1)*3+k+1) c--------------------------------------------------------------------------- #ifdef GINV_MULT SUBROUTINE ginv_mult_test(z,d_a_tmp) + implicit none include 'DIMENSIONS' - integer dimen -c include 'COMMON.MD' + include 'COMMON.LAGRANGE' double precision z(dimen),d_a_tmp(dimen) double precision ztmp(dimen/3),dtmp(dimen/3) @@ -620,6 +1149,7 @@ c--------------------------------------------------------------------------- integer IERROR #endif include 'COMMON.MD' + include 'COMMON.LAGRANGE' include 'COMMON.IOUNITS' include 'COMMON.SETUP' include 'COMMON.TIME1' @@ -703,3 +1233,4 @@ c write (2,*) i,d_a_tmp(i) c enddo return end +#endif diff --git a/source/unres/src-HCD-5D/map.f b/source/unres/src-HCD-5D/map.f deleted file mode 100644 index 6ea2632..0000000 --- a/source/unres/src-HCD-5D/map.f +++ /dev/null @@ -1,89 +0,0 @@ - subroutine map - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MAP' - include 'COMMON.VAR' - include 'COMMON.GEO' - include 'COMMON.DERIV' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - include 'COMMON.CONTROL' - include 'COMMON.TORCNSTR' - double precision energia(0:n_ene) - character*5 angid(4) /'PHI','THETA','ALPHA','OMEGA'/ - double precision ang_list(10) - double precision g(maxvar),x(maxvar) - integer nn(10) - write (iout,'(a,i3,a)')'Energy map constructed in the following ', - & nmap,' groups of variables:' - do i=1,nmap - write (iout,'(2a,i3,a,i3)') angid(kang(i)),' of residues ', - & res1(i),' to ',res2(i) - enddo - nmax=nstep(1) - do i=2,nmap - if (nmax.lt.nstep(i)) nmax=nstep(i) - enddo - ntot=nmax**nmap - iii=0 - write (istat,'(1h#,a14,29a15)') (" ",k=1,nmap), - & (ename(print_order(k)),k=1,nprint_ene),"ETOT","GNORM" - do i=0,ntot-1 - ii=i - do j=1,nmap - nn(j)=mod(ii,nmax)+1 - ii=ii/nmax - enddo - do j=1,nmap - if (nn(j).gt.nstep(j)) goto 10 - enddo - iii=iii+1 -Cd write (iout,*) i,iii,(nn(j),j=1,nmap) - do j=1,nmap - ang_list(j)=ang_from(j) - & +(nn(j)-1)*(ang_to(j)-ang_from(j))/nstep(j) - do k=res1(j),res2(j) - goto (1,2,3,4), kang(j) - 1 phi(k)=deg2rad*ang_list(j) - if (minim) phi0(k-res1(j)+1)=deg2rad*ang_list(j) - goto 5 - 2 theta(k)=deg2rad*ang_list(j) - goto 5 - 3 alph(k)=deg2rad*ang_list(j) - goto 5 - 4 omeg(k)=deg2rad*ang_list(j) - 5 continue - enddo ! k - enddo ! j - call chainbuild - if (minim) then - call geom_to_var(nvar,x) - call minimize(etot,x,iretcode,nfun) - print *,'SUMSL return code is',iretcode,' eval ',nfun -c call intout - else - call zerograd - call geom_to_var(nvar,x) - endif - call etotal(energia(0)) - etot = energia(0) - nf=1 - nfl=3 - call gradient(nvar,x,nf,g,uiparm,urparm,fdum) - gnorm=0.0d0 - do k=1,nvar - gnorm=gnorm+g(k)**2 - enddo - etot=energia(0) - - gnorm=dsqrt(gnorm) -c write (iout,'(6(1pe15.5))') (ang_list(k),k=1,nmap),etot,gnorm - write (istat,'(30e15.5)') (ang_list(k),k=1,nmap), - & (energia(print_order(ii)),ii=1,nprint_ene),etot,gnorm -c write (iout,*) 'POINT',I,' ANGLES:',(ang_list(k),k=1,nmap) -c call intout -c call enerprint(energia) - 10 continue - enddo ! i - return - end diff --git a/source/unres/src-HCD-5D/matmult.f b/source/unres/src-HCD-5D/matmult.f index e9257cf..748df4d 100644 --- a/source/unres/src-HCD-5D/matmult.f +++ b/source/unres/src-HCD-5D/matmult.f @@ -1,11 +1,12 @@ SUBROUTINE MATMULT(A1,A2,A3) - implicit real*8 (a-h,o-z) + IMPLICIT NONE include 'DIMENSIONS' - DIMENSION A1(3,3),A2(3,3),A3(3,3) - DIMENSION AI3(3,3) + DOUBLE PRECISION A1(3,3),A2(3,3),A3(3,3) + DOUBLE PRECISION AI3(3,3),A3IJ + integer I,J,K DO 1 I=1,3 DO 2 J=1,3 - A3IJ=0.0 + A3IJ=0.0D0 DO 3 K=1,3 3 A3IJ=A3IJ+A1(I,K)*A2(K,J) AI3(I,J)=A3IJ diff --git a/source/unres/src-HCD-5D/minim_jlee.F b/source/unres/src-HCD-5D/minim_jlee.F index 56d5010..7162afb 100644 --- a/source/unres/src-HCD-5D/minim_jlee.F +++ b/source/unres/src-HCD-5D/minim_jlee.F @@ -1,13 +1,33 @@ subroutine minim_jlee +#ifdef LBFGS + use minima + use inform + use output + use iounit + use scales +#endif c controls minimization and sorting routines implicit real*8 (a-h,o-z) include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +#ifndef LBFGS + integer liv,lv + parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +#endif include 'COMMON.VAR' include 'COMMON.IOUNITS' include 'COMMON.MINIM' include 'COMMON.CONTROL' +#ifdef LBFGS + common /gacia/ nfun + double precision grdmin + external funcgrad + external optsave +#else external func,gradient,fdum + dimension iv(liv) + double precision v(1:lv+1) + common /przechowalnia/ v +#endif real ran1,ran2,ran3 #ifdef MPI include 'mpif.h' @@ -22,19 +42,40 @@ c controls minimization and sorting routines dimension var(maxvar),erg(mxch*(mxch+1)/2+1) dimension var2(maxvar) integer iffr(maxres),ihpbt(maxdim),jhpbt(maxdim) - double precision d(maxvar),v(1:lv+1),garbage(maxvar) + double precision d(maxvar),garbage(maxvar),g(maxvar) double precision energia(0:n_ene),time0s,time1s dimension indx(9),info(12) - dimension iv(liv) dimension idum(1),rdum(1) dimension icont(2,maxcont) logical check_var,fail integer iloop(2) - common /przechowalnia/ v data rad /1.745329252d-2/ c receive # of start ! print *,'Processor',me,' calling MINIM_JLEE maxfun',maxfun, ! & ' maxmin',maxmin,' tolf',tolf,' rtolf',rtolf +#ifdef LBFGS + maxiter=maxmin + coordtype='RIGIDBODY' + grdmin=tolf + jout=iout + jprint=print_min_stat + iwrite=0 + if (.not. allocated(scale)) allocate (scale(nvar)) +c +c set scaling parameter for function and derivative values; +c use square root of median eigenvalue of typical Hessian +c + set_scale = .true. +c nvar = 0 + do i = 1, nvar +c if (use(i)) then +c do j = 1, 3 +c nvar = nvar + 1 + scale(i) = 12.0d0 +c end do +c end if + end do +#endif nhpb0=nhpb 10 continue time0s=MPI_WTIME() @@ -161,8 +202,13 @@ crc overlap test nfun=nfun+1 write (iout,'(a,1pe14.5)')'#OVERLAP evdw after',energia(1) else +#ifdef LBFGS + etot=1.0d20 + nfun=-1 +#else v(10)=1.0d20 iv(1)=-1 +#endif goto 201 endif endif @@ -176,8 +222,12 @@ cd write(iout,*) 'sc_move',nft_sc,etot endif if (check_var(var,info)) then +#ifdef LBFGS + etot=1.0d21 +#else v(10)=1.0d21 iv(1)=6 +#endif goto 201 endif @@ -189,10 +239,22 @@ crc ! write (*,*) 'MINIM_JLEE: Processor',me,' received nvar',nvar ! write (*,'(8f10.4)') (var(i),i=1,nvar) - do i=1,nvar - garbage(i)=var(i) - enddo + do i=1,nvar + garbage(i)=var(i) + enddo +#ifdef LBFGS + eee=funcgrad(var,g) + nfun=nfun+1 + if(eee.ge.1.0d20) then +c print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' +c print *,' energy before SUMSL =',eee +c print *,' aborting local minimization' + go to 201 + endif + call lbfgs (nvar,var,etot,grdmin,funcgrad,optsave) + deallocate(scale) +#else call deflt(2,iv,liv,lv,v) * 12 means fresh start, dont call deflt iv(1)=12 @@ -262,8 +324,12 @@ c print *, 'MINIM_JLEE: ',me,' before SUMSL ' c print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' c print *,' energy before SUMSL =',eee c print *,' aborting local minimization' +#ifdef LBFGS + etot=eee +#else iv(1)=-1 v(10)=eee +#endif go to 201 endif @@ -274,6 +340,7 @@ c print *, 'MINIM_JLEE: ',me,' after SUMSL ' c find which conformation was returned from sumsl nfun=nfun+iv(7) +#endif ! print *,'Processor',me,' iv(17)',iv(17),' iv(18)',iv(18),' nf',nf, ! & ' retcode',iv(1),' energy',v(10),' tolf',v(31),' rtolf',v(32) c if (iv(1).ne.4 .or. nf.le.1) then @@ -311,7 +378,11 @@ c print *, 'MINIM_JLEE: ',me,' minimized: ',n 201 continue indx(1)=n c return code: 6-gradient 9-number of ftn evaluation, etc +#ifdef LBFGS + indx(2)=nfun +#else indx(2)=iv(1) +#endif c total # of ftn evaluations (for iwf=0, it includes all minimizations). indx(3)=nfun indx(4)=info(2) @@ -325,12 +396,21 @@ c total # of ftn evaluations (for iwf=0, it includes all minimizations). c send back energies c al & cc c calculate contact order +#ifdef LBFGS +#ifdef CO_BIAS + call contact(.false.,ncont,icont,co) + erg(1)=etot-1.0d2*co +#else + erg(1)=etot +#endif +#else #ifdef CO_BIAS call contact(.false.,ncont,icont,co) erg(1)=v(10)-1.0d2*co #else erg(1)=v(10) #endif +#endif j=1 call mpi_send(erg,j,mpi_double_precision,king,idreal, * CG_COMM,ierr) diff --git a/source/unres/src-HCD-5D/minim_mcmf.F b/source/unres/src-HCD-5D/minim_mcmf.F index 836d258..16623b6 100644 --- a/source/unres/src-HCD-5D/minim_mcmf.F +++ b/source/unres/src-HCD-5D/minim_mcmf.F @@ -1,12 +1,31 @@ subroutine minim_mcmf +#ifdef LBFGS + use minima + use inform + use output + use iounit + use scales +#endif implicit real*8 (a-h,o-z) include 'DIMENSIONS' +#ifndef LBFGS parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +#endif include 'COMMON.VAR' include 'COMMON.IOUNITS' include 'COMMON.MINIM' include 'mpif.h' +#ifdef LBFGS + double precision grdmin + external funcgrad + external optsave +#else + double precision v(1:lv+1) + common /przechowalnia/ v external func,gradient,fdum + dimension iv(liv) +#endif + common /gacia/ nf real ran1,ran2,ran3 include 'COMMON.SETUP' include 'COMMON.GEO' @@ -14,14 +33,12 @@ include 'COMMON.FFIELD' dimension muster(mpi_status_size) dimension var(maxvar),erg(mxch*(mxch+1)/2+1) - double precision d(maxvar),v(1:lv+1),garbage(maxvar) + double precision d(maxvar),garbage(maxvar) dimension indx(6) - dimension iv(liv) dimension idum(1),rdum(1) double precision przes(3),obrot(3,3) logical non_conv data rad /1.745329252d-2/ - common /przechowalnia/ v ichuj=0 10 continue @@ -36,7 +53,41 @@ c print *, 'worker ',me,' received order ',n,ichuj * king,idreal,CG_COMM,muster,ierr) c print *, 'worker ',me,' var read ' - +#ifdef LBFGS + maxiter=maxmin + coordtype='RIGIDBODY' + grdmin=tolf + jout=iout + jprint=print_min_stat + iwrite=0 + if (.not. allocated(scale)) allocate (scale(nvar)) +c +c set scaling parameter for function and derivative values; +c use square root of median eigenvalue of typical Hessian +c + set_scale = .true. +c nvar = 0 + do i = 1, nvar +c if (use(i)) then +c do j = 1, 3 +c nvar = nvar + 1 + scale(i) = 12.0d0 +c end do +c end if + end do + eee=funcgrad(var,g) + if(eee.gt.1.0d18) then +c print *,'MINIM_JLEE: ',me,' CHUJ NASTAPIL' +c print *,' energy before SUMSL =',eee +c print *,' aborting local minimization' + nf=-1 + go to 201 + endif +c write (iout,*) "Calling lbfgs" + call lbfgs (nvar,x,eee,grdmin,funcgrad,optsave) + nf=nf+1 + deallocate(scale) +#else call deflt(2,iv,liv,lv,v) * 12 means fresh start, dont call deflt iv(1)=12 @@ -98,11 +149,16 @@ c print *,' aborting local minimization' call sumsl(nvar,d,var,func,gradient,iv,liv,lv,v,idum,rdum,fdum) c find which conformation was returned from sumsl nf=iv(7)+1 +#endif 201 continue c total # of ftn evaluations (for iwf=0, it includes all minimizations). indx(4)=nf +#ifdef LBFGS + indx(5)=0 +#else indx(5)=iv(1) eee=v(10) +#endif call mpi_send(indx,6,mpi_integer,king,idint,CG_COMM, * ierr) diff --git a/source/unres/src-HCD-5D/minimize_p.F b/source/unres/src-HCD-5D/minimize_p.F index f9faf7c..a56e4f8 100644 --- a/source/unres/src-HCD-5D/minimize_p.F +++ b/source/unres/src-HCD-5D/minimize_p.F @@ -1,7 +1,17 @@ subroutine minimize(etot,x,iretcode,nfun) - implicit real*8 (a-h,o-z) +#ifdef LBFGS + use minima + use inform + use output + use iounit + use scales +#endif + implicit none include 'DIMENSIONS' +#ifndef LBFGS + integer liv,lv parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +#endif ********************************************************************* * OPTIMIZE sets up SUMSL or DFP and provides a simple interface for * * the calling subprogram. * @@ -17,15 +27,61 @@ include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.MINIM' + integer icall common /srutu/ icall - dimension iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) - double precision energia(0:n_ene) +#ifdef LBFGS + double precision grdmin + external funcgrad + external optsave +#else + integer iv(liv) + double precision v(1:lv) + common /przechowalnia/ v + integer idum + double precision rdum + double precision fdum external func,gradient,fdum external func_restr,grad_restr logical not_done,change,reduce +#endif + double precision x(maxvar),d(maxvar),xx(maxvar) + double precision energia(0:n_ene) + integer i,nvar_restr,nfun,iretcode + double precision etot c common /przechowalnia/ v +#ifdef LBFGS + maxiter=maxmin + coordtype='RIGIDBODY' + grdmin=tolf + jout=iout + jprint=print_min_stat + iwrite=0 + if (.not. allocated(scale)) allocate (scale(nvar)) +c +c set scaling parameter for function and derivative values; +c use square root of median eigenvalue of typical Hessian +c + set_scale = .true. +c nvar = 0 + do i = 1, nvar +c if (use(i)) then +c do j = 1, 3 +c nvar = nvar + 1 + scale(i) = 12.0d0 +c end do +c end if + end do +c write (iout,*) "Calling lbfgs" + write (iout,*) 'Calling LBFGS, minimization in angles' + call var_to_geom(nvar,x) + call chainbuild_extconf + call etotal(energia(0)) + call enerprint(energia(0)) + call lbfgs (nvar,x,etot,grdmin,funcgrad,optsave) + deallocate(scale) + write (iout,*) "Minimized energy",etot +#else icall = 1 NOT_DONE=.TRUE. @@ -78,10 +134,12 @@ c v(25)=4.0D0 do i=nphi+1,nvar d(i)=1.0D-1 enddo -cd print *,'Calling SUMSL' -c call var_to_geom(nvar,x) -c call chainbuild -c call etotal(energia(0)) + write (iout,*) 'Calling SUMSL' + call var_to_geom(nvar,x) + call chainbuild_extconf + call intout + call etotal(energia(0)) + call enerprint(energia(0)) c etot = energia(0) IF (mask_r) THEN call x2xx(x,xx,nvar_restr) @@ -103,7 +161,7 @@ c write (iout,'(a)') 'Reduction worked, minimizing again...' c else c not_done=.false. c endif - call chainbuild + call chainbuild_extconf c call etotal(energia(0)) c etot=energia(0) c call enerprint(energia(0)) @@ -112,16 +170,18 @@ c call enerprint(energia(0)) c write (*,*) 'Processor',MyID,' leaves MINIMIZE.' c ENDDO ! NOT_DONE - +#endif return end #ifdef MPI c---------------------------------------------------------------------------- subroutine ergastulum - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include "mpif.h" + double precision time00 + integer ierr,ierror #endif include 'COMMON.SETUP' include 'COMMON.DERIV' @@ -130,12 +190,18 @@ c---------------------------------------------------------------------------- include 'COMMON.FFIELD' include 'COMMON.INTERACT' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif include 'COMMON.TIME1' double precision z(maxres6),d_a_tmp(maxres6) double precision edum(0:n_ene),time_order(0:10) double precision Gcopy(maxres2,maxres2) common /przechowalnia/ Gcopy integer icall /0/ + integer i,j,iorder C Workers wait for variables and NF, and NFL from the boss iorder=0 do while (iorder.ge.0) @@ -173,7 +239,8 @@ c call flush(2) call sum_gradient c write (2,*) "After sum_gradient" c write (2,*) "dimen",dimen," dimen3",dimen3 -c call flush(2) +c call flush(2 +#ifndef FIVEDIAG else if (iorder.eq.4) then call ginv_mult(z,d_a_tmp) else if (iorder.eq.5) then @@ -221,14 +288,17 @@ c write (2,*) "End MD setup" c call flush(2) c write (iout,*) "My chunk of ginv_block" c call MATOUT2(my_ng_count,dimen3,maxres2,maxers2,ginv_block) +#endif else if (iorder.eq.6) then call int_from_cart1(.false.) else if (iorder.eq.7) then call chainbuild_cart else if (iorder.eq.8) then call intcartderiv +#ifndef FIVEDIAG else if (iorder.eq.9) then call fricmat_mult(z,d_a_tmp) +#endif else if (iorder.eq.10) then call setup_fricmat endif @@ -241,6 +311,53 @@ c call MATOUT2(my_ng_count,dimen3,maxres2,maxers2,ginv_block) end #endif ************************************************************************ +#ifdef LBFGS + double precision function funcgrad(x,g) + implicit none + include 'DIMENSIONS' + include 'COMMON.CONTROL' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.QRESTR' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + double precision energia(0:n_ene) + double precision x(nvar),g(nvar) + integer i +c if (jjj.gt.0) then +c write (iout,*) "in func x" +c write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n) +c endif + call var_to_geom(nvar,x) + call zerograd + call chainbuild_extconf + call etotal(energia(0)) + call sum_gradient + funcgrad=energia(0) + call cart2intgrad(nvar,g) +C +C Add the components corresponding to local energy terms. +C +c Add the usampl contributions + if (usampl) then + do i=1,nres-3 + gloc(i,icg)=gloc(i,icg)+dugamma(i) + enddo + do i=1,nres-2 + gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i) + enddo + endif + do i=1,nvar +cd write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg) + g(i)=g(i)+gloc(i,icg) + enddo + return + end +#else subroutine func(n,x,nf,f,uiparm,urparm,ufparm) implicit real*8 (a-h,o-z) include 'DIMENSIONS' @@ -312,46 +429,51 @@ c endif return end c------------------------------------------------------- +#endif subroutine x2xx(x,xx,n) implicit real*8 (a-h,o-z) include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' double precision xx(maxvar),x(maxvar) +c write (iout,*) "nvar",nvar do i=1,nvar varall(i)=x(i) enddo - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 xx(ig)=x(igall) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 xx(ig)=x(igall) - endif + endif enddo - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 xx(ig)=x(igall) - endif - endif - enddo +c write (iout,*) "ij",ij," i",i," ig",ig," igall",igall +c write (iout,*) "x",x(igall)," xx",xx(ig) + endif + endif + enddo enddo n=ig @@ -365,40 +487,43 @@ c------------------------------------------------------- include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.INTERACT' + include 'COMMON.IOUNITS' double precision xx(maxvar),x(maxvar) do i=1,nvar x(i)=varall(i) enddo - ig=0 - igall=0 - do i=4,nres - igall=igall+1 - if (mask_phi(i).eq.1) then - ig=ig+1 + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 x(igall)=xx(ig) - endif - enddo - - do i=3,nres - igall=igall+1 - if (mask_theta(i).eq.1) then - ig=ig+1 + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 x(igall)=xx(ig) - endif + endif enddo - do ij=1,2 - do i=2,nres-1 - if (itype(i).ne.10) then - igall=igall+1 - if (mask_side(i).eq.1) then - ig=ig+1 + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 x(igall)=xx(ig) - endif - endif - enddo +c write (iout,*) "ij",ij," i",i," ig",ig," igall",igall +c write (iout,*) "x",x(igall)," xx",xx(ig) + endif + endif + enddo enddo return @@ -406,9 +531,18 @@ c------------------------------------------------------- c---------------------------------------------------------- subroutine minim_dc(etot,iretcode,nfun) +#ifdef LBFGS + use minima + use inform + use output + use iounit + use scales +#endif implicit real*8 (a-h,o-z) include 'DIMENSIONS' +#ifndef LBFGS parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +#endif #ifdef MPI include 'mpif.h' #endif @@ -419,15 +553,28 @@ c---------------------------------------------------------- include 'COMMON.GEO' include 'COMMON.MINIM' include 'COMMON.CHAIN' + double precision minval,x(maxvar),d(maxvar),xx(maxvar) +#ifdef LBFGS + double precision grdmin + double precision funcgrad_dc + external funcgrad_dc,optsave +#else dimension iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) + double precision v(1:lv) common /przechowalnia/ v - - double precision energia(0:n_ene) external func_dc,grad_dc,fdum - logical not_done,change,reduce +#endif double precision g(maxvar),f1 - + integer nvarx + double precision energia(0:n_ene) +#ifdef LBFGS + maxiter=maxmin + coordtype='CARTESIAN' + grdmin=tolf + jout=iout + jprint=print_min_stat + iwrite=0 +#else call deflt(2,iv,liv,lv,v) * 12 means fresh start, dont call deflt iv(1)=12 @@ -471,7 +618,7 @@ c v(25)=4.0D0 do i=1,6*nres d(i)=1.0D-1 enddo - +#endif k=0 do i=1,nres-1 do j=1,3 @@ -487,6 +634,37 @@ c v(25)=4.0D0 enddo endif enddo + nvarx=k + write (iout,*) "Variables set up nvarx",nvarx + write (iout,*) "Before energy minimization" + call etotal(energia(0)) + call enerprint(energia(0)) +#ifdef LBFGS +c +c From tinker +c +c perform dynamic allocation of some global arrays +c + if (.not. allocated(scale)) allocate (scale(nvarx)) +c +c set scaling parameter for function and derivative values; +c use square root of median eigenvalue of typical Hessian +c + set_scale = .true. +c nvar = 0 + do i = 1, nvarx +c if (use(i)) then +c do j = 1, 3 +c nvar = nvar + 1 + scale(i) = 12.0d0 +c end do +c end if + end do +c write (iout,*) "minim_dc Calling lbfgs" + call lbfgs (nvarx,x,etot,grdmin,funcgrad_dc,optsave) + deallocate(scale) +c write (iout,*) "minim_dc After lbfgs" +#else c----- c write (iout,*) "checkgrad before SUMSL" c icheckgrad=1 @@ -499,7 +677,7 @@ c----- c write (iout,*) "checkgrad after SUMSL" c call exec_checkgrad c----- - +#endif k=0 do i=1,nres-1 do j=1,3 @@ -528,13 +706,77 @@ cd call func_dc(k,x,nf,f1,idum,rdum,fdum) cd x(i)=x(i)-1.0D-5 cd print '(i5,2f15.5)',i,g(i),(f1-f)/1.0D-5 cd enddo - +#ifndef LBFGS etot=v(10) iretcode=iv(1) nfun=iv(6) +#endif return end +#ifdef LBFGS + double precision function funcgrad_dc(x,g) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' +#ifdef MPI + include 'mpif.h' +#endif + include 'COMMON.SETUP' + include 'COMMON.CHAIN' + include 'COMMON.DERIV' + include 'COMMON.VAR' + include 'COMMON.INTERACT' + include 'COMMON.FFIELD' + include 'COMMON.MD' + include 'COMMON.IOUNITS' + integer k + dimension x(maxvar),g(maxvar) + double precision energia(0:n_ene) + common /gacia/ nf +c + nf=nf+1 + k=0 + do i=1,nres-1 + do j=1,3 + k=k+1 + dc(j,i)=x(k) + enddo + enddo + do i=2,nres-1 + if (ialph(i,1).gt.0) then + do j=1,3 + k=k+1 + dc(j,i+nres)=x(k) + enddo + endif + enddo + call chainbuild_cart + call zerograd + call etotal(energia(0)) +c write (iout,*) "energia",energia(0) + funcgrad_dc=energia(0) +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + call cartgrad + k=0 + do i=1,nres-1 + do j=1,3 + k=k+1 + g(k)=gcart(j,i) + enddo + enddo + do i=2,nres-1 + if (ialph(i,1).gt.0) then + do j=1,3 + k=k+1 + g(k)=gxcart(j,i) + enddo + endif + enddo + return + end +#else subroutine func_dc(n,x,nf,f,uiparm,urparm,ufparm) implicit real*8 (a-h,o-z) include 'DIMENSIONS' @@ -551,7 +793,7 @@ cd enddo double precision ufparm external ufparm integer uiparm(1) - real*8 urparm(1) + real*8 urparm(1) dimension x(maxvar) nfl=nf cbad icg=mod(nf,2)+1 @@ -654,3 +896,4 @@ cd print *,40 return end +#endif diff --git a/source/unres/src-HCD-5D/misc.f b/source/unres/src-HCD-5D/misc.f index e189839..17b521c 100644 --- a/source/unres/src-HCD-5D/misc.f +++ b/source/unres/src-HCD-5D/misc.f @@ -4,7 +4,10 @@ C C C logical function find_arg(ipos,line,errflag) + implicit none + integer maxlen parameter (maxlen=80) + integer ipos character*80 line character*1 empty /' '/,equal /'='/ logical errflag @@ -29,6 +32,9 @@ C return end logical function find_group(iunit,jout,key1) + implicit none + integer iunit,jout + integer ll character*(*) key1 character*80 karta,ucase integer ilen @@ -47,6 +53,7 @@ C return end logical function iblnk(charc) + implicit none character*1 charc integer n n = ichar(charc) @@ -54,6 +61,7 @@ C return end integer function ilen(string) + implicit none character*(*) string logical iblnk @@ -67,8 +75,11 @@ C return end integer function in_keywd_set(nkey,ikey,narg,keywd,keywdset) + implicit none + integer nkey character*16 keywd,keywdset(1:nkey,0:nkey) character*16 ucase + integer i,ikey,narg do i=1,narg if (ucase(keywd).eq.keywdset(i,ikey)) then * Match found @@ -81,6 +92,7 @@ C return end character*(*) function lcase(string) + implicit none integer i, k, idiff character*(*) string character*1 c @@ -105,6 +117,8 @@ c return end logical function lcom(ipos,karta) + implicit none + integer ipos,i character*80 karta character koment(2) /'!','#'/ lcom=.false. @@ -119,6 +133,7 @@ c return end subroutine mykey(line,keywd,ipos,blankline,errflag) + implicit none * This subroutine seeks a non-empty substring keywd in the string LINE. * The substring begins with the first character different from blank and * "=" encountered right to the pointer IPOS (inclusively) and terminates @@ -128,11 +143,13 @@ c * only separators or the maximum length of the data line (80) has been reached. * The logical variable ERRFLAG is set at .TRUE. if the string * consists only from a "=". + integer maxlen parameter (maxlen=80) character*1 empty /' '/,equal /'='/,comma /','/ character*(*) keywd character*80 line logical blankline,errflag,lcom + integer ipos,istart,iend errflag=.false. do while (line(ipos:ipos).eq.empty .and. (ipos.le.maxlen)) ipos=ipos+1 @@ -160,6 +177,8 @@ c return end subroutine numstr(inum,numm) + implicit none + integer inum,inum1,inum2,inumm character*10 huj /'0123456789'/ character*(*) numm inumm=inum @@ -178,6 +197,7 @@ c return end character*(*) function ucase(string) + implicit none integer i, k, idiff character*(*) string character*1 c diff --git a/source/unres/src-HCD-5D/moments.f b/source/unres/src-HCD-5D/moments.f deleted file mode 100644 index 983ce36..0000000 --- a/source/unres/src-HCD-5D/moments.f +++ /dev/null @@ -1,328 +0,0 @@ - subroutine inertia_tensor -c Calculating the intertia tensor for the entire protein in order to -c remove the perpendicular components of velocity matrix which cause -c the molecule to rotate. - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - - double precision Im(3,3),Imcp(3,3),cm(3),pr(3),M_SC, - & eigvec(3,3),Id(3,3),eigval(3),L(3),vp(3),vrot(3), - & vpp(3,0:MAXRES),vs_p(3),pr1(3,3), - & pr2(3,3),pp(3),incr(3),v(3),mag,mag2 - common /gucio/ cm - integer iti,inres - do i=1,3 - do j=1,3 - Im(i,j)=0.0d0 - pr1(i,j)=0.0d0 - pr2(i,j)=0.0d0 - enddo - L(i)=0.0d0 - cm(i)=0.0d0 - vrot(i)=0.0d0 - enddo -c calculating the center of the mass of the protein - do i=nnt,nct-1 - do j=1,3 - cm(j)=cm(j)+c(j,i)+0.5d0*dc(j,i) - enddo - enddo - do j=1,3 - cm(j)=mp*cm(j) - enddo - M_SC=0.0d0 - do i=nnt,nct - iti=iabs(itype(i)) - M_SC=M_SC+msc(iabs(iti)) - inres=i+nres - do j=1,3 - cm(j)=cm(j)+msc(iabs(iti))*c(j,inres) - enddo - enddo - do j=1,3 - cm(j)=cm(j)/(M_SC+(nct-nnt)*mp) - enddo - - do i=nnt,nct-1 - do j=1,3 - pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) - enddo - Im(1,1)=Im(1,1)+mp*(pr(2)*pr(2)+pr(3)*pr(3)) - Im(1,2)=Im(1,2)-mp*pr(1)*pr(2) - Im(1,3)=Im(1,3)-mp*pr(1)*pr(3) - Im(2,3)=Im(2,3)-mp*pr(2)*pr(3) - Im(2,2)=Im(2,2)+mp*(pr(3)*pr(3)+pr(1)*pr(1)) - Im(3,3)=Im(3,3)+mp*(pr(1)*pr(1)+pr(2)*pr(2)) - enddo - - do i=nnt,nct - iti=iabs(itype(i)) - inres=i+nres - do j=1,3 - pr(j)=c(j,inres)-cm(j) - enddo - Im(1,1)=Im(1,1)+msc(iabs(iti))*(pr(2)*pr(2)+pr(3)*pr(3)) - Im(1,2)=Im(1,2)-msc(iabs(iti))*pr(1)*pr(2) - Im(1,3)=Im(1,3)-msc(iabs(iti))*pr(1)*pr(3) - Im(2,3)=Im(2,3)-msc(iabs(iti))*pr(2)*pr(3) - Im(2,2)=Im(2,2)+msc(iabs(iti))*(pr(3)*pr(3)+pr(1)*pr(1)) - Im(3,3)=Im(3,3)+msc(iabs(iti))*(pr(1)*pr(1)+pr(2)*pr(2)) - enddo - - do i=nnt,nct-1 - Im(1,1)=Im(1,1)+Ip*(1-dc_norm(1,i)*dc_norm(1,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(1,2)=Im(1,2)+Ip*(-dc_norm(1,i)*dc_norm(2,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(1,3)=Im(1,3)+Ip*(-dc_norm(1,i)*dc_norm(3,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(2,3)=Im(2,3)+Ip*(-dc_norm(2,i)*dc_norm(3,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(2,2)=Im(2,2)+Ip*(1-dc_norm(2,i)*dc_norm(2,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - Im(3,3)=Im(3,3)+Ip*(1-dc_norm(3,i)*dc_norm(3,i))* - & vbld(i+1)*vbld(i+1)*0.25d0 - enddo - - - do i=nnt,nct - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - iti=iabs(itype(i)) - inres=i+nres - Im(1,1)=Im(1,1)+Isc(iti)*(1-dc_norm(1,inres)* - & dc_norm(1,inres))*vbld(inres)*vbld(inres) - Im(1,2)=Im(1,2)-Isc(iti)*(dc_norm(1,inres)* - & dc_norm(2,inres))*vbld(inres)*vbld(inres) - Im(1,3)=Im(1,3)-Isc(iti)*(dc_norm(1,inres)* - & dc_norm(3,inres))*vbld(inres)*vbld(inres) - Im(2,3)=Im(2,3)-Isc(iti)*(dc_norm(2,inres)* - & dc_norm(3,inres))*vbld(inres)*vbld(inres) - Im(2,2)=Im(2,2)+Isc(iti)*(1-dc_norm(2,inres)* - & dc_norm(2,inres))*vbld(inres)*vbld(inres) - Im(3,3)=Im(3,3)+Isc(iti)*(1-dc_norm(3,inres)* - & dc_norm(3,inres))*vbld(inres)*vbld(inres) - endif - enddo - - call angmom(cm,L) -c write(iout,*) "The angular momentum before adjustment:" -c write(iout,*) (L(j),j=1,3) - - Im(2,1)=Im(1,2) - Im(3,1)=Im(1,3) - Im(3,2)=Im(2,3) - -c Copying the Im matrix for the djacob subroutine - do i=1,3 - do j=1,3 - Imcp(i,j)=Im(i,j) - Id(i,j)=0.0d0 - enddo - enddo - -c Finding the eigenvectors and eignvalues of the inertia tensor - call djacob(3,3,10000,1.0d-10,Imcp,eigvec,eigval) -c write (iout,*) "Eigenvalues & Eigenvectors" -c write (iout,'(5x,3f10.5)') (eigval(i),i=1,3) -c write (iout,*) -c do i=1,3 -c write (iout,'(i5,3f10.5)') i,(eigvec(i,j),j=1,3) -c enddo -c Constructing the diagonalized matrix - do i=1,3 - if (dabs(eigval(i)).gt.1.0d-15) then - Id(i,i)=1.0d0/eigval(i) - else - Id(i,i)=0.0d0 - endif - enddo - do i=1,3 - do j=1,3 - Imcp(i,j)=eigvec(j,i) - enddo - enddo - do i=1,3 - do j=1,3 - do k=1,3 - pr1(i,j)=pr1(i,j)+Id(i,k)*Imcp(k,j) - enddo - enddo - enddo - do i=1,3 - do j=1,3 - do k=1,3 - pr2(i,j)=pr2(i,j)+eigvec(i,k)*pr1(k,j) - enddo - enddo - enddo -c Calculating the total rotational velocity of the molecule - do i=1,3 - do j=1,3 - vrot(i)=vrot(i)+pr2(i,j)*L(j) - enddo - enddo -c Resetting the velocities - do i=nnt,nct-1 - call vecpr(vrot(1),dc(1,i),vp) - do j=1,3 - d_t(j,i)=d_t(j,i)-vp(j) - enddo - enddo - do i=nnt,nct - if(itype(i).ne.10 .and. itype(i).ne.ntyp1) then - inres=i+nres - call vecpr(vrot(1),dc(1,inres),vp) - do j=1,3 - d_t(j,inres)=d_t(j,inres)-vp(j) - enddo - endif - enddo - call angmom(cm,L) -c write(iout,*) "The angular momentum after adjustment:" -c write(iout,*) (L(j),j=1,3) - return - end -c---------------------------------------------------------------------------- - subroutine angmom(cm,L) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.CONTROL' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.NAMES' - - double precision L(3),cm(3),pr(3),vp(3),vrot(3),incr(3),v(3), - & pp(3) - integer iti,inres -c Calculate the angular momentum - do j=1,3 - L(j)=0.0d0 - enddo - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct-1 - do j=1,3 - pr(j)=c(j,i)+0.5d0*dc(j,i)-cm(j) - enddo - do j=1,3 - v(j)=incr(j)+0.5d0*d_t(j,i) - enddo - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - call vecpr(pr(1),v(1),vp) - do j=1,3 - L(j)=L(j)+mp*vp(j) - enddo - do j=1,3 - pr(j)=0.5d0*dc(j,i) - pp(j)=0.5d0*d_t(j,i) - enddo - call vecpr(pr(1),pp(1),vp) - do j=1,3 - L(j)=L(j)+Ip*vp(j) - enddo - enddo - do j=1,3 - incr(j)=d_t(j,0) - enddo - do i=nnt,nct - iti=iabs(itype(i)) - inres=i+nres - do j=1,3 - pr(j)=c(j,inres)-cm(j) - enddo - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - v(j)=incr(j)+d_t(j,inres) - enddo - else - do j=1,3 - v(j)=incr(j) - enddo - endif - call vecpr(pr(1),v(1),vp) -c write (iout,*) "i",i," iti",iti," pr",(pr(j),j=1,3), -c & " v",(v(j),j=1,3)," vp",(vp(j),j=1,3) - do j=1,3 - L(j)=L(j)+msc(iabs(iti))*vp(j) - enddo -c write (iout,*) "L",(l(j),j=1,3) - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - v(j)=incr(j)+d_t(j,inres) - enddo - call vecpr(dc(1,inres),d_t(1,inres),vp) - do j=1,3 - L(j)=L(j)+Isc(iti)*vp(j) - enddo - endif - do j=1,3 - incr(j)=incr(j)+d_t(j,i) - enddo - enddo - return - end -c------------------------------------------------------------------------------ - subroutine vcm_vel(vcm) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.MD' - include 'COMMON.CHAIN' - include 'COMMON.DERIV' - include 'COMMON.GEO' - include 'COMMON.LOCAL' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - double precision vcm(3),vv(3),summas,amas - do j=1,3 - vcm(j)=0.0d0 - vv(j)=d_t(j,0) - enddo - summas=0.0d0 - do i=nnt,nct - if (i.lt.nct) then - summas=summas+mp - do j=1,3 - vcm(j)=vcm(j)+mp*(vv(j)+0.5d0*d_t(j,i)) - enddo - endif - amas=msc(iabs(itype(i))) - summas=summas+amas - if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - do j=1,3 - vcm(j)=vcm(j)+amas*(vv(j)+d_t(j,i+nres)) - enddo - else - do j=1,3 - vcm(j)=vcm(j)+amas*vv(j) - enddo - endif - do j=1,3 - vv(j)=vv(j)+d_t(j,i) - enddo - enddo -c write (iout,*) "vcm",(vcm(j),j=1,3)," summas",summas - do j=1,3 - vcm(j)=vcm(j)/summas - enddo - return - end diff --git a/source/unres/src-HCD-5D/muca_md.f b/source/unres/src-HCD-5D/muca_md.f deleted file mode 100644 index c10a6a7..0000000 --- a/source/unres/src-HCD-5D/muca_md.f +++ /dev/null @@ -1,334 +0,0 @@ - subroutine muca_delta(remd_t_bath,remd_ene,i,iex,delta) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.MD' - double precision remd_t_bath(maxprocs) - double precision remd_ene(maxprocs) - double precision muca_ene - double precision betai,betaiex,delta - - betai=1.0/(Rb*remd_t_bath(i)) - betaiex=1.0/(Rb*remd_t_bath(iex)) - - delta=betai*(muca_ene(remd_ene(iex),i,remd_t_bath)- - & muca_ene(remd_ene(i),i,remd_t_bath)) - & -betaiex*(muca_ene(remd_ene(iex),iex,remd_t_bath)- - & muca_ene(remd_ene(i),iex,remd_t_bath)) - - return - end - - double precision function muca_ene(energy,i,remd_t_bath) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.MD' - double precision y,yp,energy - double precision remd_t_bath(maxprocs) - integer i - - if (energy.lt.elowi(i)) then - call splint(emuca,nemuca,nemuca2,nmuca,elowi(i),y,yp) - muca_ene=remd_t_bath(i)*Rb*(yp*(energy-elowi(i))+y) - elseif (energy.gt.ehighi(i)) then - call splint(emuca,nemuca,nemuca2,nmuca,ehighi(i),y,yp) - muca_ene=remd_t_bath(i)*Rb*(yp*(energy-ehighi(i))+y) - else - call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) - muca_ene=remd_t_bath(i)*Rb*y - endif - return - end - - subroutine read_muca - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.CONTROL' - include 'COMMON.MD' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision yp1,ypn,yp,x,muca_factor,y,muca_ene - imtime=0 - do i=1,4*maxres - hist(i)=0 - enddo - if (modecalc.eq.14.and..not.remd_tlist) then - print *,"MUCAREMD works only with TLIST" - stop - endif - open(89,file='muca.input') - read(89,*) - read(89,*) - if (modecalc.eq.14) then - read(89,*) (elowi(i),ehighi(i),i=1,nrep) - if (remd_mlist) then - k=0 - do i=1,nrep - do j=1,remd_m(i) - i2rep(k)=i - k=k+1 - enddo - enddo - elow=elowi(i2rep(me)) - ehigh=ehighi(i2rep(me)) - elowi(me+1)=elow - ehighi(me+1)=ehigh - else - elow=elowi(me+1) - ehigh=ehighi(me+1) - endif - else - read(89,*) elow,ehigh - elowi(1)=elow - ehighi(1)=ehigh - endif - i=0 - do while(.true.) - i=i+1 - read(89,*,end=100) emuca(i),nemuca(i) -cd nemuca(i)=nemuca(i)*remd_t(me+1)*Rb - enddo - 100 continue - nmuca=i-1 - hbin=emuca(nmuca)-emuca(nmuca-1) - write (iout,*) 'hbin',hbin - write (iout,*) me,'elow,ehigh',elow,ehigh - yp1=0 - ypn=0 - call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) - factor_min=0.0d0 - factor_min=muca_factor(ehigh) - call print_muca - return - end - - - subroutine print_muca - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.CONTROL' - include 'COMMON.MD' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision yp1,ypn,yp,x,muca_factor,y,muca_ene - double precision dummy(maxprocs) - - if (remd_mlist) then - k=0 - do i=1,nrep - do j=1,remd_m(i) - i2rep(k)=i - k=k+1 - enddo - enddo - endif - - do i=1,nmuca -c print *,'nemuca ',emuca(i),nemuca(i) - do j=0,4 - x=emuca(i)+hbin/5*j - if (modecalc.eq.14) then - if (remd_mlist) then - yp=muca_factor(x)*remd_t(i2rep(me))*Rb - dummy(me+1)=remd_t(i2rep(me)) - y=muca_ene(x,me+1,dummy) - else - yp=muca_factor(x)*remd_t(me+1)*Rb - y=muca_ene(x,me+1,remd_t) - endif - write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime, - & 'muca factor ',x,yp,' muca ene',y - else - yp=muca_factor(x)*t_bath*Rb - dummy(1)=t_bath - y=muca_ene(x,1,dummy) - write (iout,'(i4,i12,a12,2f15.5,a10,f15.5)') me,imtime, - & 'muca factor ',x,yp,' muca ene',y - endif - enddo - enddo - if(mucadyn.gt.0) then - do i=1,nmuca - write(iout,'(a13,i8,2f12.5)') 'nemuca after ', - & imtime,emuca(i),nemuca(i) - enddo - endif - return - end - - subroutine muca_update(energy) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - include 'COMMON.CONTROL' - include 'COMMON.MD' - include 'COMMON.REMD' - include 'COMMON.SETUP' - include 'COMMON.IOUNITS' - double precision energy - double precision yp1,ypn - integer k - logical lnotend - - k=int((energy-emuca(1))/hbin)+1 - - IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN - if(energy.ge.ehigh) - & write (iout,*) 'MUCA reject',energy,emuca(k) - if(energy.ge.ehigh.and.(energy-ehigh).lt.hbin) then - write (iout,*) 'MUCA ehigh',energy,emuca(k) - do i=k,nmuca - hist(i)=hist(i)+1 - enddo - endif - if(k.gt.0.and.energy.lt.ehigh) hist(k)=hist(k)+1 - ELSE - if(k.gt.0.and.k.lt.4*maxres) hist(k)=hist(k)+1 - ENDIF - if(mod(imtime,mucadyn).eq.0) then - - do i=1,nmuca - IF(muca_smooth.eq.2.or.muca_smooth.eq.3) THEN - nemuca(i)=nemuca(i)+dlog(hist(i)+1) - ELSE - if (hist(i).gt.0) hist(i)=dlog(hist(i)) - nemuca(i)=nemuca(i)+hist(i) - ENDIF - hist(i)=0 - write(iout,'(a24,i8,2f12.5)')'nemuca before smoothing ', - & imtime,emuca(i),nemuca(i) - enddo - - - lnotend=.true. - ismooth=0 - ist=2 - ien=nmuca-1 - IF(muca_smooth.eq.1.or.muca_smooth.eq.3) THEN -c lnotend=.false. -c do i=1,nmuca-1 -c do j=i+1,nmuca -c if(nemuca(j).lt.nemuca(i)) lnotend=.true. -c enddo -c enddo - do while(lnotend) - ismooth=ismooth+1 - write (iout,*) 'MUCA update smoothing',ist,ien - do i=ist,ien - nemuca(i)=(nemuca(i-1)+nemuca(i)+nemuca(i+1))/3 - enddo - lnotend=.false. - ist=0 - ien=0 - do i=1,nmuca-1 - do j=i+1,nmuca - if(nemuca(j).lt.nemuca(i)) then - lnotend=.true. - if(ist.eq.0) ist=i-1 - if(ien.lt.j+1) ien=j+1 - endif - enddo - enddo - enddo - ENDIF - - write (iout,*) 'MUCA update ',imtime,' smooth= ',ismooth - yp1=0 - ypn=0 - call spline(emuca,nemuca,nmuca,yp1,ypn,nemuca2) - call print_muca - - endif - return - end - - double precision function muca_factor(energy) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.MUCA' - double precision y,yp,energy - - if (energy.lt.elow) then - call splint(emuca,nemuca,nemuca2,nmuca,elow,y,yp) - elseif (energy.gt.ehigh) then - call splint(emuca,nemuca,nemuca2,nmuca,ehigh,y,yp) - else - call splint(emuca,nemuca,nemuca2,nmuca,energy,y,yp) - endif - - if(yp.ge.factor_min) then - muca_factor=yp - else - muca_factor=factor_min - endif -cd print *,'energy, muca_factor',energy,muca_factor - return - end - - - SUBROUTINE spline(x,y,n,yp1,ypn,y2) - INTEGER n,NMAX - REAL*8 yp1,ypn,x(n),y(n),y2(n) - PARAMETER (NMAX=500) - INTEGER i,k - REAL*8 p,qn,sig,un,u(NMAX) - if (yp1.gt..99e30) then - y2(1)=0. - u(1)=0. - else - y2(1)=-0.5 - u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) - endif - do i=2,n-1 - sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) - p=sig*y2(i-1)+2. - y2(i)=(sig-1.)/p - u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) - * /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p - enddo - if (ypn.gt..99e30) then - qn=0. - un=0. - else - qn=0.5 - un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1))) - endif - y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) - do k=n-1,1,-1 - y2(k)=y2(k)*y2(k+1)+u(k) - enddo - return - END - - - SUBROUTINE splint(xa,ya,y2a,n,x,y,yp) - INTEGER n - REAL*8 x,y,xa(n),y2a(n),ya(n),yp - INTEGER k,khi,klo - REAL*8 a,b,h - klo=1 - khi=n - 1 if (khi-klo.gt.1) then - k=(khi+klo)/2 - if (xa(k).gt.x) then - khi=k - else - klo=k - endif - goto 1 - endif - h=xa(khi)-xa(klo) - if (h.eq.0.) pause 'bad xa input in splint' - a=(xa(khi)-x)/h - b=(x-xa(klo))/h - y=a*ya(klo)+b*ya(khi)+ - * ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6. - yp=-ya(klo)/h+ya(khi)/h-3*(a**2)*y2a(klo)*h/6. - + +(3*(b**2)-1)*y2a(khi)*h/6. - return - END diff --git a/source/unres/src-HCD-5D/newconf.f b/source/unres/src-HCD-5D/newconf.f index 5f93b95..9791555 100644 --- a/source/unres/src-HCD-5D/newconf.f +++ b/source/unres/src-HCD-5D/newconf.f @@ -10,7 +10,7 @@ ccccccccccccccccccccccccccccccccccccccccccccccccc include 'COMMON.INTERACT' include 'COMMON.HAIRPIN' include 'COMMON.VAR' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.GEO' include 'COMMON.CONTROL' logical nicht_getan,nicht_getan1,fail,lfound @@ -2299,7 +2299,7 @@ ccccccccccccccccccccccccccccccccccccccccccccccccc include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.HAIRPIN' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' character*50 linia integer isec(maxres) diff --git a/source/unres/src-HCD-5D/parmread.F b/source/unres/src-HCD-5D/parmread.F index aad982a..2da8851 100644 --- a/source/unres/src-HCD-5D/parmread.F +++ b/source/unres/src-HCD-5D/parmread.F @@ -7,7 +7,7 @@ C Important! Energy-term weights ARE NOT read here; they are read from the C main input file instead, because NO defaults have yet been set for these C parameters. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include "mpif.h" @@ -25,6 +25,20 @@ C include 'COMMON.NAMES' include 'COMMON.SBRIDGE' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif +#ifdef LANG0 +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else + include 'COMMON.LANGEVIN.lang0' +#endif +#else + include 'COMMON.LANGEVIN' +#endif include 'COMMON.SETUP' include 'COMMON.CONTROL' include 'COMMON.SHIELD' @@ -32,11 +46,17 @@ C character*1 onelett(4) /"G","A","P","D"/ character*1 toronelet(-2:2) /"p","a","G","A","P"/ logical lprint,LaTeX - dimension blower(3,3,maxlob) + double precision blower(3,3,maxlob) character*3 string -C dimension b(13) character*3 lancuch,ucase character*1000 weightcard + character*4 res1 + integer i,ii,j,jj,k,kk,l,ll,lll,llll,m,mm,n,iblock,junk,ijunk, + & nkcctyp,maxinter + double precision akl,v0ij,si,rri,epsij,v0ijsccor,epsijlip,rjunk, + & sigt2sq,sigt1sq,sigii1,sigii2,ratsig1,ratsig2,rsum_max,r_augm, + & rrij,sigeps + double precision dwa16 C C For printing parameters after they are read set the following in the UNRES C C-shell script: @@ -653,6 +673,12 @@ c write (iout,*) "itype2loc",(itype2loc(i),i=1,ntyp1) c write (iout,*) "nloctyp",nloctyp, c & " iloctyp",(iloctyp(i),i=0,nloctyp) #ifdef NEWCORR + bnew1=0.0d0 + bnew2=0.0d0 + ccnew=0.0d0 + ddnew=0.0d0 + eenew=0.0d0 + e0new=0.0d0 do i=0,nloctyp-1 c write (iout,*) "NEWCORR",i read (ifourier,*,end=115,err=115) @@ -734,7 +760,8 @@ c ddnew(ii,2,i)=ddnew(ii,2,i)/2 enddo if (lprint) then write (iout,'(a)') "Coefficients of the multibody terms" - do i=-nloctyp+1,nloctyp-1 +c do i=-nloctyp+1,nloctyp-1 + do i=-nloctyp,nloctyp write (iout,*) "Type: ",onelet(iloctyp(i)) write (iout,*) "Coefficients of the expansion of B1" do j=1,2 @@ -981,8 +1008,8 @@ c Dtilde(2,2,i)=0.0d0 EEold(2,2,-i)=-b(10,i)+b(11,i) EEold(2,1,-i)=-b(12,i)+b(13,i) EEold(1,2,-i)=-b(12,i)-b(13,i) -c write(iout,*) "TU DOCHODZE" -c print *,"JESTEM" + write(iout,*) "TU DOCHODZE" + print *,"JESTEM" c ee(1,1,i)=1.0d0 c ee(2,2,i)=1.0d0 c ee(2,1,i)=0.0d0 @@ -1871,7 +1898,7 @@ C Important! Energy-term weights ARE NOT read here; they are read from the C main input file instead, because NO defaults have yet been set for these C parameters. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include "mpif.h" @@ -1893,6 +1920,8 @@ C include 'COMMON.CONTROL' include 'COMMON.SHIELD' character*1000 weightcard + integer i,j + double precision scalscp,wlong c c READ energy-term weights c @@ -2007,8 +2036,15 @@ C 12/1/95 Added weight for the multi-body term WCORR call rescale_weights(t_bath) if(me.eq.king.or..not.out1file) & write (iout,22) wsc,wscp,welec,wvdwpp,wbond,wang,wscloc,wtor, - & wtor_d,wstrain,wel_loc,wcorr,wcorr5,wcorr6,wsccor,wturn3, - & wturn4,wturn6 + & wtor_d,wstrain,wel_loc, +#ifdef FOURBODY + & wcorr,wcorr5,wcorr6, +#endif + & wsccor,wturn3, +#ifdef FOURBODY + & wturn4, +#endif + & wturn6 22 format (/'Energy-term weights (scaled):'// & 'WSCC= ',f10.6,' (SC-SC)'/ & 'WSCP= ',f10.6,' (SC-p)'/ @@ -2021,13 +2057,18 @@ C 12/1/95 Added weight for the multi-body term WCORR & 'WTORD= ',f10.6,' (double torsional)'/ & 'WSTRAIN=',f10.6,' (SS bridges & dist. cnstr.)'/ & 'WEL_LOC=',f10.6,' (multi-body 3-rd order)'/ +#ifdef FOURBODY & 'WCORR4= ',f10.6,' (multi-body 4th order)'/ & 'WCORR5= ',f10.6,' (multi-body 5th order)'/ & 'WCORR6= ',f10.6,' (multi-body 6th order)'/ - & 'WSCCOR= ',f10.6,' (back-scloc correlatkion)'/ +#endif + & 'WSCCOR= ',f10.6,' (back-scloc correlation)'/ & 'WTURN3= ',f10.6,' (turns, 3rd order)'/ & 'WTURN4= ',f10.6,' (turns, 4th order)'/ - & 'WTURN6= ',f10.6,' (turns, 6th order)') +#ifdef FOURBODY + & 'WTURN6= ',f10.6,' (turns, 6th order)' +#endif + & ) if(me.eq.king.or..not.out1file) & write (iout,*) "Reference temperature for weights calculation:", & temp0 diff --git a/source/unres/src-HCD-5D/pinorm.f b/source/unres/src-HCD-5D/pinorm.f index 91392bf..e89e0a4 100644 --- a/source/unres/src-HCD-5D/pinorm.f +++ b/source/unres/src-HCD-5D/pinorm.f @@ -1,5 +1,6 @@ double precision function pinorm(x) - implicit real*8 (a-h,o-z) + implicit none + double precision x c c this function takes an angle (in radians) and puts it in the range of c -pi to +pi. diff --git a/source/unres/src-HCD-5D/printmat.f b/source/unres/src-HCD-5D/printmat.f index be2b38f..397ded7 100644 --- a/source/unres/src-HCD-5D/printmat.f +++ b/source/unres/src-HCD-5D/printmat.f @@ -1,4 +1,6 @@ subroutine printmat(ldim,m,n,iout,key,a) + implicit none + integer ldim,m,n,nlim,iout,i,j,k character*3 key(n) double precision a(ldim,n) do 1 i=1,n,8 diff --git a/source/unres/src-HCD-5D/q_measure-02.F b/source/unres/src-HCD-5D/q_measure-02.F index 5244b2b..a790a8b 100644 --- a/source/unres/src-HCD-5D/q_measure-02.F +++ b/source/unres/src-HCD-5D/q_measure-02.F @@ -240,8 +240,12 @@ c MD with umbrella_sampling using Wolyne's distance measure as a constraint #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -375,8 +379,12 @@ c Calculating numerical dUconst/ddc and dUconst/ddx #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' diff --git a/source/unres/src-HCD-5D/q_measure.F b/source/unres/src-HCD-5D/q_measure.F index ce1d4fe..1c041a0 100644 --- a/source/unres/src-HCD-5D/q_measure.F +++ b/source/unres/src-HCD-5D/q_measure.F @@ -96,6 +96,7 @@ c------------------------------------------------------------------- include 'COMMON.INTERACT' include 'COMMON.VAR' include 'COMMON.MD' + include 'COMMON.QRESTR' integer i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4, & secseg integer nsep /3/ diff --git a/source/unres/src-HCD-5D/q_measure1.F b/source/unres/src-HCD-5D/q_measure1.F index 9c1546d..22b764b 100644 --- a/source/unres/src-HCD-5D/q_measure1.F +++ b/source/unres/src-HCD-5D/q_measure1.F @@ -156,8 +156,12 @@ c MD with umbrella_sampling using Wolyne's distance measure as a constraint #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -260,8 +264,12 @@ c Calculating numerical dUconst/ddc and dUconst/ddx #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' diff --git a/source/unres/src-HCD-5D/q_measure3.F b/source/unres/src-HCD-5D/q_measure3.F index f0a030e..e799940 100644 --- a/source/unres/src-HCD-5D/q_measure3.F +++ b/source/unres/src-HCD-5D/q_measure3.F @@ -6,6 +6,7 @@ include 'COMMON.INTERACT' include 'COMMON.VAR' include 'COMMON.MD' + include 'COMMON.QRESTR' integer i,j,jl,k,l,il,kl,nl,np,seg1,seg2,seg3,seg4,secseg integer nsep /3/ double precision dist,qm @@ -98,6 +99,7 @@ c------------------------------------------------------------------- include 'COMMON.INTERACT' include 'COMMON.VAR' include 'COMMON.MD' + include 'COMMON.QRESTR' integer seg1,seg2,seg3,seg4 logical flag double precision qwolan(3,0:maxres),cdummy(3,0:maxres2), diff --git a/source/unres/src-HCD-5D/rattle.F b/source/unres/src-HCD-5D/rattle.F index 5a8ed0c..b044396 100644 --- a/source/unres/src-HCD-5D/rattle.F +++ b/source/unres/src-HCD-5D/rattle.F @@ -1,23 +1,32 @@ subroutine rattle1 c RATTLE algorithm for velocity Verlet - step 1, UNRES c AL 9/24/04 - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' + include 'COMMON.IOUNITS' #ifdef RATTLE include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' include 'COMMON.LOCAL' include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' include 'COMMON.NAMES' include 'COMMON.TIME1' double precision gginv(maxres2,maxres2), @@ -275,17 +284,27 @@ c------------------------------------------------------------------------------ subroutine rattle2 c RATTLE algorithm for velocity Verlet - step 2, UNRES c AL 9/24/04 - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' + include 'COMMON.IOUNITS' #ifdef RATTLE include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -458,11 +477,20 @@ c AL 9/24/04 include 'COMMON.CONTROL' include 'COMMON.VAR' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' diff --git a/source/unres/src-HCD-5D/readpdb.F b/source/unres/src-HCD-5D/readpdb.F index 68db17c..943d67d 100644 --- a/source/unres/src-HCD-5D/readpdb.F +++ b/source/unres/src-HCD-5D/readpdb.F @@ -1,7 +1,7 @@ subroutine readpdb C Read the PDB file and convert the peptide geometry into virtual-chain C geometry. - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.LOCAL' include 'COMMON.VAR' @@ -11,15 +11,17 @@ C geometry. include 'COMMON.GEO' include 'COMMON.NAMES' include 'COMMON.CONTROL' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.SETUP' include 'COMMON.SBRIDGE' character*3 seq,atom,res character*80 card - dimension sccor(3,50) + double precision sccor(3,50) double precision e1(3),e2(3),e3(3) integer rescode,iterter(maxres),cou logical fail + integer i,j,iii,ires,ires_old,ishift,ibeg + double precision dcj bfac=0.0d0 do i=1,maxres iterter(i)=0 @@ -304,7 +306,7 @@ cc enddiag end c--------------------------------------------------------------------------- subroutine int_from_cart(lside,lprn) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include "mpif.h" @@ -318,11 +320,14 @@ c--------------------------------------------------------------------------- include 'COMMON.NAMES' include 'COMMON.CONTROL' include 'COMMON.SETUP' + double precision dist,alpha,beta character*3 seq,atom,res character*80 card - dimension sccor(3,50) + double precision sccor(3,50) integer rescode logical lside,lprn + integer i,j,iti + double precision di,cosfac2,sinfac2,cosfac,sinfac #ifdef MPI if(me.eq.king.or..not.out1file)then #endif @@ -414,7 +419,7 @@ c print *,"A TU2" end c------------------------------------------------------------------------------- subroutine sc_loc_geom(lprn) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include "mpif.h" @@ -430,6 +435,8 @@ c------------------------------------------------------------------------------- include 'COMMON.SETUP' double precision x_prime(3),y_prime(3),z_prime(3) logical lprn + integer i,j,it + double precision xx,yy,zz,cosfac,cosfac2,sinfac,sinfac2 do i=1,nres-1 do j=1,3 dc_norm(j,i)=vbld_inv(i+1)*(c(j,i+1)-c(j,i)) @@ -521,10 +528,12 @@ c end c--------------------------------------------------------------------------- subroutine sccenter(ires,nscat,sccor) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CHAIN' - dimension sccor(3,50) + integer i,j,ires,nscat + double precision sccor(3,50) + double precision sccmj do j=1,3 sccmj=0.0D0 do i=1,nscat @@ -536,13 +545,13 @@ c--------------------------------------------------------------------------- end c--------------------------------------------------------------------------- subroutine bond_regular - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.LOCAL' - include 'COMMON.CALC' include 'COMMON.INTERACT' include 'COMMON.CHAIN' + integer i,i1,i2 do i=1,nres-1 vbld(i+1)=vbl vbld_inv(i+1)=vblinv @@ -569,7 +578,7 @@ c--------------------------------------------------------------------------- subroutine readpdb_template(k) C Read the PDB file for read_constr_homology with read2sigma C and convert the peptide geometry into virtual-chain geometry. - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.LOCAL' include 'COMMON.VAR' @@ -579,10 +588,10 @@ C and convert the peptide geometry into virtual-chain geometry. include 'COMMON.GEO' include 'COMMON.NAMES' include 'COMMON.CONTROL' - include 'COMMON.DISTFIT' + include 'COMMON.FRAG' include 'COMMON.SETUP' - integer i,j,ibeg,ishift1,ires,iii,ires_old,ishift,ity, - & ishift_pdb + integer i,j,k,ibeg,ishift1,ires,iii,ires_old,ishift,ity, + & ishift_pdb,ires_ca logical lprn /.false./,fail double precision e1(3),e2(3),e3(3) double precision dcj,efree_temp diff --git a/source/unres/src-HCD-5D/readrtns_CSA.F b/source/unres/src-HCD-5D/readrtns_CSA.F index 66f7c17..4765a41 100644 --- a/source/unres/src-HCD-5D/readrtns_CSA.F +++ b/source/unres/src-HCD-5D/readrtns_CSA.F @@ -1,5 +1,5 @@ subroutine readrtns - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -9,6 +9,7 @@ include 'COMMON.SBRIDGE' include 'COMMON.IOUNITS' include 'COMMON.SPLITELE' + integer i,j logical file_exist C Read job setup parameters call read_control @@ -84,18 +85,19 @@ C------------------------------------------------------------------------------- C C Read contorl data C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MP include 'mpif.h' logical OKRandom, prng_restart - real*8 r1 + double precision r1 #endif include 'COMMON.IOUNITS' include 'COMMON.TIME1' include 'COMMON.THREAD' include 'COMMON.SBRIDGE' include 'COMMON.CONTROL' + include 'COMMON.SAXS' include 'COMMON.MCM' include 'COMMON.MAP' include 'COMMON.HEADER' @@ -109,10 +111,13 @@ C include 'COMMON.SPLITELE' include 'COMMON.SHIELD' include 'COMMON.GEO' + integer i + integer KDIAG,ICORFL,IXDR COMMON /MACHSW/ KDIAG,ICORFL,IXDR character*8 diagmeth(0:3) /'Library','EVVRSP','Givens','Jacobi'/ character*80 ucase character*320 controlcard + double precision seed nglob_csa=0 eglob_csa=1d99 @@ -125,6 +130,9 @@ c print *,"Processor",me," fg_rank",fg_rank," out1file",out1file call random_init(seed) C Set up the time limit (caution! The time must be input in minutes!) read_cart=index(controlcard,'READ_CART').gt.0 + out_cart=index(controlcard,'OUT_CART').gt.0 + out_int=index(controlcard,'OUT_INT').gt.0 + gmatout=index(controlcard,'GMATOUT').gt.0 call readi(controlcard,'CONSTR_DIST',constr_dist,0) C this variable with_theta_constr is the variable which allow to read and execute the C constrains on theta angles WITH_THETA_CONSTR is the keyword @@ -144,25 +152,24 @@ C constrains on theta angles WITH_THETA_CONSTR is the keyword call reada(controlcard,'TIMLIM',timlim,2800.0D0) ! default 16 hours unres_pdb = index(controlcard,'UNRES_PDB') .gt. 0 call reada(controlcard,'SAFETY',safety,30.0D0) ! default 30 minutes - call reada(controlcard,'RMSDBC',rmsdbc,3.0D0) - call reada(controlcard,'RMSDBC1',rmsdbc1,0.5D0) - call reada(controlcard,'RMSDBC1MAX',rmsdbc1max,1.5D0) - call reada(controlcard,'RMSDBCM',rmsdbcm,3.0D0) - call reada(controlcard,'DRMS',drms,0.1D0) - if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then - write (iout,'(a,f10.1)')'RMSDBC = ',rmsdbc - write (iout,'(a,f10.1)')'RMSDBC1 = ',rmsdbc1 - write (iout,'(a,f10.1)')'RMSDBC1MAX = ',rmsdbc1max - write (iout,'(a,f10.1)')'DRMS = ',drms - write (iout,'(a,f10.1)')'RMSDBCM = ',rmsdbcm - write (iout,'(a,f10.1)') 'Time limit (min):',timlim - endif +c call reada(controlcard,'RMSDBC',rmsdbc,3.0D0) +c call reada(controlcard,'RMSDBC1',rmsdbc1,0.5D0) +c call reada(controlcard,'RMSDBC1MAX',rmsdbc1max,1.5D0) +c call reada(controlcard,'RMSDBCM',rmsdbcm,3.0D0) +c call reada(controlcard,'DRMS',drms,0.1D0) +c if(me.eq.king .or. .not. out1file .and. fg_rank.eq.0) then +c write (iout,'(a,f10.1)')'RMSDBC = ',rmsdbc +c write (iout,'(a,f10.1)')'RMSDBC1 = ',rmsdbc1 +c write (iout,'(a,f10.1)')'RMSDBC1MAX = ',rmsdbc1max +c write (iout,'(a,f10.1)')'DRMS = ',drms +cc write (iout,'(a,f10.1)')'RMSDBCM = ',rmsdbcm +c write (iout,'(a,f10.1)') 'Time limit (min):',timlim +c endif call readi(controlcard,'NZ_START',nz_start,0) call readi(controlcard,'NZ_END',nz_end,0) c call readi(controlcard,'IZ_SC',iz_sc,0) timlim=60.0D0*timlim safety = 60.0d0*safety - timem=timlim modecalc=0 call reada(controlcard,"T_BATH",t_bath,300.0d0) minim=(index(controlcard,'MINIMIZE').gt.0) @@ -297,9 +304,16 @@ C Reading the dimensions of box in x,y,z coordinates call reada(controlcard,'BOXX',boxxsize,100.0d0) call reada(controlcard,'BOXY',boxysize,100.0d0) call reada(controlcard,'BOXZ',boxzsize,100.0d0) + write(iout,*) "Periodic box dimensions",boxxsize,boxysize,boxzsize c Cutoff range for interactions - call reada(controlcard,"R_CUT",r_cut,15.0d0) + call reada(controlcard,"R_CUT_INT",r_cut_int,25.0d0) + call reada(controlcard,"R_CUT_RESPA",r_cut_respa,2.0d0) call reada(controlcard,"LAMBDA",rlamb,0.3d0) + write (iout,*) "Cutoff on interactions",r_cut_int + write (iout,*) + & "Cutoff in switching short and long range interactions in RESPA", + & r_cut_respa + write (iout,*) "lambda in switch function",rlamb call reada(controlcard,"LIPTHICK",lipthick,0.0d0) call reada(controlcard,"LIPAQBUF",lipbufthick,0.0d0) if (lipthick.gt.0.0d0) then @@ -328,25 +342,6 @@ C endif buftubebot=bordtubebot+tubebufthick buftubetop=bordtubetop-tubebufthick endif -c if (shield_mode.gt.0) then -c pi=3.141592d0 -C VSolvSphere the volume of solving sphere -C print *,pi,"pi" -C rpp(1,1) is the energy r0 for peptide group contact and will be used for it -C there will be no distinction between proline peptide group and normal peptide -C group in case of shielding parameters -c write (iout,*) "rpp(1,1)",rpp(1,1)," pi",pi -c VSolvSphere=4.0/3.0*pi*rpp(1,1)**3 -c VSolvSphere_div=VSolvSphere-4.0/3.0*pi*(rpp(1,1)/2.0)**3 -c write (iout,*) "VSolvSphere",VSolvSphere,"VSolvSphere_div", -c & VSolvSphere_div -C long axis of side chain -c do i=1,ntyp -c long_r_sidechain(i)=vbldsc0(1,i) -c short_r_sidechain(i)=sigma0(i) -c enddo -c buff_shield=1.0d0 -c endif if (me.eq.king .or. .not.out1file ) & write (iout,*) "DISTCHAINMAX",distchainmax @@ -360,7 +355,7 @@ c-------------------------------------------------------------------------- C C Read REMD settings C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.TIME1' @@ -368,8 +363,12 @@ C #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.INTERACT' include 'COMMON.NAMES' include 'COMMON.GEO' @@ -379,7 +378,7 @@ C character*80 ucase character*320 controlcard character*3200 controlcard1 - integer iremd_m_total + integer iremd_m_total,i if(me.eq.king.or..not.out1file) & write (iout,*) "REMD setup" @@ -445,16 +444,21 @@ c-------------------------------------------------------------------------- C C Read MD settings C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.TIME1' include 'COMMON.MD' + include 'COMMON.QRESTR' #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.INTERACT' include 'COMMON.NAMES' include 'COMMON.GEO' @@ -464,6 +468,8 @@ C include 'COMMON.FFIELD' character*80 ucase character*320 controlcard + integer i + double precision eta call card_concat(controlcard) call readi(controlcard,"NSTEP",n_timestep,1000000) @@ -545,7 +551,7 @@ c if performing umbrella sampling, fragments constrained are read from the frag & "A-MTS algorithm used; initial time step for fast-varying", & " short-range forces split into",ntime_split," steps." write (iout,'(a,f5.2,a,f5.2)') "Short-range force cutoff", - & r_cut," lambda",rlamb + & r_cut_respa," lambda",rlamb endif write (iout,'(2a,f10.5)') & "Maximum acceleration threshold to reduce the time step", @@ -681,11 +687,11 @@ c------------------------------------------------------------------------------ C C Read molecular data. C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' - integer error_msg + integer error_msg,ierror,ierr,ierrcode #endif include 'COMMON.IOUNITS' include 'COMMON.GEO' @@ -698,6 +704,7 @@ C include 'COMMON.SBRIDGE' include 'COMMON.HEADER' include 'COMMON.CONTROL' + include 'COMMON.SAXS' include 'COMMON.DBASE' include 'COMMON.THREAD' include 'COMMON.CONTACTS' @@ -713,14 +720,19 @@ C character*256 pdbfile character*400 weightcard character*80 weightcard_t,ucase - dimension itype_pdb(maxres) + integer itype_pdb(maxres) common /pizda/ itype_pdb logical seq_comp,fail double precision energia(0:n_ene) double precision secprob(3,maxdih_constr) + double precision co + double precision phihel,phibet,sigmahel,sigmabet + integer iti,nsi,maxsi integer ilen external ilen - integer tperm + integer iperm,tperm + integer i,j,ii,k,l,itrial,itmp,i1,i2,it1,it2 + double precision sumv C C Read PDB structure if applicable C @@ -789,25 +801,6 @@ C Convert sequence to numeric code do i=1,nres itype(i)=rescode(i,sequence(i),iscode) enddo -C Assign initial virtual bond lengths -c do i=2,nres -c vbld(i)=vbl -c vbld_inv(i)=vblinv -c enddo -c if (itype(1).eq.ntyp1) then -c vbld(2)=vbld(2)/2 -c vbld_inv(2)=vbld_inv(2)*2 -c endif -c if (itype(nres).eq.ntyp1) then -c vbld(nres)=vbld(nres)/2 -c vbld_inv(nres)=vbld_inv(nres)*2 -c endif -c do i=2,nres-1 -c vbld(i+nres)=dsc(iabs(itype(i))) -c vbld_inv(i+nres)=dsc_inv(iabs(itype(i))) -c write (iout,*) "i",i," itype",itype(i), -c & " dsc",dsc(itype(i))," vbld",vbld(i),vbld(i+nres) -c enddo endif c print *,nres c print '(20i4)',(itype(i),i=1,nres) @@ -840,10 +833,18 @@ c print '(20i4)',(itype(i),i=1,nres) cd print *,'NNT=',NNT,' NCT=',NCT call seq2chains(nres,itype,nchain,chain_length,chain_border, & ireschain) + chain_border1(1,1)=1 + chain_border1(2,1)=chain_border(2,1)+1 + do i=2,nchain-1 + chain_border1(1,i)=chain_border(1,i)-1 + chain_border1(2,i)=chain_border(2,i)+1 + enddo + chain_border1(1,nchain)=chain_border(1,nchain)-1 + chain_border1(2,nchain)=nres write(iout,*) "nres",nres," nchain",nchain do i=1,nchain write(iout,*)"chain",i,chain_length(i),chain_border(1,i), - & chain_border(2,i) + & chain_border(2,i),chain_border1(1,i),chain_border1(2,i) enddo call chain_symmetry(nchain,nres,itype,chain_border, & chain_length,npermchain,tabpermchain) @@ -855,8 +856,11 @@ c enddo do i=1,nres write(iout,*) i,(iperm(i,ii),ii=1,npermchain) enddo + call flush(iout) if (itype(1).eq.ntyp1) nnt=2 if (itype(nres).eq.ntyp1) nct=nct-1 + write (iout,*) "nnt",nnt," nct",nct + call flush(iout) #ifdef DFA if (.not. (wdfa_dist.eq.0.0 .and. wdfa_tor.eq.0.0 .and. & wdfa_nei.eq.0.0 .and. wdfa_beta.eq.0.0)) then @@ -1372,10 +1376,11 @@ c-------------------------------------------------------------------------- c----------------------------------------------------------------------------- subroutine read_bridge C Read information about disulfide bridges. - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' + integer ierror #endif include 'COMMON.IOUNITS' include 'COMMON.GEO' @@ -1392,6 +1397,7 @@ C Read information about disulfide bridges. include 'COMMON.THREAD' include 'COMMON.TIME1' include 'COMMON.SETUP' + integer i,j C Read bridging residues. read (inp,*) ns,(iss(i),i=1,ns) print *,'ns=',ns @@ -1447,8 +1453,8 @@ C bridging residues. enddo write (iout,'(a,i3,a)') 'Pair',i,' contains unknown cystine.' 20 continue - dhpb(i)=dbr - forcon(i)=fbr +c dhpb(i)=dbr +c forcon(i)=fbr enddo do i=1,nss ihpb(i)=ihpb(i)+nres @@ -1460,7 +1466,7 @@ C bridging residues. end c---------------------------------------------------------------------------- subroutine read_x(kanal,*) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' @@ -1469,6 +1475,7 @@ c---------------------------------------------------------------------------- include 'COMMON.CONTROL' include 'COMMON.LOCAL' include 'COMMON.INTERACT' + integer i,j,k,l,kanal c Read coordinates from input c read(kanal,'(8f10.5)',end=10,err=10) @@ -1499,7 +1506,7 @@ c end c---------------------------------------------------------------------------- subroutine read_threadbase - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.GEO' @@ -1515,6 +1522,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DBASE' include 'COMMON.THREAD' include 'COMMON.TIME1' + integer i,j,k + double precision dist C Read pattern database for threading. read (icbase,*) nseq do i=1,nseq @@ -1544,7 +1553,7 @@ c & nres_base(1,i)) end c------------------------------------------------------------------------------ subroutine setup_var - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.GEO' @@ -1560,17 +1569,17 @@ c------------------------------------------------------------------------------ include 'COMMON.DBASE' include 'COMMON.THREAD' include 'COMMON.TIME1' + integer i C Set up variable list. ntheta=nres-2 nphi=nres-3 nvar=ntheta+nphi nside=0 - write (iout,*) "SETUP_VAR ialph" do i=2,nres-1 if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then - nside=nside+1 + nside=nside+1 ialph(i,1)=nvar+nside - ialph(nside,2)=i + ialph(nside,2)=i endif enddo if (indphi.gt.0) then @@ -1580,13 +1589,12 @@ C Set up variable list. else nvar=nvar+2*nside endif - write (iout,'(3i4)') (i,ialph(i,1),ialph(i,2),i=2,nres-1) return end c---------------------------------------------------------------------------- subroutine gen_dist_constr C Generate CA distance constraints. - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.GEO' @@ -1602,8 +1610,9 @@ C Generate CA distance constraints. include 'COMMON.DBASE' include 'COMMON.THREAD' include 'COMMON.TIME1' - dimension itype_pdb(maxres) + integer i,j,itype_pdb(maxres) common /pizda/ itype_pdb + double precision dist character*2 iden cd print *,'gen_dist_constr: nnt=',nnt,' nct=',nct cd write (2,*) 'gen_dist_constr: nnt=',nnt,' nct=',nct, @@ -1638,10 +1647,11 @@ cd enddo end c---------------------------------------------------------------------------- subroutine map_read - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.MAP' include 'COMMON.IOUNITS' + integer imap character*3 angid(4) /'THE','PHI','ALP','OME'/ character*80 mapcard,ucase do imap=1,nmap @@ -1684,7 +1694,7 @@ c---------------------------------------------------------------------------- end c---------------------------------------------------------------------------- subroutine csaread - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.GEO' @@ -1746,114 +1756,15 @@ c!bankt return end c---------------------------------------------------------------------------- -cfmc subroutine mcmfread -cfmc implicit real*8 (a-h,o-z) -cfmc include 'DIMENSIONS' -cfmc include 'COMMON.MCMF' -cfmc include 'COMMON.IOUNITS' -cfmc include 'COMMON.GEO' -cfmc character*80 ucase -cfmc character*620 mcmcard -cfmc call card_concat(mcmcard) -cfmc -cfmc call readi(mcmcard,'MAXRANT',maxrant,1000) -cfmc write(iout,*)'MAXRANT=',maxrant -cfmc call readi(mcmcard,'MAXFAM',maxfam,maxfam_p) -cfmc write(iout,*)'MAXFAM=',maxfam -cfmc call readi(mcmcard,'NNET1',nnet1,5) -cfmc write(iout,*)'NNET1=',nnet1 -cfmc call readi(mcmcard,'NNET2',nnet2,4) -cfmc write(iout,*)'NNET2=',nnet2 -cfmc call readi(mcmcard,'NNET3',nnet3,4) -cfmc write(iout,*)'NNET3=',nnet3 -cfmc call readi(mcmcard,'ILASTT',ilastt,0) -cfmc write(iout,*)'ILASTT=',ilastt -cfmc call readi(mcmcard,'MAXSTR',maxstr,maxstr_mcmf) -cfmc write(iout,*)'MAXSTR=',maxstr -cfmc maxstr_f=maxstr/maxfam -cfmc write(iout,*)'MAXSTR_F=',maxstr_f -cfmc call readi(mcmcard,'NMCMF',nmcmf,10) -cfmc write(iout,*)'NMCMF=',nmcmf -cfmc call readi(mcmcard,'IFOCUS',ifocus,nmcmf) -cfmc write(iout,*)'IFOCUS=',ifocus -cfmc call readi(mcmcard,'NLOCMCMF',nlocmcmf,1000) -cfmc write(iout,*)'NLOCMCMF=',nlocmcmf -cfmc call readi(mcmcard,'INTPRT',intprt,1000) -cfmc write(iout,*)'INTPRT=',intprt -cfmc call readi(mcmcard,'IPRT',iprt,100) -cfmc write(iout,*)'IPRT=',iprt -cfmc call readi(mcmcard,'IMAXTR',imaxtr,100) -cfmc write(iout,*)'IMAXTR=',imaxtr -cfmc call readi(mcmcard,'MAXEVEN',maxeven,1000) -cfmc write(iout,*)'MAXEVEN=',maxeven -cfmc call readi(mcmcard,'MAXEVEN1',maxeven1,3) -cfmc write(iout,*)'MAXEVEN1=',maxeven1 -cfmc call readi(mcmcard,'INIMIN',inimin,200) -cfmc write(iout,*)'INIMIN=',inimin -cfmc call readi(mcmcard,'NSTEPMCMF',nstepmcmf,10) -cfmc write(iout,*)'NSTEPMCMF=',nstepmcmf -cfmc call readi(mcmcard,'NTHREAD',nthread,5) -cfmc write(iout,*)'NTHREAD=',nthread -cfmc call readi(mcmcard,'MAXSTEPMCMF',maxstepmcmf,2500) -cfmc write(iout,*)'MAXSTEPMCMF=',maxstepmcmf -cfmc call readi(mcmcard,'MAXPERT',maxpert,9) -cfmc write(iout,*)'MAXPERT=',maxpert -cfmc call readi(mcmcard,'IRMSD',irmsd,1) -cfmc write(iout,*)'IRMSD=',irmsd -cfmc call reada(mcmcard,'DENEMIN',denemin,0.01D0) -cfmc write(iout,*)'DENEMIN=',denemin -cfmc call reada(mcmcard,'RCUT1S',rcut1s,3.5D0) -cfmc write(iout,*)'RCUT1S=',rcut1s -cfmc call reada(mcmcard,'RCUT1E',rcut1e,2.0D0) -cfmc write(iout,*)'RCUT1E=',rcut1e -cfmc call reada(mcmcard,'RCUT2S',rcut2s,0.5D0) -cfmc write(iout,*)'RCUT2S=',rcut2s -cfmc call reada(mcmcard,'RCUT2E',rcut2e,0.1D0) -cfmc write(iout,*)'RCUT2E=',rcut2e -cfmc call reada(mcmcard,'DPERT1',d_pert1,180.0D0) -cfmc write(iout,*)'DPERT1=',d_pert1 -cfmc call reada(mcmcard,'DPERT1A',d_pert1a,180.0D0) -cfmc write(iout,*)'DPERT1A=',d_pert1a -cfmc call reada(mcmcard,'DPERT2',d_pert2,90.0D0) -cfmc write(iout,*)'DPERT2=',d_pert2 -cfmc call reada(mcmcard,'DPERT2A',d_pert2a,45.0D0) -cfmc write(iout,*)'DPERT2A=',d_pert2a -cfmc call reada(mcmcard,'DPERT2B',d_pert2b,90.0D0) -cfmc write(iout,*)'DPERT2B=',d_pert2b -cfmc call reada(mcmcard,'DPERT2C',d_pert2c,60.0D0) -cfmc write(iout,*)'DPERT2C=',d_pert2c -cfmc d_pert1=deg2rad*d_pert1 -cfmc d_pert1a=deg2rad*d_pert1a -cfmc d_pert2=deg2rad*d_pert2 -cfmc d_pert2a=deg2rad*d_pert2a -cfmc d_pert2b=deg2rad*d_pert2b -cfmc d_pert2c=deg2rad*d_pert2c -cfmc call reada(mcmcard,'KT_MCMF1',kt_mcmf1,1.0D0) -cfmc write(iout,*)'KT_MCMF1=',kt_mcmf1 -cfmc call reada(mcmcard,'KT_MCMF2',kt_mcmf2,1.0D0) -cfmc write(iout,*)'KT_MCMF2=',kt_mcmf2 -cfmc call reada(mcmcard,'DKT_MCMF1',dkt_mcmf1,10.0D0) -cfmc write(iout,*)'DKT_MCMF1=',dkt_mcmf1 -cfmc call reada(mcmcard,'DKT_MCMF2',dkt_mcmf2,1.0D0) -cfmc write(iout,*)'DKT_MCMF2=',dkt_mcmf2 -cfmc call reada(mcmcard,'RCUTINI',rcutini,3.5D0) -cfmc write(iout,*)'RCUTINI=',rcutini -cfmc call reada(mcmcard,'GRAT',grat,0.5D0) -cfmc write(iout,*)'GRAT=',grat -cfmc call reada(mcmcard,'BIAS_MCMF',bias_mcmf,0.0D0) -cfmc write(iout,*)'BIAS_MCMF=',bias_mcmf -cfmc -cfmc return -cfmc end -c---------------------------------------------------------------------------- subroutine mcmread - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.MCM' include 'COMMON.MCE' include 'COMMON.IOUNITS' character*80 ucase character*320 mcmcard + integer i call card_concat(mcmcard) call readi(mcmcard,'MAXACC',maxacc,100) call readi(mcmcard,'MAX_MCM_IT',max_mcm_it,10000) @@ -1913,7 +1824,7 @@ C Probabilities of different move types end c---------------------------------------------------------------------------- subroutine read_minim - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.MINIM' include 'COMMON.IOUNITS' @@ -1939,13 +1850,14 @@ c---------------------------------------------------------------------------- end c---------------------------------------------------------------------------- subroutine read_angles(kanal,*) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.GEO' include 'COMMON.VAR' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' include 'COMMON.CONTROL' + integer i,kanal c Read angles from input c read (kanal,*,err=10,end=10) (theta(i),i=3,nres) @@ -2039,10 +1951,11 @@ c---------------------------------------------------------------------------- end c---------------------------------------------------------------------------- subroutine openunits - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' + integer ierror character*16 form,nodename integer nodelen #endif @@ -2050,7 +1963,7 @@ c---------------------------------------------------------------------------- include 'COMMON.IOUNITS' include 'COMMON.MD' include 'COMMON.CONTROL' - integer lenpre,lenpot,ilen,lentmp + integer lenpre,lenpot,ilen,lentmp,npos external ilen character*3 out1file_text,ucase character*3 ll @@ -2439,13 +2352,21 @@ c---------------------------------------------------------------------------- card=card(:ilen(card)+1)//karta return end -c---------------------------------------------------------------------------------- +c------------------------------------------------------------------------------ subroutine readrst - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' + include 'COMMON.CONTROL' include 'COMMON.MD' + include 'COMMON.QRESTR' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif + integer i,j open(irest2,file=rest2name,status='unknown') read(irest2,*) totT,EK,potE,totE,t_bath totTafm=totT @@ -2461,9 +2382,9 @@ c------------------------------------------------------------------------------- close(irest2) return end -c--------------------------------------------------------------------------------- +c------------------------------------------------------------------------------ subroutine read_fragments - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -2472,7 +2393,9 @@ c------------------------------------------------------------------------------- include 'COMMON.CHAIN' include 'COMMON.IOUNITS' include 'COMMON.MD' + include 'COMMON.QRESTR' include 'COMMON.CONTROL' + integer i read(inp,*) nset,nfrag,npair,nfrag_back loc_qlike=(nfrag_back.lt.0) nfrag_back=iabs(nfrag_back) @@ -2522,7 +2445,7 @@ c------------------------------------------------------------------------------- end C--------------------------------------------------------------------------- subroutine read_afminp - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -2533,7 +2456,8 @@ C--------------------------------------------------------------------------- include 'COMMON.IOUNITS' include 'COMMON.SBRIDGE' character*320 afmcard - print *, "wchodze" + integer i +c print *, "wchodze" call card_concat(afmcard) call readi(afmcard,"BEG",afmbeg,0) call readi(afmcard,"END",afmend,0) @@ -2546,22 +2470,24 @@ CCCC NOW PROPERTIES FOR AFM distafminit=(c(i,afmend)-c(i,afmbeg))**2+distafminit enddo distafminit=dsqrt(distafminit) - print *,'initdist',distafminit +c print *,'initdist',distafminit return end c------------------------------------------------------------------------------- subroutine read_saxs_constr - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' #endif include 'COMMON.SETUP' include 'COMMON.CONTROL' + include 'COMMON.SAXS' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' include 'COMMON.SBRIDGE' - double precision cm(3) + double precision cm(3),cnorm + integer i,j c read(inp,*) nsaxs write (iout,*) "Calling read_saxs nsaxs",nsaxs call flush(iout) @@ -2618,7 +2544,7 @@ c SAXS "spheres". c------------------------------------------------------------------------------- subroutine read_dist_constr - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -2629,8 +2555,10 @@ c------------------------------------------------------------------------------- include 'COMMON.IOUNITS' include 'COMMON.SBRIDGE' include 'COMMON.INTERACT' - integer ifrag_(2,100),ipair_(2,1000) + integer i,j,k,ii,jj,itemp,link_type,iiend,jjend,kk + integer nfrag_,npair_,ndist_,ifrag_(2,100),ipair_(2,1000) double precision wfrag_(100),wpair_(1000) + double precision ddjk,dist,dist_cut,fordepthmax character*5000 controlcard logical normalize,next integer restr_type @@ -3017,16 +2945,18 @@ C dhpb(nhpb)=dist(ihpb(nhpb),jhpb(nhpb)) end c------------------------------------------------------------------------------- subroutine read_constr_homology - + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' #endif include 'COMMON.SETUP' include 'COMMON.CONTROL' + include 'COMMON.HOMOLOGY' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' include 'COMMON.MD' + include 'COMMON.QRESTR' include 'COMMON.GEO' include 'COMMON.INTERACT' include 'COMMON.NAMES' @@ -3043,7 +2973,8 @@ c & sigma_odl_temp(maxres,maxres,max_template) character*2 kic2 character*24 model_ki_dist, model_ki_angle character*500 controlcard - integer ki, i, j, k, l, ii_in_use(maxdim),i_tmp,idomain_tmp + integer ki,i,ii,j,k,l,ii_in_use(maxdim),i_tmp,idomain_tmp,irec, + & ik,iistart,iishift integer ilen external ilen logical liiflag @@ -3055,6 +2986,7 @@ c double precision, dimension (max_template,maxres) :: rescore double precision, dimension (max_template,maxres) :: rescore2 double precision, dimension (max_template,maxres) :: rescore3 + double precision distal character*24 pdbfile,tpl_k_rescore c ----------------------------------------------------------------- c Reading multiple PDB ref structures and calculation of retraints @@ -3455,6 +3387,7 @@ c---------------------------------------------------------------------- #endif c------------------------------------------------------------------------------ subroutine copy_to_tmp(source) + implicit none include "DIMENSIONS" include "COMMON.IOUNITS" character*(*) source @@ -3474,6 +3407,7 @@ c------------------------------------------------------------------------------ end c------------------------------------------------------------------------------ subroutine move_from_tmp(source) + implicit none include "DIMENSIONS" include "COMMON.IOUNITS" character*(*) source @@ -3490,13 +3424,14 @@ c------------------------------------------------------------------------------ C C Initialize random number generator C - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' logical OKRandom, prng_restart real*8 r1 integer iseed_array(4) + integer error_msg,ierr #endif include 'COMMON.IOUNITS' include 'COMMON.TIME1' @@ -3512,6 +3447,8 @@ C include 'COMMON.MD' include 'COMMON.FFIELD' include 'COMMON.SETUP' + integer i,iseed + double precision seed,ran_number iseed=-dint(dabs(seed)) if (iseed.eq.0) then write (iout,'(/80(1h*)/20x,a/80(1h*))') @@ -3573,13 +3510,14 @@ c r1 = prng_next(me) end c---------------------------------------------------------------------- subroutine read_klapaucjusz - + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' #endif include 'COMMON.SETUP' include 'COMMON.CONTROL' + include 'COMMON.HOMOLOGY' include 'COMMON.CHAIN' include 'COMMON.IOUNITS' include 'COMMON.MD' @@ -3588,12 +3526,14 @@ c---------------------------------------------------------------------- include 'COMMON.NAMES' character*256 fragfile integer ninclust(maxclust),inclust(max_template,maxclust), - & nresclust(maxclust),iresclust(maxres,maxclust) + & nresclust(maxclust),iresclust(maxres,maxclust),nclust character*2 kic2 character*24 model_ki_dist, model_ki_angle character*500 controlcard - integer ki, i, j, k, l, ii_in_use(maxdim),i_tmp,idomain_tmp + integer ki, i, j, k, l, ii_in_use(maxdim),i_tmp,idomain_tmp, + & ik,ll,ii,kk,iistart,iishift,lim_xx + double precision distal logical lprn /.true./ integer ilen external ilen @@ -3670,7 +3610,7 @@ c write (iout,*) "c(",j,i,") =",c(j,i) enddo enddo call int_from_cart(.true.,.false.) - call sc_loc_geom(.true.) + call sc_loc_geom(.false.) do i=1,nres thetaref(i)=theta(i) phiref(i)=phi(i) diff --git a/source/unres/src-HCD-5D/rescode.f b/source/unres/src-HCD-5D/rescode.f index bc79489..834d924 100644 --- a/source/unres/src-HCD-5D/rescode.f +++ b/source/unres/src-HCD-5D/rescode.f @@ -1,5 +1,6 @@ integer function rescode(iseq,nam,itype) - implicit real*8 (a-h,o-z) + implicit none + integer iseq,itype,i include 'DIMENSIONS' include 'COMMON.NAMES' include 'COMMON.IOUNITS' diff --git a/source/unres/src-HCD-5D/sc_move.F b/source/unres/src-HCD-5D/sc_move.F index f353589..75b7211 100644 --- a/source/unres/src-HCD-5D/sc_move.F +++ b/source/unres/src-HCD-5D/sc_move.F @@ -45,7 +45,7 @@ c Local variables double precision orig_w(n_ene) double precision wtime - + sideonly=.true. c Set non side-chain weights to zero (minimization is faster) c NOTE: e(2) does not actually depend on the side-chain, only CA orig_w(2)=wscp @@ -152,7 +152,8 @@ c Put the original weights back to calculate the full energy wtor=orig_w(13) wtor_d=orig_w(14) wvdwpp=orig_w(15) - + sideonly=.false. + mask_side=1 crc n_fun=n_fun+1 ct write (iout,*) 'sc_local time= ',MPI_WTIME()-wtime return @@ -230,7 +231,7 @@ crc cur_e=orig_e nres_moved=0 do i=2,nres-1 c Don't do glycine (itype(j)==10) - if (itype(i).ne.10) then + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then sc_dist=dist(nres+i,nres+res_pick) else sc_dist=sc_dist_cutoff @@ -243,10 +244,11 @@ c Don't do glycine (itype(j)==10) endif enddo - call chainbuild + call chainbuild_extconf call egb1(evdw) call esc(escloc) e_sc=wsc*evdw+wscloc*escloc +c write (iout,*) "sc_move: e_sc",e_sc cd call etotal(energy) cd print *,'new ',(energy(k),k=0,n_ene) orig_e=e_sc @@ -271,7 +273,8 @@ crc orig_omeg(i)=omeg(i) crc enddo call minimize_sc1(e_sc,var,iretcode,loc_nfun) - +c write (iout,*) "n_try",n_try +c write (iout,*) "sc_move after minimze_sc1 e_sc",e_sc cv write(*,'(2i3,2f12.5,2i3)') cv & res_pick,nres_moved,orig_e,e_sc-cur_e, cv & iretcode,loc_nfun @@ -334,111 +337,74 @@ c Reset the minimization mask_r to false return end - -c------------------------------------------------------------- - - subroutine sc_minimize(etot,iretcode,nfun) -c Minimizes side-chains only, leaving backbone frozen -crc implicit none - -c Includes - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.FFIELD' - -c Output arguments - double precision etot - integer iretcode,nfun - -c Local variables - integer i - double precision orig_w(n_ene),energy(0:n_ene) - double precision var(maxvar) - - -c Set non side-chain weights to zero (minimization is faster) -c NOTE: e(2) does not actually depend on the side-chain, only CA - orig_w(2)=wscp - orig_w(3)=welec - orig_w(4)=wcorr - orig_w(5)=wcorr5 - orig_w(6)=wcorr6 - orig_w(7)=wel_loc - orig_w(8)=wturn3 - orig_w(9)=wturn4 - orig_w(10)=wturn6 - orig_w(11)=wang - orig_w(13)=wtor - orig_w(14)=wtor_d - - wscp=0.D0 - welec=0.D0 - wcorr=0.D0 - wcorr5=0.D0 - wcorr6=0.D0 - wel_loc=0.D0 - wturn3=0.D0 - wturn4=0.D0 - wturn6=0.D0 - wang=0.D0 - wtor=0.D0 - wtor_d=0.D0 - -c Prepare to freeze backbone - do i=1,nres - mask_phi(i)=0 - mask_theta(i)=0 - mask_side(i)=1 - enddo - -c Minimize the side-chains - mask_r=.true. - call geom_to_var(nvar,var) - call minimize(etot,var,iretcode,nfun) - call var_to_geom(nvar,var) - mask_r=.false. - -c Put the original weights back and calculate the full energy - wscp=orig_w(2) - welec=orig_w(3) - wcorr=orig_w(4) - wcorr5=orig_w(5) - wcorr6=orig_w(6) - wel_loc=orig_w(7) - wturn3=orig_w(8) - wturn4=orig_w(9) - wturn6=orig_w(10) - wang=orig_w(11) - wtor=orig_w(13) - wtor_d=orig_w(14) - - call chainbuild - call etotal(energy) - etot=energy(0) - - return - end - c------------------------------------------------------------- subroutine minimize_sc1(etot,x,iretcode,nfun) +#ifdef LBFGS_SC + use minima + use inform + use output + use iounit + use scales +#endif implicit real*8 (a-h,o-z) include 'DIMENSIONS' - parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) +#ifndef LBFGS_SC +c parameter (liv=60,lv=(77+maxvar*(maxvar+17)/2)) + parameter(max_sc_move=10) + parameter (liv=60,lv=(77+2*max_sc_move*(2*max_sc_move+17)/2)) +#endif include 'COMMON.IOUNITS' include 'COMMON.VAR' include 'COMMON.GEO' include 'COMMON.MINIM' common /srutu/ icall - dimension iv(liv) - double precision minval,x(maxvar),d(maxvar),v(1:lv),xx(maxvar) + double precision x(maxvar),d(maxvar),xx(maxvar) double precision energia(0:n_ene) +#ifdef LBFGS_SC + integer nvar_restr + common /zmienne/ nvar_restr + double precision grdmin + double precision funcgrad_restr1 + external funcgrad_restr1 + external optsave +#else external func,gradient,fdum external func_restr1,grad_restr1 logical not_done,change,reduce + dimension iv(liv) + double precision v(1:lv) common /przechowalnia/ v - +#endif +#ifdef LBFGS_SC + maxiter=7 + coordtype='RIGIDBODY' + grdmin=tolf + jout=iout +c jprint=print_min_stat + jprint=0 + iwrite=0 + if (.not. allocated(scale)) allocate (scale(nvar)) +c +c set scaling parameter for function and derivative values; +c use square root of median eigenvalue of typical Hessian +c + call x2xx(x,xx,nvar_restr) + set_scale = .true. +c nvar = 0 + do i = 1, nvar_restr +c if (use(i)) then +c do j = 1, 3 +c nvar = nvar + 1 + scale(i) = 12.0d0 +c end do +c end if + end do +c write (iout,*) "Calling lbfgs" + call lbfgs (nvar_restr,xx,etot,grdmin,funcgrad_restr1,optsave) + deallocate(scale) +c write (iout,*) "After lbfgs" + call xx2x(x,xx) +#else call deflt(2,iv,liv,lv,v) * 12 means fresh start, dont call deflt iv(1)=12 @@ -451,8 +417,8 @@ c------------------------------------------------------------- * controls output iv(19)=2 * selects output unit -c iv(21)=iout iv(21)=0 +c iv(21)=0 * 1 means to print out result iv(22)=0 * 1 means to print out summary stats @@ -491,14 +457,158 @@ c v(25)=4.0D0 & iv,liv,lv,v,idum,rdum,fdum) call xx2x(x,xx) ELSE - call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) +c call sumsl(nvar,d,x,func,gradient,iv,liv,lv,v,idum,rdum,fdum) ENDIF etot=v(10) iretcode=iv(1) nfun=iv(6) - +#endif return end +#ifdef LBFGS_SC + double precision function funcgrad_restr1(x,g) + implicit real*8 (a-h,o-z) + include 'DIMENSIONS' + include 'COMMON.DERIV' + include 'COMMON.IOUNITS' + include 'COMMON.GEO' + include 'COMMON.FFIELD' + include 'COMMON.INTERACT' + include 'COMMON.TIME1' + include 'COMMON.CHAIN' + include 'COMMON.VAR' + integer nvar_restr + common /zmienne/ nvar_restr + double precision energia(0:n_ene),evdw,escloc + double precision ufparm,e1,e2 + dimension x(maxvar),g(maxvar),gg(maxvar) +#ifdef OSF +c Intercept NaNs in the coordinates, before calling etotal + x_sum=0.D0 + do i=1,nvar_restr + x_sum=x_sum+x(i) + enddo + FOUND_NAN=.false. + if (x_sum.ne.x_sum) then + write(iout,*)" *** func_restr1 : Found NaN in coordinates" + f=1.0D+73 + FOUND_NAN=.true. + return + endif +#else + FOUND_NAN=.false. + do i=1,nvar_restr + if (isnan(x(i))) then + FOUND_NAN=.true. + f=1.0D+73 + funcgrad_restr1=f + write (iout,*) "NaN in coordinates" + return + endif + enddo +#endif + +c write (iout,*) "nvar_restr",nvar_restr +c write (iout,*) "x",(x(i),i=1,nvar_restr) + call var_to_geom_restr(nvar_restr,x) + call zerograd + call chainbuild_extconf +cd write (iout,*) 'ETOTAL called from FUNC' + call egb1(evdw) + call esc(escloc) + f=wsc*evdw+wscloc*escloc +c write (iout,*) "evdw",evdw," escloc",escloc + if (isnan(f)) then + f=1.0d20 + funcgrad_restr1=f + return + endif + funcgrad_restr1=f +c write (iout,*) "f",f +cd call etotal(energia(0)) +cd f=wsc*energia(1)+wscloc*energia(12) +cd print *,f,evdw,escloc,energia(0) +C +C Sum up the components of the Cartesian gradient. +C + do i=1,nct + do j=1,3 + gradx(j,i,icg)=wsc*gvdwx(j,i)+wscloc*gsclocx(j,i) + enddo + enddo + +C +C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. +C + call cart2intgrad(nvar,gg) +C +C Convert the Cartesian gradient into internal-coordinate gradient. +C + + ig=0 + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + g(ig)=gg(ialph(i,1)) +c write (iout,*) "i",i," ig",ig," ialph",ialph(i,1) +c write (iout,*) "g",g(ig)," gg",gg(ialph(i,1)) + ENDIF + endif + enddo + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + IF (mask_side(i).eq.1) THEN + ig=ig+1 + g(ig)=gg(ialph(i,1)+nside) +c write (iout,*) "i",i," ig",ig," ialph",ialph(i,1)+nside +c write (iout,*) "g",g(ig)," gg",gg(ialph(i,1)+nside) + ENDIF + endif + enddo + +C +C Add the components corresponding to local energy terms. +C + + ig=0 + igall=0 + do i=4,nres + igall=igall+1 + if (mask_phi(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do i=3,nres + igall=igall+1 + if (mask_theta(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) + endif + enddo + + do ij=1,2 + do i=2,nres-1 + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then + igall=igall+1 + if (mask_side(i).eq.1) then + ig=ig+1 + g(ig)=g(ig)+gloc(igall,icg) +c write (iout,*) "ij",ij," i",i," ig",ig," igall",igall +c write (iout,*) "gloc",gloc(igall,icg)," g",g(ig) + endif + endif + enddo + enddo + +cd do i=1,ig +cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) +cd enddo + return + end +#else ************************************************************************ subroutine func_restr1(n,x,nf,f,uiparm,urparm,ufparm) implicit real*8 (a-h,o-z) @@ -509,9 +619,7 @@ c v(25)=4.0D0 include 'COMMON.FFIELD' include 'COMMON.INTERACT' include 'COMMON.TIME1' - common /chuju/ jjj double precision energia(0:n_ene),evdw,escloc - integer jjj double precision ufparm,e1,e2 external ufparm integer uiparm(1) @@ -537,11 +645,12 @@ c Intercept NaNs in the coordinates, before calling etotal call var_to_geom_restr(n,x) call zerograd - call chainbuild + call chainbuild_extconf cd write (iout,*) 'ETOTAL called from FUNC' call egb1(evdw) call esc(escloc) f=wsc*evdw+wscloc*escloc +c write (iout,*) "f",f cd call etotal(energia(0)) cd f=wsc*energia(1)+wscloc*energia(12) cd print *,f,evdw,escloc,energia(0) @@ -550,7 +659,7 @@ C Sum up the components of the Cartesian gradient. C do i=1,nct do j=1,3 - gradx(j,i,icg)=wsc*gvdwx(j,i) + gradx(j,i,icg)=wsc*gvdwx(j,i)+wscloc*gsclocx(j,i) enddo enddo @@ -569,7 +678,7 @@ c------------------------------------------------------- external ufparm integer uiparm(1) double precision urparm(1) - dimension x(maxvar),g(maxvar) + dimension x(maxvar),g(maxvar),gg(maxvar) icg=mod(nf,2)+1 if (nf-nfl+1) 20,30,40 @@ -578,76 +687,51 @@ c write (iout,*) 'grad 20' if (nf.eq.0) return goto 40 30 call var_to_geom_restr(n,x) - call chainbuild + call chainbuild_extconf C C Evaluate the derivatives of virtual bond lengths and SC vectors in variables. C - 40 call cartder + 40 call cart2intgrad(nvar,gg) C C Convert the Cartesian gradient into internal-coordinate gradient. C ig=0 - ind=nres-2 + ind=nres-2 do i=2,nres-2 - IF (mask_phi(i+2).eq.1) THEN - gphii=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg) - gphii=gphii+dxdv(k+3,ind)*gradx(k,j,icg) - enddo - enddo + IF (mask_phi(i+2).eq.1) THEN ig=ig+1 - g(ig)=gphii - ELSE - ind=ind+nres-1-i + g(ig)=gg(i-1) ENDIF enddo - ind=0 do i=1,nres-2 IF (mask_theta(i+2).eq.1) THEN ig=ig+1 - gthetai=0.0D0 - do j=i+1,nres-1 - ind=ind+1 - do k=1,3 - gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg) - gthetai=gthetai+dxdv(k,ind)*gradx(k,j,icg) - enddo - enddo - g(ig)=gthetai - ELSE - ind=ind+nres-1-i + g(ig)=gg(nphi+i) ENDIF enddo do i=2,nres-1 - if (itype(i).ne.10) then + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then IF (mask_side(i).eq.1) THEN ig=ig+1 - galphai=0.0D0 - do k=1,3 - galphai=galphai+dxds(k,i)*gradx(k,i,icg) - enddo - g(ig)=galphai + g(ig)=gg(ialph(i,1)) +c write (iout,*) "i",i," ig",ig," ialph",ialph(i,1) +c write (iout,*) "g",g(ig)," gg",gg(ialph(i,1)) ENDIF endif enddo do i=2,nres-1 - if (itype(i).ne.10) then + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then IF (mask_side(i).eq.1) THEN ig=ig+1 - gomegai=0.0D0 - do k=1,3 - gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg) - enddo - g(ig)=gomegai + g(ig)=gg(ialph(i,1)+nside) +c write (iout,*) "i",i," ig",ig," ialph",ialph(i,1)+nside +c write (iout,*) "g",g(ig)," gg",gg(ialph(i,1)+nside) ENDIF endif enddo @@ -676,11 +760,13 @@ C do ij=1,2 do i=2,nres-1 - if (itype(i).ne.10) then + if (itype(i).ne.10 .and. itype(i).ne.ntyp1) then igall=igall+1 if (mask_side(i).eq.1) then ig=ig+1 g(ig)=g(ig)+gloc(igall,icg) +c write (iout,*) "ij",ij," i",i," ig",ig," igall",igall +c write (iout,*) "gloc",gloc(igall,icg)," g",g(ig) endif endif enddo @@ -691,6 +777,7 @@ cd write (iout,'(a2,i5,a3,f25.8)') 'i=',i,' g=',g(i) cd enddo return end +#endif C----------------------------------------------------------------------------- subroutine egb1(evdw) C @@ -716,11 +803,12 @@ c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon lprn=.false. c if (icall.eq.0) lprn=.true. ind=0 - do i=iatsc_s,iatsc_e +c do i=iatsc_s,iatsc_e + do i=nnt,nct itypi=iabs(itype(i)) - if (itypi.eq.ntyp1) cycle + if (itypi.eq.ntyp1 .or. mask_side(i).eq.0) cycle itypi1=iabs(itype(i+1)) xi=c(1,nres+i) yi=c(2,nres+i) @@ -761,8 +849,9 @@ C lipbufthick is thickenes of lipid buffore C C Calculate SC interaction energy. C - do iint=1,nint_gr(i) - do j=istart(i,iint),iend(i,iint) +c do iint=1,nint_gr(i) +c do j=istart(i,iint),iend(i,iint) + do j=i+1,nct IF (mask_side(j).eq.1.or.mask_side(i).eq.1) THEN ind=ind+1 itypj=iabs(itype(j)) @@ -922,7 +1011,7 @@ C Calculate angular part of the gradient. call sc_grad ENDIF enddo ! j - enddo ! iint +c enddo ! iint enddo ! i end C----------------------------------------------------------------------------- diff --git a/source/unres/src-HCD-5D/stochfric.F b/source/unres/src-HCD-5D/stochfric.F index f38dfda..dc0b088 100644 --- a/source/unres/src-HCD-5D/stochfric.F +++ b/source/unres/src-HCD-5D/stochfric.F @@ -1,5 +1,5 @@ subroutine friction_force - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' include 'COMMON.VAR' include 'COMMON.CHAIN' @@ -8,20 +8,93 @@ include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.IOUNITS' +#ifdef FIVEDIAG + integer iposc,ichain,n,innt,inct + double precision v_work(3,maxres2),vvec(maxres2_chain),rs(maxres2) +#else double precision gamvec(MAXRES6) common /syfek/ gamvec double precision vv(3),vvtot(3,maxres),v_work(MAXRES6), & ginvfric(maxres2,maxres2) common /przechowalnia/ ginvfric +#endif + integer i,j,k,ind logical lprn /.false./, checkmode /.false./ - +#ifdef FIVEDIAG +c Here accelerations due to friction forces are computed right after forces. + d_t_work=0.0d0 + do j=1,3 + v_work(j,1)=d_t(j,0) + v_work(j,nnt)=d_t(j,0) + enddo + do i=nnt+1,nct + do j=1,3 + v_work(j,i)=v_work(j,i-1)+d_t(j,i-1) + enddo + enddo + do i=nnt,nct + if (iabs(itype(i)).ne.10 .and. iabs(itype(i)).ne.ntyp1) then + do j=1,3 + v_work(j,i+nres)=v_work(j,i)+d_t(j,i+nres) + enddo + endif + enddo +#ifdef DEBUG + write (iout,*) "v_work" + do i=1,2*nres + write (iout,'(i5,3f10.5)') i,(v_work(j,i),j=1,3) + enddo +#endif + do j=1,3 + ind=0 + do ichain=1,nchain + n=dimen_chain(ichain) + iposc=iposd_chain(ichain) +c write (iout,*) "friction_force j",j," ichain",ichain, +c & " n",n," iposc",iposc,iposc+n-1 + innt=chain_border(1,ichain) + inct=chain_border(2,ichain) + do i=innt,inct + vvec(ind+1)=v_work(j,i) + ind=ind+1 + if (iabs(itype(i)).ne.10) then + vvec(ind+1)=v_work(j,i+nres) + ind=ind+1 + endif + enddo +#ifdef DEBUG + write (iout,*) "vvec ind",ind + write (iout,'(f10.5)') (vvec(i),i=iposc,ind) +#endif +c write (iout,*) "chain",i," ind",ind," n",n + call fivediagmult(n,DMfric(iposc),DU1fric(iposc), + & DU2fric(iposc),vvec,rs) + do i=iposc,iposc+n-1 + fric_work(3*(i-1)+j)=-rs(i) + enddo + enddo + enddo +#ifdef DEBUG + write (iout,*) "Vector fric_work" + write (iout,'(3f10.5)') (fric_work(j),j=1,dimen3) +#endif +#else do i=0,MAXRES2 do j=1,3 friction(j,i)=0.0d0 @@ -150,14 +223,16 @@ c enddo enddo enddo endif +#endif return end c----------------------------------------------------- subroutine stochastic_force(stochforcvec) - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' + double precision time00 #endif include 'COMMON.VAR' include 'COMMON.CHAIN' @@ -166,24 +241,39 @@ c----------------------------------------------------- include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif include 'COMMON.TIME1' #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#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./ + integer i,j,ind,ii,iti + double precision anorm_distr +#ifdef FIVEDIAG + integer ichain,innt,inct,iposc +#endif + do i=0,MAXRES2 do j=1,3 stochforc(j,i)=0.0d0 enddo enddo - x=0.0d0 + x=0.0d0 #ifdef MPI time00=MPI_Wtime() @@ -207,11 +297,80 @@ c Compute the stochastic forces acting on bodies. Store in force. force(j,i+nres)=anorm_distr(x,sig2,lowb2,highb2) enddo enddo +#ifdef DEBUG + write (iout,*) "Stochastic forces on sites" + do i=1,nres + write (iout,'(i5,2(3f10.5,5x))') i,(force(j,i),j=1,3), + & (force(j,i+nres),j=1,3) + enddo +#endif #ifdef MPI time_fsample=time_fsample+MPI_Wtime()-time00 #else time_fsample=time_fsample+tcpu()-time00 #endif +#ifdef FIVEDIAG + ind=0 + do ichain=1,nchain + innt=chain_border(1,ichain) + inct=chain_border(2,ichain) + iposc=iposd_chain(ichain) +c write (iout,*)"stochastic_force ichain=",ichain," innt",innt, +c & " inct",inct," iposc",iposc + do j=1,3 + stochforcvec(ind+j)=0.5d0*force(j,innt) + enddo + if (iabs(itype(innt)).eq.10) then + do j=1,3 + stochforcvec(ind+j)=stochforcvec(ind+j)+force(j,innt+nres) + enddo + ind=ind+3 + else + ind=ind+3 + do j=1,3 + stochforcvec(ind+j)=force(j,innt+nres) + enddo + ind=ind+3 + endif + do i=innt+1,inct-1 + do j=1,3 + stochforcvec(ind+j)=0.5d0*(force(j,i)+force(j,i-1)) + enddo + if (iabs(itype(i)).eq.10) then + do j=1,3 + stochforcvec(ind+j)=stochforcvec(ind+j)+force(j,i+nres) + enddo + ind=ind+3 + else + ind=ind+3 + do j=1,3 + stochforcvec(ind+j)=force(j,i+nres) + enddo + ind=ind+3 + endif + enddo + do j=1,3 + stochforcvec(ind+j)=0.5d0*force(j,inct-1) + enddo + if (iabs(itype(inct)).eq.10) then + do j=1,3 + stochforcvec(ind+j)=stochforcvec(ind+j)+force(j,inct+nres) + enddo + ind=ind+3 + else + ind=ind+3 + do j=1,3 + stochforcvec(ind+j)=force(j,inct+nres) + enddo + ind=ind+3 + endif +c write (iout,*) "chain",ichain," ind",ind + enddo +#ifdef DEBUG + write (iout,*) "stochforcvec" + write (iout,'(3f10.5)') (stochforcvec(j),j=1,ind) +#endif +#else c Compute the stochastic forces acting on virtual-bond vectors. do j=1,3 ff(j)=0.0d0 @@ -240,7 +399,6 @@ c Compute the stochastic forces acting on virtual-bond vectors. enddo endif enddo - do j=1,3 stochforcvec(j)=stochforc(j,0) enddo @@ -259,6 +417,7 @@ c Compute the stochastic forces acting on virtual-bond vectors. ind=ind+3 endif enddo +#endif if (lprn) then write (iout,*) "stochforcvec" do i=1,3*dimen @@ -311,14 +470,15 @@ c Compute the stochastic forces acting on virtual-bond vectors. enddo endif - return end c------------------------------------------------------------------ subroutine setup_fricmat - implicit real*8 (a-h,o-z) + implicit none #ifdef MPI include 'mpif.h' + integer ierr + double precision time00 #endif include 'DIMENSIONS' include 'COMMON.VAR' @@ -328,6 +488,11 @@ c------------------------------------------------------------------ include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.MD' +#ifdef FIVEDIAG + include 'COMMON.LAGRANGE.5diag' +#else + include 'COMMON.LAGRANGE' +#endif include 'COMMON.SETUP' include 'COMMON.TIME1' c integer licznik /0/ @@ -335,28 +500,30 @@ c save licznik #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.IOUNITS' integer IERROR - integer i,j,ind,ind1,m + integer i,j,k,l,ind,ind1,m,ii,iti,it,nzero,innt,inct + integer ichain,nind logical lprn /.false./ - double precision dtdi,gamvec(MAXRES2), - & ginvfric(maxres2,maxres2),Ghalf(mmaxres2),fcopy(maxres2,maxres2) + double precision dtdi,gamvec(MAXRES2) common /syfek/ gamvec +#ifndef FIVEDIAG + double precision ginvfric(maxres2,maxres2),Ghalf(mmaxres2), + & fcopy(maxres2,maxres2) double precision work(8*maxres2) integer iwork(maxres2) common /przechowalnia/ ginvfric,Ghalf,fcopy +#endif + #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 @@ -364,6 +531,7 @@ c Load the friction coefficients corresponding to peptide groups enddo c Load the friction coefficients corresponding to side chains m=nct-nnt + if (lprn) write (iout,*) "m",m ind=0 C gamsc(ntyp1)=1.0d0 do i=nnt,nct @@ -373,23 +541,105 @@ C gamsc(ntyp1)=1.0d0 gamvec(ii)=gamsc(iabs(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 - +#ifdef FIVEDIAG + DMfric=0.0d0 + DU1fric=0.0d0 + DU2fric=0.0d0 + ind=1 + do ichain=1,nchain + innt=chain_border(1,ichain) + inct=chain_border(2,ichain) +c write (iout,*) "ichain",ichain," innt",innt," inct",inct +c DMfric part + DMfric(ind)=gamvec(innt-nnt+1)/4 + if (iabs(itype(innt)).eq.10) then + DMfric(ind)=DMfric(ind)+gamvec(m+innt-nnt+1) + ind=ind+1 + else + DMfric(ind+1)=gamvec(m+innt-nnt+1) + ind=ind+2 + endif +c write (iout,*) "DMfric init ind",ind +c DMfric + do i=innt+1,inct-1 + DMfric(ind)=gamvec(i-nnt+1)/2 + if (iabs(itype(i)).eq.10) then + DMfric(ind)=DMfric(ind)+gamvec(m+i-nnt+1) + ind=ind+1 + else + DMfric(ind+1)=gamvec(m+i-nnt+1) + ind=ind+2 + endif + enddo +c write (iout,*) "DMfric endloop ind",ind + if (inct.gt.innt) then + DMfric(ind)=gamvec(inct-1-nnt+1)/4 + if (iabs(itype(inct)).eq.10) then + DMfric(ind)=DMfric(ind)+gamvec(inct+m-nnt+1) + ind=ind+1 + else + DMfric(ind+1)=gamvec(inct+m-nnt+1) + ind=ind+2 + endif + endif +c write (iout,*) "DMfric end ind",ind + enddo +c DU1fric part + do ichain=1,nchain + ind=iposd_chain(ichain) + innt=chain_border(1,ichain) + inct=chain_border(2,ichain) + do i=innt,inct + if (iabs(itype(i)).ne.10) then + ind=ind+2 + else + DU1fric(ind)=gamvec(i-nnt+1)/4 + ind=ind+1 + endif + enddo + enddo +c DU2fric part + do ichain=1,nchain + ind=iposd_chain(ichain) + innt=chain_border(1,ichain) + inct=chain_border(2,ichain) + do i=innt,inct-1 + if (iabs(itype(i)).ne.10) then + DU2fric(ind)=gamvec(i-nnt+1)/4 + DU2fric(ind+1)=0.0d0 + ind=ind+2 + else + DU2fric(ind)=0.0d0 + ind=ind+1 + endif + enddo + enddo + if (lprn) then + write(iout,*)"The upper part of the five-diagonal friction matrix" + do ichain=1,nchain + write (iout,'(a,i5)') 'Chain',ichain + innt=iposd_chain(ichain) + inct=iposd_chain(ichain)+dimen_chain(ichain)-1 + do i=innt,inct + if (i.lt.inct-1) then + write (iout,'(2i3,3f10.5)') i,i-innt+1,DMfric(i),DU1fric(i), + & DU2fric(i) + else if (i.eq.inct-1) then + write (iout,'(2i3,3f10.5)') i,i-innt+1,DMfric(i),DU1fric(i) + else + write (iout,'(2i3,3f10.5)') i,i-innt+1,DMfric(i) + endif + enddo + enddo + endif + 10 continue +#else c The friction matrix do k=1,dimen do i=1,dimen @@ -531,6 +781,7 @@ c write (iout,*) "My chunk of fricmat" c call MATOUT2(my_ng_count,dimen,maxres2,maxres2,fcopy) endif #endif +#endif return end c------------------------------------------------------------------------------- @@ -540,7 +791,7 @@ 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) + implicit none include 'DIMENSIONS' include 'COMMON.CONTROL' include 'COMMON.VAR' @@ -548,8 +799,12 @@ c #ifndef LANG0 include 'COMMON.LANGEVIN' #else +#ifdef FIVEDIAG + include 'COMMON.LANGEVIN.lang0.5diag' +#else include 'COMMON.LANGEVIN.lang0' #endif +#endif include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.GEO' @@ -558,8 +813,11 @@ c include 'COMMON.IOUNITS' include 'COMMON.NAMES' double precision radius(maxres2),gamvec(maxres2) + double precision twosix parameter (twosix=1.122462048309372981d0) logical lprn /.false./ + integer i,j,iti,ind + double precision probe,area,ratio c c determine new friction coefficients every few SD steps c @@ -578,7 +836,7 @@ c Load peptide group radii c Load side chain radii do i=nnt,nct iti=itype(i) - radius(i+nres)=restok(iti) + if (iti.ne.ntyp1) radius(i+nres)=restok(iti) enddo c do i=1,2*nres c write (iout,*) "i",i," radius",radius(i) diff --git a/source/unres/src-HCD-5D/tau.options b/source/unres/src-HCD-5D/tau.options deleted file mode 100644 index f17ddc3..0000000 --- a/source/unres/src-HCD-5D/tau.options +++ /dev/null @@ -1,41 +0,0 @@ -Usage: tau_compiler.sh - -optVerbose Turn on verbose debugging message - -optDetectMemoryLeaks Track mallocs/frees using TAU's memory wrapper - -optPdtDir="" PDT architecture directory. Typically $(PDTDIR)/$(PDTARCHDIR) - -optPdtF95Opts="" Options for Fortran parser in PDT (f95parse) - -optPdtF95Reset="" Reset options to the Fortran parser to the given list - -optPdtCOpts="" Options for C parser in PDT (cparse). Typically $(TAU_MPI_INCLUDE) $(TAU_INCLUDE) $(TAU_DEFS) - -optPdtCReset="" Reset options to the C parser to the given list - -optPdtCxxOpts="" Options for C++ parser in PDT (cxxparse). Typically $(TAU_MPI_INCLUDE) $(TAU_INCLUDE) $(TAU_DEFS) - -optPdtCxxReset="" Reset options to the C++ parser to the given list - -optPdtF90Parser="" Specify a different Fortran parser. For e.g., f90parse instead of f95parse - -optPdtGnuFortranParser Specify the GNU gfortran PDT parser gfparse instead of f95parse - -optPdtUser="" Optional arguments for parsing source code - -optTauInstr="" Specify location of tau_instrumentor. Typically $(TAUROOT)/$(CONFIG_ARCH)/bin/tau_instrumentor - -optPreProcess Preprocess the source code before parsing. Uses /usr/bin/cpp -P by default. - -optCPP="" Specify an alternative preprocessor and pre-process the sources. - -optCPPOpts="" Specify additional options to the C pre-processor. - -optCPPReset="" Reset C preprocessor options to the specified list. - -optTauSelectFile="" Specify selective instrumentation file for tau_instrumentor - -optPDBFile="" Specify PDB file for tau_instrumentor. Skips parsing stage. - -optTau="" Specify options for tau_instrumentor - -optCompile="" Options passed to the compiler by the user. - -optTauDefs="" Options passed to the compiler by TAU. Typically $(TAU_DEFS) - -optTauIncludes="" Options passed to the compiler by TAU. Typically $(TAU_MPI_INCLUDE) $(TAU_INCLUDE) - -optIncludeMemory="" Flags for replacement of malloc/free. Typically -I$(TAU_DIR)/include/Memory - -optReset="" Reset options to the compiler to the given list - -optLinking="" Options passed to the linker. Typically $(TAU_MPI_FLIBS) $(TAU_LIBS) $(TAU_CXXLIBS) - -optLinkReset="" Reset options to the linker to the given list - -optTauCC="" Specifies the C compiler used by TAU - -optOpariTool="" Specifies the location of the Opari tool - -optOpariDir="" Specifies the location of the Opari directory - -optOpariOpts="" Specifies optional arguments to the Opari tool - -optOpariReset="" Resets options passed to the Opari tool - -optNoMpi Removes -l*mpi* libraries during linking (default) - -optMpi Does not remove -l*mpi* libraries during linking - -optNoRevert Exit on error. Does not revert to the original compilation rule on error. - -optRevert Revert to the original compilation rule on error (default). - -optKeepFiles Does not remove intermediate .pdb and .inst.* files - -optAppCC="" Specifies the fallback C compiler. - -optAppCXX="" Specifies the fallback C++ compiler. - -optAppF90="" Specifies the fallback F90 compiler. diff --git a/source/unres/src-HCD-5D/test.F b/source/unres/src-HCD-5D/test.F index 7277b01..ac867d9 100644 --- a/source/unres/src-HCD-5D/test.F +++ b/source/unres/src-HCD-5D/test.F @@ -1858,978 +1858,3 @@ cd call write_pdb(6,'dist structure',etot) return end c----------------------------------------------------------- - subroutine contact_cp(var,var2,iff,ieval,in_pdb) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.MINIM' - - character*50 linia - integer nf,ij(4) - double precision energy(0:n_ene) - double precision var(maxvar),var2(maxvar) - double precision time0,time1 - integer iff(maxres),ieval - double precision theta1(maxres),phi1(maxres),alph1(maxres), - & omeg1(maxres) - logical debug - - debug=.false. -c debug=.true. - if (ieval.eq.-1) debug=.true. - - -c -c store selected dist. constrains from 1st structure -c -#ifdef OSF -c Intercept NaNs in the coordinates -c write(iout,*) (var(i),i=1,nvar) - x_sum=0.D0 - do i=1,nvar - x_sum=x_sum+var(i) - enddo - if (x_sum.ne.x_sum) then - write(iout,*)" *** contact_cp : Found NaN in coordinates" - call flush(iout) - print *," *** contact_cp : Found NaN in coordinates" - return - endif -#endif - - - call var_to_geom(nvar,var) - call chainbuild - nhpb0=nhpb - ind=0 - do i=1,nres-3 - do j=i+3,nres - ind=ind+1 - if ( iff(i).eq.1.and.iff(j).eq.1 ) then - d0(ind)=DIST(i,j) - w(ind)=10.0 - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=10.0 - dhpb(nhpb)=d0(ind) - else - w(ind)=0.0 - endif - enddo - enddo - call hpb_partition - - do i=1,nres - theta1(i)=theta(i) - phi1(i)=phi(i) - alph1(i)=alph(i) - omeg1(i)=omeg(i) - enddo - -c -c freeze sec.elements from 2nd structure -c - do i=1,nres - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - enddo - - call var_to_geom(nvar,var2) - call secondary2(debug) - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - endif - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - mask(i)=0 - mask_phi(i)=0 - mask_theta(i)=0 - enddo - enddo - mask_r=.true. - -c -c copy selected res from 1st to 2nd structure -c - - do i=1,nres - if ( iff(i).eq.1 ) then - theta(i)=theta1(i) - phi(i)=phi1(i) - alph(i)=alph1(i) - omeg(i)=omeg1(i) - endif - enddo - - if(debug) then -c -c prepare description in linia variable -c - iwsk=0 - nf=0 - if (iff(1).eq.1) then - iwsk=1 - nf=nf+1 - ij(nf)=1 - endif - do i=2,nres - if ( iwsk.eq.0.and.iff(i-1).eq.0.and.iff(i).eq.1 ) then - iwsk=1 - nf=nf+1 - ij(nf)=i - endif - if ( iwsk.eq.1.and.iff(i-1).eq.1.and.iff(i).eq.0 ) then - iwsk=0 - nf=nf+1 - ij(nf)=i-1 - endif - enddo - if (iff(nres).eq.1) then - nf=nf+1 - ij(nf)=nres - endif - - write(linia,'(a6,i3,a1,i3,a1,i3,a1,i3)') - & "SELECT",ij(1)-1,"-",ij(2)-1, - & ",",ij(3)-1,"-",ij(4)-1 - - endif -c -c run optimization -c - call contact_cp_min(var,ieval,in_pdb,linia,debug) - - return - end - - subroutine contact_cp_min(var,ieval,in_pdb,linia,debug) -c -c input : theta,phi,alph,omeg,in_pdb,linia,debug -c output : var,ieval -c - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.VAR' - include 'COMMON.CHAIN' - include 'COMMON.MINIM' - - character*50 linia - integer nf,ij(4) - double precision energy(0:n_ene) - double precision var(maxvar) - double precision time0,time1 - integer ieval,info(3) - logical debug,fail,check_var,reduce,change - - write(iout,'(a20,i6,a20)') - & '------------------',in_pdb,'-------------------' - - if (debug) then - call chainbuild - call write_pdb(1000+in_pdb,'combined structure',0d0) -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - endif - -c -c run optimization of distances -c -c uses d0(),w() and mask() for frozen 2D -c -ctest--------------------------------------------- -ctest NX=NRES-3 -ctest NY=((NRES-4)*(NRES-5))/2 -ctest call distfit(debug,5000) - - do i=1,nres - mask_side(i)=0 - enddo - - ipot01=ipot - maxmin01=maxmin - maxfun01=maxfun -c wstrain01=wstrain - wsc01=wsc - wscp01=wscp - welec01=welec - wvdwpp01=wvdwpp -c wang01=wang - wscloc01=wscloc - wtor01=wtor - wtor_d01=wtor_d - - ipot=6 - maxmin=2000 - maxfun=4000 -c wstrain=1.0 - wsc=0.0 - wscp=0.0 - welec=0.0 - wvdwpp=0.0 -c wang=0.0 - wscloc=0.0 - wtor=0.0 - wtor_d=0.0 - - call geom_to_var(nvar,var) -cde change=reduce(var) - if (check_var(var,info)) then - write(iout,*) 'cp_min error in input' - print *,'cp_min error in input' - return - endif - -cd call etotal(energy(0)) -cd call enerprint(energy(0)) -cd call check_eint - -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif -cdtest call minimize(etot,var,iretcode,nfun) -cdtest write(iout,*)'SUMSL return code is',iretcode,' eval SDIST',nfun -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - -cd call etotal(energy(0)) -cd call enerprint(energy(0)) -cd call check_eint - - do i=1,nres - mask_side(i)=1 - enddo - - ipot=ipot01 - maxmin=maxmin01 - maxfun=maxfun01 -c wstrain=wstrain01 - wsc=wsc01 - wscp=wscp01 - welec=welec01 - wvdwpp=wvdwpp01 -c wang=wang01 - wscloc=wscloc01 - wtor=wtor01 - wtor_d=wtor_d01 -ctest-------------------------------------------------- - - if(debug) then -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,a)')' Time for distfit ',time1-time0,' sec' - call write_pdb(2000+in_pdb,'distfit structure',0d0) - endif - - - ipot0=ipot - maxmin0=maxmin - maxfun0=maxfun - wstrain0=wstrain -c -c run soft pot. optimization -c with constrains: -c nhpb,ihpb(),jhpb(),forcon(),dhpb() and hpb_partition -c and frozen 2D: -c mask_phi(),mask_theta(),mask_side(),mask_r -c - ipot=6 - maxmin=2000 - maxfun=4000 - -cde change=reduce(var) -cde if (check_var(var,info)) write(iout,*) 'error before soft' -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - - write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, - & nfun/(time1-time0),' SOFT eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(3000+in_pdb,'soft structure',etot) - endif -c -c run full UNRES optimization with constrains and frozen 2D -c the same variables as soft pot. optimizatio -c - ipot=ipot0 - maxmin=maxmin0 - maxfun=maxfun0 -c -c check overlaps before calling full UNRES minim -c - call var_to_geom(nvar,var) - call chainbuild - call etotal(energy(0)) -#ifdef OSF - write(iout,*) 'N7 ',energy(0) - if (energy(0).ne.energy(0)) then - write(iout,*) 'N7 error - gives NaN',energy(0) - endif -#endif - ieval=1 - if (energy(1).eq.1.0d20) then - write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw=1d20',energy(1) - call overlap_sc(fail) - if(.not.fail) then - call etotal(energy(0)) - ieval=ieval+1 - write (iout,'(a,1pe14.5)')'#N7_OVERLAP evdw after',energy(1) - else - mask_r=.false. - nhpb= nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - return - endif - endif - call flush(iout) -c -cdte time0=MPI_WTIME() -cde change=reduce(var) -cde if (check_var(var,info)) then -cde write(iout,*) 'error before mask dist' -cde call var_to_geom(nvar,var) -cde call chainbuild -cde call write_pdb(10000+in_pdb,'before mask dist',etot) -cde endif -cdte call minimize(etot,var,iretcode,nfun) -cdte write(iout,*)'SUMSL MASK DIST return code is',iretcode, -cdte & ' eval ',nfun -cdte ieval=ieval+nfun -cdte -cdte time1=MPI_WTIME() -cdte write (iout,'(a,f6.2,f8.2,a)') -cdte & ' Time for mask dist min.',time1-time0, -cdte & nfun/(time1-time0),' eval/s' -cdte call flush(iout) - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(4000+in_pdb,'mask dist',etot) - endif -c -c switch off freezing of 2D and -c run full UNRES optimization with constrains -c - mask_r=.false. -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif -cde change=reduce(var) -cde if (check_var(var,info)) then -cde write(iout,*) 'error before dist' -cde call var_to_geom(nvar,var) -cde call chainbuild -cde call write_pdb(11000+in_pdb,'before dist',etot) -cde endif - - call minimize(etot,var,iretcode,nfun) - -cde change=reduce(var) -cde if (check_var(var,info)) then -cde write(iout,*) 'error after dist',ico -cde call var_to_geom(nvar,var) -cde call chainbuild -cde call write_pdb(12000+in_pdb+ico*1000,'after dist',etot) -cde endif - write(iout,*)'SUMSL DIST return code is',iretcode,' eval ',nfun - ieval=ieval+nfun - -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for dist min.',time1-time0, - & nfun/(time1-time0),' eval/s' -cde call etotal(energy(0)) -cde write(iout,*) 'N7 after dist',energy(0) - call flush(iout) - - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(in_pdb,linia,etot) - endif -c -c reset constrains -c - nhpb= nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - - return - end -c-------------------------------------------------------- - subroutine softreg - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.GEO' - include 'COMMON.CHAIN' - include 'COMMON.IOUNITS' - include 'COMMON.VAR' - include 'COMMON.CONTROL' - include 'COMMON.SBRIDGE' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' - include 'COMMON.INTERACT' -c - include 'COMMON.DISTFIT' - integer iff(maxres) - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision var(maxvar) - integer ieval -c - logical debug,ltest,fail - character*50 linia -c - linia='test' - debug=.true. - in_pdb=0 - - - -c------------------------ -c -c freeze sec.elements -c - do i=1,nres - mask_phi(i)=1 - mask_theta(i)=1 - mask_side(i)=1 - iff(i)=0 - enddo - - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - if (bfrag(3,j).le.bfrag(4,j)) then - do i=bfrag(3,j),bfrag(4,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - else - do i=bfrag(4,j),bfrag(3,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - endif - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - mask_phi(i)=0 - mask_theta(i)=0 - iff(i)=1 - enddo - enddo - mask_r=.true. - - - - nhpb0=nhpb -c -c store dist. constrains -c - do i=1,nres-3 - do j=i+3,nres - if ( iff(i).eq.1.and.iff(j).eq.1 ) then - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=0.1 - dhpb(nhpb)=DIST(i,j) - endif - enddo - enddo - call hpb_partition - - if (debug) then - call chainbuild - call write_pdb(100+in_pdb,'input reg. structure',0d0) - endif - - - ipot0=ipot - maxmin0=maxmin - maxfun0=maxfun - wstrain0=wstrain - wang0=wang -c -c run soft pot. optimization -c - ipot=6 - wang=3.0 - maxmin=2000 - maxfun=4000 - call geom_to_var(nvar,var) -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - - write(iout,*)'SUMSL return code is',iretcode,' eval SOFT',nfun -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for soft min.',time1-time0, - & nfun/(time1-time0),' SOFT eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(300+in_pdb,'soft structure',etot) - endif -c -c run full UNRES optimization with constrains and frozen 2D -c the same variables as soft pot. optimizatio -c - ipot=ipot0 - wang=wang0 - maxmin=maxmin0 - maxfun=maxfun0 -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL MASK DIST return code is',iretcode, - & ' eval ',nfun - ieval=nfun - -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)') - & ' Time for mask dist min.',time1-time0, - & nfun/(time1-time0),' eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(400+in_pdb,'mask & dist',etot) - endif -c -c switch off constrains and -c run full UNRES optimization with frozen 2D -c - -c -c reset constrains -c - nhpb_c=nhpb - nhpb=nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - - -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - write(iout,*)'SUMSL MASK return code is',iretcode,' eval ',nfun - ieval=ieval+nfun - -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for mask min.',time1-time0, - & nfun/(time1-time0),' eval/s' - - - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(500+in_pdb,'mask 2d frozen',etot) - endif - - mask_r=.false. - - -c -c run full UNRES optimization with constrains and NO frozen 2D -c - - nhpb=nhpb_c - link_start=1 - link_end=nhpb - maxfun=maxfun0/5 - - do ico=1,5 - - wstrain=wstrain0/ico - -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - write(iout,'(a10,f6.3,a14,i3,a6,i5)') - & ' SUMSL DIST',wstrain,' return code is',iretcode, - & ' eval ',nfun - ieval=nfun - -#ifdef MPI - time1=MPI_WTIME() -#else - time0=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)') - & ' Time for dist min.',time1-time0, - & nfun/(time1-time0),' eval/s' - if (debug) then - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(600+in_pdb+ico,'dist cons',etot) - endif - - enddo -c - nhpb=nhpb0 - link_start=1 - link_end=nhpb - wstrain=wstrain0 - maxfun=maxfun0 - - -c - if (minim) then -#ifdef MPI - time0=MPI_WTIME() -#else - time0=tcpu() -#endif - call minimize(etot,var,iretcode,nfun) - write(iout,*)'------------------------------------------------' - write(iout,*)'SUMSL return code is',iretcode,' eval ',nfun, - & '+ DIST eval',ieval - -#ifdef MPI - time1=MPI_WTIME() -#else - time1=tcpu() -#endif - write (iout,'(a,f6.2,f8.2,a)')' Time for full min.',time1-time0, - & nfun/(time1-time0),' eval/s' - - - call var_to_geom(nvar,var) - call chainbuild - call write_pdb(999,'full min',etot) - endif - - return - end - - - subroutine beta_slide(i1,i2,i3,i4,i5,ieval,ij) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' - include 'COMMON.CHAIN' - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision var(maxvar) - integer jdata(5),isec(maxres) -c - jdata(1)=i1 - jdata(2)=i2 - jdata(3)=i3 - jdata(4)=i4 - jdata(5)=i5 - - call secondary2(.false.) - - do i=1,nres - isec(i)=0 - enddo - do j=1,nbfrag - do i=bfrag(1,j),bfrag(2,j) - isec(i)=1 - enddo - do i=bfrag(4,j),bfrag(3,j),sign(1,bfrag(3,j)-bfrag(4,j)) - isec(i)=1 - enddo - enddo - do j=1,nhfrag - do i=hfrag(1,j),hfrag(2,j) - isec(i)=2 - enddo - enddo - -c -c cut strands at the ends -c - if (jdata(2)-jdata(1).gt.3) then - jdata(1)=jdata(1)+1 - jdata(2)=jdata(2)-1 - if (jdata(3).lt.jdata(4)) then - jdata(3)=jdata(3)+1 - jdata(4)=jdata(4)-1 - else - jdata(3)=jdata(3)-1 - jdata(4)=jdata(4)+1 - endif - endif - -cv call chainbuild -cv call etotal(energy(0)) -cv etot=energy(0) -cv write(iout,*) nnt,nct,etot -cv call write_pdb(ij*100,'first structure',etot) -cv write(iout,*) 'N16 test',(jdata(i),i=1,5) - -c------------------------ -c generate constrains -c - ishift=jdata(5)-2 - if(ishift.eq.0) ishift=-2 - nhpb0=nhpb - call chainbuild - do i=jdata(1),jdata(2) - isec(i)=-1 - if(jdata(4).gt.jdata(3))then - do j=jdata(3)+i-jdata(1)-2,jdata(3)+i-jdata(1)+2 - isec(j)=-1 -cd print *,i,j,j+ishift - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=1000.0 - dhpb(nhpb)=DIST(i,j+ishift) - enddo - else - do j=jdata(3)-i+jdata(1)+2,jdata(3)-i+jdata(1)-2,-1 - isec(j)=-1 -cd print *,i,j,j+ishift - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=1000.0 - dhpb(nhpb)=DIST(i,j+ishift) - enddo - endif - enddo - - do i=nnt,nct-2 - do j=i+2,nct - if(isec(i).gt.0.or.isec(j).gt.0) then -cd print *,i,j - nhpb=nhpb+1 - ihpb(nhpb)=i - jhpb(nhpb)=j - forcon(nhpb)=0.1 - dhpb(nhpb)=DIST(i,j) - endif - enddo - enddo - - call hpb_partition - - call geom_to_var(nvar,var) - maxfun0=maxfun - wstrain0=wstrain - maxfun=4000/5 - - do ico=1,5 - - wstrain=wstrain0/ico - -cv time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,'(a10,f6.3,a14,i3,a6,i5)') - & ' SUMSL DIST',wstrain,' return code is',iretcode, - & ' eval ',nfun - ieval=ieval+nfun -cv time1=MPI_WTIME() -cv write (iout,'(a,f6.2,f8.2,a)') -cv & ' Time for dist min.',time1-time0, -cv & nfun/(time1-time0),' eval/s' -cv call var_to_geom(nvar,var) -cv call chainbuild -cv call write_pdb(ij*100+ico,'dist cons',etot) - - enddo -c - nhpb=nhpb0 - call hpb_partition - wstrain=wstrain0 - maxfun=maxfun0 -c -cd print *,etot - wscloc0=wscloc - wscloc=10.0 - call sc_move(nnt,nct,100,100d0,nft_sc,etot) - wscloc=wscloc0 -cv call chainbuild -cv call etotal(energy(0)) -cv etot=energy(0) -cv call write_pdb(ij*100+10,'sc_move',etot) -cd call intout -cd print *,nft_sc,etot - - return - end - - subroutine beta_zip(i1,i2,ieval,ij) - implicit real*8 (a-h,o-z) - include 'DIMENSIONS' -#ifdef MPI - include 'mpif.h' -#endif - include 'COMMON.GEO' - include 'COMMON.VAR' - include 'COMMON.INTERACT' - include 'COMMON.IOUNITS' - include 'COMMON.DISTFIT' - include 'COMMON.SBRIDGE' - include 'COMMON.CONTROL' - include 'COMMON.FFIELD' - include 'COMMON.MINIM' - include 'COMMON.CHAIN' - double precision time0,time1 - double precision energy(0:n_ene),ee - double precision var(maxvar) - character*10 test - -cv call chainbuild -cv call etotal(energy(0)) -cv etot=energy(0) -cv write(test,'(2i5)') i1,i2 -cv call write_pdb(ij*100,test,etot) -cv write(iout,*) 'N17 test',i1,i2,etot,ij - -c -c generate constrains -c - nhpb0=nhpb - nhpb=nhpb+1 - ihpb(nhpb)=i1 - jhpb(nhpb)=i2 - forcon(nhpb)=1000.0 - dhpb(nhpb)=4.0 - - call hpb_partition - - call geom_to_var(nvar,var) - maxfun0=maxfun - wstrain0=wstrain - maxfun=1000/5 - - do ico=1,5 - wstrain=wstrain0/ico -cv time0=MPI_WTIME() - call minimize(etot,var,iretcode,nfun) - write(iout,'(a10,f6.3,a14,i3,a6,i5)') - & ' SUMSL DIST',wstrain,' return code is',iretcode, - & ' eval ',nfun - ieval=ieval+nfun -cv time1=MPI_WTIME() -cv write (iout,'(a,f6.2,f8.2,a)') -cv & ' Time for dist min.',time1-time0, -cv & nfun/(time1-time0),' eval/s' -c do not comment the next line - call var_to_geom(nvar,var) -cv call chainbuild -cv call write_pdb(ij*100+ico,'dist cons',etot) - enddo - - nhpb=nhpb0 - call hpb_partition - wstrain=wstrain0 - maxfun=maxfun0 - -cv call etotal(energy(0)) -cv etot=energy(0) -cv write(iout,*) 'N17 test end',i1,i2,etot,ij - - - return - end diff --git a/source/unres/src-HCD-5D/timing.F b/source/unres/src-HCD-5D/timing.F index 0581ead..7bd51b8 100644 --- a/source/unres/src-HCD-5D/timing.F +++ b/source/unres/src-HCD-5D/timing.F @@ -66,7 +66,7 @@ C... node's task was accomplished (parallel only); C... -1 - STOP signal was received from another node because of error; C... -2 - STOP signal was received from another node, because C... the node's time was up. - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' integer nf logical ovrtim @@ -139,10 +139,11 @@ c Check for FOUND_NAN flag end C-------------------------------------------------------------------------- logical function ovrtim() + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.TIME1' - real*8 tcpu + real*8 tcpu,curtim #ifdef MPI include "mpif.h" curtim = MPI_Wtime()-walltime @@ -164,7 +165,9 @@ c write (iout,*) "curtim",curtim," timlim",timlim," safety",safety end ************************************************************************** double precision function tcpu() + implicit none include 'COMMON.TIME1' + double precision seconds #ifdef ES9000 **************************** C Next definition for EAGLE (ibm-es9000) @@ -253,12 +256,14 @@ c next definitions for windows NT Digital fortran end C--------------------------------------------------------------------------- subroutine dajczas(rntime,hrtime,mintime,sectime) + implicit none include 'COMMON.IOUNITS' real*8 rntime,hrtime,mintime,sectime + integer ihr,imn,isc hrtime=rntime/3600.0D0 - hrtime=aint(hrtime) - mintime=aint((rntime-3600.0D0*hrtime)/60.0D0) - sectime=aint((rntime-3600.0D0*hrtime-60.0D0*mintime)+0.5D0) + hrtime=dint(hrtime) + mintime=dint((rntime-3600.0D0*hrtime)/60.0D0) + sectime=dint((rntime-3600.0D0*hrtime-60.0D0*mintime)+0.5D0) if (sectime.eq.60.0D0) then sectime=0.0D0 mintime=mintime+1.0D0 @@ -273,10 +278,11 @@ C--------------------------------------------------------------------------- end C--------------------------------------------------------------------------- subroutine print_detailed_timing - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' + double precision time1 #endif include 'COMMON.IOUNITS' include 'COMMON.TIME1' @@ -310,7 +316,7 @@ C--------------------------------------------------------------------------- & " BCASTW",time_bcastw," ALLREDUCE",time_allreduce, & " TOTAL", & time_bcast+time_reduce+time_gather+time_scatter+ - & time_sendrecv+time_barrier+time_bcastc + & time_sendrecv+time_barrier_g+time_barrier_e+time_bcastc write (*,*) "Processor",fg_rank,myrank," enecalc",time_enecalc write (*,*) "Processor",fg_rank,myrank," sumene",time_sumene write (*,*) "Processor",fg_rank,myrank," intfromcart", diff --git a/source/unres/src-HCD-5D/unres.F b/source/unres/src-HCD-5D/unres.F index 5da3f8e..f556eb6 100644 --- a/source/unres/src-HCD-5D/unres.F +++ b/source/unres/src-HCD-5D/unres.F @@ -6,7 +6,7 @@ C Program to carry out conformational search of proteins in an united-residue C C approximation. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' @@ -20,7 +20,7 @@ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC include 'COMMON.GEO' include 'COMMON.HEADER' include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.CHAIN' include 'COMMON.VAR' include 'COMMON.IOUNITS' @@ -46,7 +46,9 @@ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC & 'Mesoscopic molecular dynamics (MD) ', & 'Not used 13', & 'Replica exchange molecular dynamics (REMD)'/ + integer ilen external ilen + integer ierr c call memmon_print_usage() @@ -71,8 +73,8 @@ c write (iout,*) "After readrtns" call flush(iout) C if (modecalc.eq.-2) then - call test - stop +c call test +c stop else if (modecalc.eq.-1) then write(iout,*) "call check_sc_map next" call check_bond @@ -134,6 +136,7 @@ c call memmon_print_usage() end c-------------------------------------------------------------------------- subroutine exec_MD + implicit none include 'DIMENSIONS' #ifdef MPI include "mpif.h" @@ -156,6 +159,7 @@ c endif c--------------------------------------------------------------------------- #ifdef MPI subroutine exec_MREMD + implicit none include 'DIMENSIONS' #ifdef MPI include "mpif.h" @@ -164,6 +168,7 @@ c--------------------------------------------------------------------------- include 'COMMON.CONTROL' include 'COMMON.IOUNITS' include 'COMMON.REMD' + integer i if (me.eq.king .or. .not. out1file) & write (iout,*) "Calling chainbuild" call chainbuild @@ -182,7 +187,7 @@ c--------------------------------------------------------------------------- #endif c--------------------------------------------------------------------------- subroutine exec_eeval_or_minim - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -194,7 +199,7 @@ c--------------------------------------------------------------------------- include 'COMMON.GEO' include 'COMMON.HEADER' include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.CHAIN' include 'COMMON.VAR' include 'COMMON.IOUNITS' @@ -202,10 +207,22 @@ c--------------------------------------------------------------------------- include 'COMMON.REMD' include 'COMMON.MD' include 'COMMON.SBRIDGE' + integer i,icall,iretcode,nfun common /srutu/ icall - double precision energy(0:n_ene) + integer nharp,iharp(4,maxres/3) + integer nft_sc + logical fail + double precision energy(0:n_ene),etot,etota double precision energy_long(0:n_ene),energy_short(0:n_ene) + double precision rms,frac,frac_nn,co double precision varia(maxvar) + double precision time00,time1,time_ene,evals +#ifdef LBFGS + character*9 status + integer niter + common /lbfgstat/ status,niter,nfun +#endif + integer ilen if (indpdb.eq.0) call chainbuild if (indpdb.ne.0) then dc(1,0)=c(1,1) @@ -247,20 +264,28 @@ c call flush(iout) time_ene=tcpu()-time00 #endif write (iout,*) "Time for energy evaluation",time_ene - print *,"after etotal" +c print *,"after etotal" etota = energy(0) etot =etota call enerprint(energy(0)) call hairpin(.true.,nharp,iharp) - print *,'after hairpin' +c print *,'after hairpin' call secondary2(.true.) - print *,'after secondary' +c print *,'after secondary' if (minim) then crc overlap test + if (indpdb.ne.0 .and. .not.dccart) then + call bond_regular + call chainbuild_extconf + call etotal(energy(0)) + write (iout,*) "After bond regularization" + call enerprint(energy(0)) + endif + if (overlapsc) then - print *, 'Calling OVERLAP_SC' +c print *, 'Calling OVERLAP_SC' call overlap_sc(fail) - print *,"After overlap_sc" +c print *,"After overlap_sc" endif if (searchsc) then @@ -278,12 +303,8 @@ crc overlap test #endif call minim_dc(etot,iretcode,nfun) else - if (indpdb.ne.0) then - call bond_regular - call chainbuild_extconf - endif call geom_to_var(nvar,varia) - print *,'Calling MINIMIZE.' +c print *,'Calling MINIMIZE.' #ifdef MPI time1=MPI_WTIME() #else @@ -291,7 +312,11 @@ crc overlap test #endif call minimize(etot,varia,iretcode,nfun) endif +#ifdef LBFGS + print *,'LBFGS return code is',status,' eval ',nfun +#else print *,'SUMSL return code is',iretcode,' eval ',nfun +#endif #ifdef MPI evals=nfun/(MPI_WTIME()-time1) #else @@ -308,11 +333,22 @@ crc overlap test call enerprint(energy(0)) call intout - call briefout(0,etot) + if (out_int) call briefout(0,etot) + if (out_cart) then + cartname=prefix(:ilen(prefix))//'.x' + potE=etot + call cartoutx(0.0d0) + endif if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) +#ifdef LBFGS + write (iout,'(a,a9)') 'LBFGS return code:',status + write (iout,'(a,i20)') '# of energy evaluations:',nfun+1 + write (iout,'(a,f16.3)')'# of energy evaluations/sec:',evals +#else write (iout,'(a,i3)') 'SUMSL return code:',iretcode write (iout,'(a,i20)') '# of energy evaluations:',nfun+1 write (iout,'(a,f16.3)')'# of energy evaluations/sec:',evals +#endif else print *,'refstr=',refstr if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) @@ -324,7 +360,7 @@ crc overlap test end c--------------------------------------------------------------------------- subroutine exec_regularize - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -336,7 +372,7 @@ c--------------------------------------------------------------------------- include 'COMMON.GEO' include 'COMMON.HEADER' include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.CHAIN' include 'COMMON.VAR' include 'COMMON.IOUNITS' @@ -345,6 +381,13 @@ c--------------------------------------------------------------------------- include 'COMMON.MD' include 'COMMON.SBRIDGE' double precision energy(0:n_ene) + double precision etot,rms,frac,frac_nn,co + integer iretcode +#ifdef LBFGS + character*9 status + integer niter,nfun + common /lbfgstat/ status,niter,nfun +#endif call gen_dist_constr call sc_conf @@ -359,11 +402,16 @@ c--------------------------------------------------------------------------- if (outpdb) call pdbout(etot,titel(:50),ipdb) if (outmol2) call mol2out(etot,titel(:32)) if (refstr) call rms_nac_nnc(rms,frac,frac_nn,co,.true.) +#ifdef LBFGS + write (iout,'(a,a9)') 'LBFGS return code:',status +#else write (iout,'(a,i3)') 'SUMSL return code:',iretcode +#endif return end c--------------------------------------------------------------------------- subroutine exec_thread + implicit none include 'DIMENSIONS' #ifdef MP include "mpif.h" @@ -374,9 +422,10 @@ c--------------------------------------------------------------------------- end c--------------------------------------------------------------------------- subroutine exec_MC - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' character*10 nodeinfo + integer ipar double precision varia(maxvar) #ifdef MPI include "mpif.h" @@ -405,11 +454,12 @@ c--------------------------------------------------------------------------- end c--------------------------------------------------------------------------- subroutine exec_mult_eeval_or_minim - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' - dimension muster(mpi_status_size) + integer muster(mpi_status_size) + integer ierr,ierror #endif include 'COMMON.SETUP' include 'COMMON.TIME1' @@ -418,7 +468,7 @@ c--------------------------------------------------------------------------- include 'COMMON.GEO' include 'COMMON.HEADER' include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.CHAIN' include 'COMMON.VAR' include 'COMMON.IOUNITS' @@ -427,8 +477,11 @@ c--------------------------------------------------------------------------- include 'COMMON.MD' include 'COMMON.SBRIDGE' double precision varia(maxvar) - dimension ind(6) - double precision energy(0:max_ene) + integer i,j,iconf,ind(6) + integer n,it,man,nf_mcmf,nmin,imm,mm,nft + double precision energy(0:max_ene),ene,etot,ene0 + double precision rms,frac,frac_nn,co + double precision time logical eof eof=.false. #ifdef MPI @@ -702,7 +755,7 @@ cjlee end end c--------------------------------------------------------------------------- subroutine exec_checkgrad - implicit real*8 (a-h,o-z) + implicit none include 'DIMENSIONS' #ifdef MPI include 'mpif.h' @@ -714,14 +767,16 @@ c--------------------------------------------------------------------------- include 'COMMON.GEO' include 'COMMON.HEADER' include 'COMMON.CONTROL' - include 'COMMON.CONTACTS' +c include 'COMMON.CONTACTS' include 'COMMON.CHAIN' include 'COMMON.VAR' include 'COMMON.IOUNITS' include 'COMMON.FFIELD' include 'COMMON.REMD' include 'COMMON.MD' + include 'COMMON.QRESTR' include 'COMMON.SBRIDGE' + integer icall common /srutu/ icall double precision energy(0:max_ene) c print *,"A TU?" @@ -798,7 +853,8 @@ c enddo goto (10,20,30) icheckgrad 10 call check_ecartint return - 20 call check_cartgrad + 20 write (iout,*) + & "Checking the gradient of Cartesian coordinates disabled." return 30 call check_eint return @@ -812,6 +868,7 @@ C Energy maps end c--------------------------------------------------------------------------- subroutine exec_CSA + implicit none #ifdef MPI include "mpif.h" #endif @@ -828,16 +885,18 @@ C This method works only with parallel machines! end c--------------------------------------------------------------------------- subroutine exec_softreg + implicit none include 'DIMENSIONS' include 'COMMON.IOUNITS' include 'COMMON.CONTROL' - double precision energy(0:max_ene) + double precision energy(0:max_ene),etot + double precision rms,frac,frac_nn,co call chainbuild call etotal(energy(0)) call enerprint(energy(0)) if (.not.lsecondary) then write(iout,*) 'Calling secondary structure recognition' - call secondary2(debug) + call secondary2(.true.) else write(iout,*) 'Using secondary structure supplied in pdb' endif diff --git a/source/wham/src-HCD-5D/Makefile_MPICH_ifort-okeanos b/source/wham/src-HCD-5D/Makefile_MPICH_ifort-okeanos index 28f86e7..034a517 100644 --- a/source/wham/src-HCD-5D/Makefile_MPICH_ifort-okeanos +++ b/source/wham/src-HCD-5D/Makefile_MPICH_ifort-okeanos @@ -1,9 +1,9 @@ BIN = ~/bin FC = ftn -OPT = -mcmodel=medium -shared-intel -O3 -dynamic +#OPT = -mcmodel=medium -shared-intel -O3 -dynamic #OPT = -O3 -intel-static -mcmodel=medium #OPT = -O3 -ip -w -#OPT = -g -CB -mcmodel=medium -shared-intel -dynamic +OPT = -g -CB -mcmodel=medium -shared-intel -dynamic FFLAGS = ${OPT} -c -I. -I./include_unres -I$(INSTALL_DIR)/include LIBS = -L$(INSTALL_DIR)/lib -lmpich xdrf/libxdrf.a @@ -127,7 +127,7 @@ NEWCORR: ${objects} ${objects_compar} xdrf/libxdrf.a ./compinfo ${FC} -c ${FFLAGS} cinfo.f $(FC) ${OPT} ${objects} ${objects_compar} cinfo.o \ - ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_NEWCORR-SAXS-homology.exe + ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_NEWCORR-SAXS-homology-D.exe NEWCORR_DFA: CPPFLAGS = -DMPI -DLINUX -DUNRES -DSPLITELE -DPROCOR -DNEWCORR -DCORRCD -DDFA -DPGI -DISNAN -DAMD64 -DWHAM -DDFA NEWCORR_DFA: ${objects} ${objects_compar} dfa.o xdrf/libxdrf.a @@ -135,7 +135,7 @@ NEWCORR_DFA: ${objects} ${objects_compar} dfa.o xdrf/libxdrf.a ./compinfo ${FC} -c ${FFLAGS} cinfo.f $(FC) ${OPT} ${objects} ${objects_compar} dfa.o cinfo.o \ - ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_NEWCORR-SAXS-homology-DFA.exe + ${LIBS} -o ${BIN}/wham_ifort_KCC_MPICH-okeanos_NEWCORR-SAXS-homology-DFA-D.exe xdrf/libxdrf.a: cd xdrf && make diff --git a/source/wham/src-HCD-5D/cxread.F b/source/wham/src-HCD-5D/cxread.F index e3e5fcb..cd29176 100644 --- a/source/wham/src-HCD-5D/cxread.F +++ b/source/wham/src-HCD-5D/cxread.F @@ -300,6 +300,7 @@ c & bprotfile_temp(:ilen(bprotfile_temp)) write (iout,'(8f10.5)') ((c(j,i),j=1,3),i=1,nres) write (iout,'(8f10.5)') ((c(j,i+nres),j=1,3),i=nnt,nct) write (iout,*) "Internal coordinates" + call intout write (iout,'(8f10.4)') (vbld(k),k=nnt+1,nct) write (iout,'(8f10.4)') (vbld(k),k=nres+nnt,nres+nct) write (iout,'(8f10.4)') (rad2deg*theta(k),k=3,nres) diff --git a/source/wham/src-HCD-5D/energy_p_new.F b/source/wham/src-HCD-5D/energy_p_new.F index 1842afd..5360778 100644 --- a/source/wham/src-HCD-5D/energy_p_new.F +++ b/source/wham/src-HCD-5D/energy_p_new.F @@ -124,12 +124,18 @@ C endif c print *,"Processor",myrank," computed Utord" C - call eback_sc_corr(esccor) + if (wsccor.gt.0.0d0) then + call eback_sc_corr(esccor) + else + esccor=0.0d0 + endif if (wliptran.gt.0) then call Eliptransfer(eliptran) + else + eliptran=0.0d0 endif - +#ifdef FOURBODY C C 12/1/95 Multi-body terms C @@ -151,6 +157,7 @@ c write (iout,*) ecorr,ecorr5,ecorr6,eturn6 c write (iout,*) "Calling multibody_hbond" call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1) endif +#endif c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr if (nsaxs.gt.0 .and. saxs_mode.eq.0) then call e_saxs(Esaxs_constr) @@ -506,10 +513,17 @@ C Bartek #ifdef SPLITELE write(iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,wvdwpp, & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1), - & etors_d,wtor_d*fact(2),ehpb,wstrain,ecorr,wcorr*fact(3), - & ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),eel_loc, + & etors_d,wtor_d*fact(2),ehpb,wstrain, +#ifdef FOURBODY + & ecorr,wcorr*fact(3), + & ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), +#endif + & eel_loc, & wel_loc*fact(2),eello_turn3,wturn3*fact(2), - & eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5), + & eello_turn4,wturn4*fact(3), +#ifdef FOURBODY + & eello_turn6,wturn6*fact(5), +#endif & esccor,wsccor*fact(1),edihcnstr, & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, & etube,wtube,esaxs,wsaxs,ehomology_constr, @@ -528,13 +542,17 @@ C Bartek & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, & ' (SS bridges & dist. cnstr.)'/ +#ifdef FOURBODY & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ @@ -554,10 +572,16 @@ C Bartek #else write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1), & estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1), - & etors_d,wtor_d*fact(2),ehpb,wstrain,ecorr,wcorr*fact(3), + & etors_d,wtor_d*fact(2),ehpb,wstrain, +#ifdef FOURBODY + & ecorr,wcorr*fact(3), & ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5), +#endif & eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2), - & eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5), + & eello_turn4,wturn4*fact(3), +#ifdef FOURBODY + & eello_turn6,wturn6*fact(5), +#endif & esccor,wsccor*fact(1),edihcnstr, & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc, & etube,wtube,esaxs,wsaxs,ehomology_constr, @@ -575,13 +599,17 @@ C Bartek & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/ & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6, & ' (SS bridges & dist. restr.)'/ +#ifdef FOURBODY & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/ +#endif & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/ & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/ & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/ +#ifdef FOURBODY & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/ +#endif & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/ & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/ & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/ @@ -622,7 +650,10 @@ C include 'COMMON.SBRIDGE' include 'COMMON.NAMES' include 'COMMON.IOUNITS' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif dimension gg(3) integer icant external icant @@ -661,6 +692,10 @@ cd & 'iend=',iend(i,iint) C Change 12/1/95 to calculate four-body interactions rij=xj*xj+yj*yj+zj*zj rrij=1.0D0/rij + sqrij=dsqrt(rij) + sss1=sscale(sqrij) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(sqrij) c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj eps0ij=eps(itypi,itypj) fac=rrij**expon2 @@ -680,15 +715,16 @@ cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj), cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm, cd & (c(k,i),k=1,3),(c(k,j),k=1,3) if (bb.gt.0.0d0) then - evdw=evdw+evdwij + evdw=evdw+sss1*evdwij else - evdw_t=evdw_t+evdwij + evdw_t=evdw_t+sss1*evdwij endif if (calc_grad) then C C Calculate the components of the gradient in DC and X C - fac=-rrij*(e1+evdwij) + fac=-rrij*(e1+evdwij)*sss1 + & +evdwij*sssgrad1/sqrij/expon gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -702,6 +738,7 @@ C enddo enddo endif +#ifdef FOURBODY C C 12/1/95, revised on 5/20/97 C @@ -758,10 +795,13 @@ cd write (iout,'(2i3,3f10.5)') cd & i,j,(gacont(kk,num_conti,i),kk=1,3) endif endif +#endif enddo ! j enddo ! iint +#ifdef FOURBODY C Change 12/1/95 num_cont(i)=num_conti +#endif enddo ! i if (calc_grad) then do i=1,nct @@ -835,6 +875,9 @@ C e_augm=augm(itypi,itypj)*fac_augm r_inv_ij=dsqrt(rrij) rij=1.0D0/r_inv_ij + sss1=sscale(rij) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(rij) r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj)) fac=r_shift_inv**expon e1=fac*fac*aa @@ -852,15 +895,16 @@ cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm, cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij, cd & (c(k,i),k=1,3),(c(k,j),k=1,3) if (bb.gt.0.0d0) then - evdw=evdw+evdwij + evdw=evdw+evdwij*sss1 else - evdw_t=evdw_t+evdwij + evdw_t=evdw_t+evdwij*sss1 endif if (calc_grad) then C C Calculate the components of the gradient in DC and X C - fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2) + fac=(-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2))*sss1 + & +evdwij*sssgrad1*r_inv_ij/expon gg(1)=xj*fac gg(2)=yj*fac gg(3)=zj*fac @@ -978,6 +1022,10 @@ cd else cd rrij=rrsave(ind) cd endif rij=dsqrt(rrij) + sss1=sscale(1.0d0/rij) + if (sss1.eq.0.0d0) cycle + sssgrad1=sscagrad(1.0d0/rij) + C Calculate the angle-dependent terms of energy & contributions to derivatives. call sc_angular C Calculate whole angle-dependent part of epsilon and contributions @@ -995,9 +1043,9 @@ C to its derivatives & /dabs(eps(itypi,itypj)) eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj) if (bb.gt.0.0d0) then - evdw=evdw+evdwij + evdw=evdw+sss1*evdwij else - evdw_t=evdw_t+evdwij + evdw_t=evdw_t+sss1*evdwij endif if (calc_grad) then if (lprn) then @@ -1015,6 +1063,7 @@ C Calculate gradient components. fac=-expon*(e1+evdwij) sigder=fac/sigsq fac=rrij*fac + & +evdwij*sssgrad1/sss1*rij C Calculate radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac @@ -1240,8 +1289,8 @@ C finding the closest c write (iout,*) i,j,xj,yj,zj rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) - sss=sscale((1.0d0/rij)/sigma(itypi,itypj)) - sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj)) + sss=sscale(1.0d0/rij) + sssgrad=sscagrad(1.0d0/rij) if (sss.le.0.0) cycle C Calculate angle-dependent terms of energy and contributions to their C derivatives. @@ -1401,6 +1450,9 @@ c alf12=0.0D0 dzj=dc_norm(3,nres+j) rrij=1.0D0/(xj*xj+yj*yj+zj*zj) rij=dsqrt(rrij) + sss=sscale(1.0d0/rij) + if (sss.eq.0.0d0) cycle + sssgrad=sscagrad(1.0d0/rij) C Calculate angle-dependent terms of energy and contributions to their C derivatives. call sc_angular @@ -1425,9 +1477,9 @@ c--------------------------------------------------------------- e_augm=augm(itypi,itypj)*fac_augm evdwij=evdwij*eps2rt*eps3rt if (bb.gt.0.0d0) then - evdw=evdw+evdwij+e_augm + evdw=evdw+(evdwij+e_augm)*sss else - evdw_t=evdw_t+evdwij+e_augm + evdw_t=evdw_t+(evdwij+e_augm)*sss endif ij=icant(itypi,itypj) aux=eps1*eps2rt**2*eps3rt**2 @@ -1453,6 +1505,7 @@ C Calculate gradient components. fac=-expon*(e1+evdwij)*rij_shift sigder=fac*sigder fac=rij*fac-2*expon*rrij*e_augm + fac=fac+(evdwij+e_augm)*sssgrad/sss*rij C Calculate the radial part of the gradient gg(1)=xj*fac gg(2)=yj*fac @@ -1730,7 +1783,7 @@ C-------------------------------------------------------------------------- include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' - include 'COMMON.CONTACTS' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -1962,6 +2015,7 @@ c & EE(1,2,iti),EE(2,2,i) c write(iout,*) "Macierz EUG", c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2), c & eug(2,2,i-2) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) & then call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2)) @@ -1970,6 +2024,7 @@ c & eug(2,2,i-2) call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2)) call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2)) endif +#endif else do k=1,2 Ub2(k,i-2)=0.0d0 @@ -2011,6 +2066,7 @@ c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then #endif cd write (iout,*) 'mu1',mu1(:,i-2) cd write (iout,*) 'mu2',mu2(:,i-2) +#ifdef FOURBODY if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) & then if (calc_grad) then @@ -2033,7 +2089,9 @@ C Vectors and matrices dependent on a single virtual-bond dihedral. call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2)) endif endif +#endif enddo +#ifdef FOURBODY C Matrices dependent on two consecutive virtual-bond dihedrals. C The order of matrices is from left to right. if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) @@ -2053,6 +2111,7 @@ C The order of matrices is from left to right. endif enddo endif +#endif return end C-------------------------------------------------------------------------- @@ -2078,7 +2137,11 @@ C include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -2151,9 +2214,11 @@ cd enddo eello_turn3=0.0d0 eello_turn4=0.0d0 ind=0 +#ifdef FOURBODY do i=1,nres num_cont_hb(i)=0 enddo +#endif cd print '(a)','Enter EELEC' cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e do i=1,nres @@ -2204,7 +2269,9 @@ c end if num_conti=0 call eelecij(i,i+2,ees,evdw1,eel_loc) if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo do i=iturn4_start,iturn4_end if (i.lt.1) cycle @@ -2259,13 +2326,16 @@ c endif if (ymedi.lt.0) ymedi=ymedi+boxysize zmedi=mod(zmedi,boxzsize) if (zmedi.lt.0) zmedi=zmedi+boxzsize - +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif c write(iout,*) "JESTEM W PETLI" call eelecij(i,i+3,ees,evdw1,eel_loc) if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1) & call eturn4(i,eello_turn4) +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i C Loop over all neighbouring boxes C do xshift=-1,1 @@ -2332,7 +2402,9 @@ c go to 166 c endif c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i) +#ifdef FOURBODY num_conti=num_cont_hb(i) +#endif C I TU KURWA do j=ielstart(i),ielend(i) C do j=16,17 @@ -2348,7 +2420,9 @@ c & .or.itype(j-1).eq.ntyp1 &) cycle call eelecij(i,j,ees,evdw1,eel_loc) enddo ! j +#ifdef FOURBODY num_cont_hb(i)=num_conti +#endif enddo ! i C enddo ! zshift C enddo ! yshift @@ -2380,7 +2454,11 @@ C------------------------------------------------------------------------------- include 'COMMON.CHAIN' include 'COMMON.DERIV' include 'COMMON.INTERACT' +#ifdef FOURBODY include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' +#endif + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VECTORS' include 'COMMON.FFIELD' @@ -2498,8 +2576,9 @@ C yj=yj-ymedi C zj=zj-zmedi rij=xj*xj+yj*yj+zj*zj - sss=sscale(sqrt(rij)) - sssgrad=sscagrad(sqrt(rij)) + sss=sscale(sqrt(rij)) + if (sss.eq.0.0d0) return + sssgrad=sscagrad(sqrt(rij)) c write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut, c & " rlamb",rlamb," sss",sss c if (sss.gt.0.0d0) then @@ -2667,9 +2746,10 @@ cgrad gelc(l,k)=gelc(l,k)+ggg(l) cgrad enddo cgrad enddo if (sss.gt.0.0) then - ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj - ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj - ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj + facvdw=facvdw+sssgrad*rmij*evdwij + ggg(1)=facvdw*xj + ggg(2)=facvdw*yj + ggg(3)=facvdw*zj else ggg(1)=0.0 ggg(2)=0.0 @@ -2696,10 +2776,11 @@ cgrad enddo endif ! calc_grad #else C MARYSIA - facvdw=(ev1+evdwij)*sss + facvdw=(ev1+evdwij) facel=(el1+eesij) fac1=fac - fac=-3*rrmij*(facvdw+facvdw+facel) + fac=-3*rrmij*(facvdw+facvdw+facel)*sss + & +(evdwij+eesij)*sssgrad*rrmij erij(1)=xj*rmij erij(2)=yj*rmij erij(3)=zj*rmij @@ -3015,7 +3096,7 @@ C fac_shield(i)=0.4 C fac_shield(j)=0.6 endif eel_loc_ij=eel_loc_ij - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') & 'eelloc',i,j,eel_loc_ij c if (eel_loc_ij.ne.0) @@ -3079,7 +3160,7 @@ C Calculate patrial derivative for theta angle & +a23*gmuij1(2) & +a32*gmuij1(3) & +a33*gmuij1(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss c write(iout,*) "derivative over thatai" c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3), c & a33*gmuij1(4) @@ -3095,7 +3176,7 @@ c & a33*gmuij2(4) & +a33*gmuij2(4) gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ & geel_loc_ij*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss c Derivative over j residue geel_loc_ji=a22*gmuji1(1) @@ -3120,7 +3201,7 @@ c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3), c & a33*gmuji2(4) gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+ & geel_loc_ji*wel_loc - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss #endif cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij @@ -3136,10 +3217,14 @@ C Partial derivatives in virtual-bond dihedral angles gamma & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) & *fac_shield(i)*fac_shield(j) C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2) + aux=eel_loc_ij/sss*sssgrad*rmij + ggg(1)=aux*xj + ggg(2)=aux*yj + ggg(3)=aux*zj do l=1,3 - ggg(l)=(agg(l,1)*muij(1)+ + ggg(l)=ggg(l)+(agg(l,1)*muij(1)+ & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l) gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l) cgrad ghalf=0.5d0*ggg(l) @@ -3176,6 +3261,7 @@ C Remaining derivatives of eello C Change 12/26/95 to calculate four-body contributions to H-bonding energy c if (j.gt.i+1 .and. num_conti.le.maxconts) then +#ifdef FOURBODY if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 & .and. num_conti.le.maxconts) then c write (iout,*) i,j," entered corr" @@ -3315,11 +3401,17 @@ cd fprimcont=0.0D0 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k) enddo gggp(1)=gggp(1)+ees0pijp*xj + & +ees0p(num_conti,i)/sss*rmij*xj*sssgrad gggp(2)=gggp(2)+ees0pijp*yj + & +ees0p(num_conti,i)/sss*rmij*yj*sssgrad gggp(3)=gggp(3)+ees0pijp*zj + & +ees0p(num_conti,i)/sss*rmij*zj*sssgrad gggm(1)=gggm(1)+ees0mijp*xj + & +ees0m(num_conti,i)/sss*rmij*xj*sssgrad gggm(2)=gggm(2)+ees0mijp*yj + & +ees0m(num_conti,i)/sss*rmij*yj*sssgrad gggm(3)=gggm(3)+ees0mijp*zj + & +ees0m(num_conti,i)/sss*rmij*zj*sssgrad C Derivatives due to the contact function gacont_hbr(1,num_conti,i)=fprimcont*xj gacont_hbr(2,num_conti,i)=fprimcont*yj @@ -3334,28 +3426,28 @@ cgrad ghalfm=0.5D0*gggm(k) gacontp_hb1(k,num_conti,i)=!ghalfp & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontp_hb2(k,num_conti,i)=!ghalfp & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontp_hb3(k,num_conti,i)=gggp(k) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontm_hb1(k,num_conti,i)=!ghalfm & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontm_hb2(k,num_conti,i)=!ghalfm & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss gacontm_hb3(k,num_conti,i)=gggm(k) - & *fac_shield(i)*fac_shield(j) + & *fac_shield(i)*fac_shield(j)*sss enddo C Diagnostics. Comment out or remove after debugging! @@ -3374,6 +3466,7 @@ cdiag enddo endif ! num_conti.le.maxconts endif ! fcont.gt.0 endif ! j.gt.i+1 +#endif if (calc_grad) then if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then do k=1,4 @@ -3415,6 +3508,7 @@ C Third- and fourth-order contributions from turns include 'COMMON.FFIELD' include 'COMMON.CONTROL' include 'COMMON.SHIELD' + include 'COMMON.CORRMAT' dimension ggg(3) double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2), & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2), @@ -3603,6 +3697,7 @@ C Third- and fourth-order contributions from turns include 'COMMON.FFIELD' include 'COMMON.CONTROL' include 'COMMON.SHIELD' + include 'COMMON.CORRMAT' dimension ggg(3) double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2), & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2), @@ -5479,14 +5574,14 @@ C if (itype(i-1).eq.ntyp1) cycle coskt(k)=dcos(k*theti2) sinkt(k)=dsin(k*theti2) enddo -cu if (i.eq.3) then -cu phii=0.0d0 -cu ityp1=nthetyp+1 -cu do k=1,nsingle -cu cosph1(k)=0.0d0 -cu sinph1(k)=0.0d0 -cu enddo -cu else + if (i.eq.3) then + phii=0.0d0 + ityp1=nthetyp+1 + do k=1,nsingle + cosph1(k)=0.0d0 + sinph1(k)=0.0d0 + enddo + else if (i.gt.3 .and. itype(i-3).ne.ntyp1) then #ifdef OSF phii=phi(i) @@ -5508,7 +5603,7 @@ c ityp1=nthetyp+1 sinph1(k)=0.0d0 enddo endif -cu endif + endif if (i.lt.nres .and. itype(i+1).ne.ntyp1) then #ifdef OSF phii1=phi(i+1) @@ -6934,6 +7029,7 @@ c gsccor_loc(i-3)=gloci enddo return end +#ifdef FOURBODY c------------------------------------------------------------------------------ subroutine multibody(ecorr) C This subroutine calculates multi-body contributions to energy following @@ -6946,6 +7042,8 @@ C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added. include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision gx(3),gx1(3) logical lprn @@ -7000,6 +7098,8 @@ c------------------------------------------------------------------------------ include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision gx(3),gx1(3) logical lprn lprn=.false. @@ -7042,6 +7142,8 @@ C This subroutine calculates multi-body contributions to hydrogen-bonding include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' double precision gx(3),gx1(3) logical lprn,ldone @@ -7115,6 +7217,8 @@ C This subroutine calculates multi-body contributions to hydrogen-bonding include 'COMMON.LOCAL' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.CHAIN' include 'COMMON.CONTROL' include 'COMMON.SHIELD' @@ -7272,6 +7376,8 @@ c------------------------------------------------------------------------------ include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.SHIELD' include 'COMMON.CONTROL' double precision gx(3),gx1(3) @@ -7448,6 +7554,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -7514,6 +7622,8 @@ C include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -7893,6 +8003,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -8008,6 +8120,8 @@ C--------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -8425,6 +8539,8 @@ c-------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -8568,6 +8684,8 @@ c-------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -8675,6 +8793,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -8863,6 +8983,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -8981,6 +9103,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -9228,6 +9352,8 @@ c---------------------------------------------------------------------------- include 'COMMON.DERIV' include 'COMMON.INTERACT' include 'COMMON.CONTACTS' + include 'COMMON.CONTMAT' + include 'COMMON.CORRMAT' include 'COMMON.TORSION' include 'COMMON.VAR' include 'COMMON.GEO' @@ -9548,7 +9674,7 @@ cd write (2,*) 'ekont',ekont cd write (2,*) 'eel_turn6',ekont*eel_turn6 return end - +#endif crc------------------------------------------------- CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC subroutine Eliptransfer(eliptran) diff --git a/source/wham/src-HCD-5D/include_unres/COMMON.CONTACTS b/source/wham/src-HCD-5D/include_unres/COMMON.CONTACTS index 4525a07..871e353 100644 --- a/source/wham/src-HCD-5D/include_unres/COMMON.CONTACTS +++ b/source/wham/src-HCD-5D/include_unres/COMMON.CONTACTS @@ -3,69 +3,3 @@ C Change 12/1/95 - common block CONTACTS1 included. double precision facont,gacont common /contacts/ ncont,ncont_ref,icont(2,maxcont), & icont_ref(2,maxcont) - common /contacts1/ facont(maxconts,maxres), - & gacont(3,maxconts,maxres), - & num_cont(maxres),jcont(maxconts,maxres) -C 12/26/95 - H-bonding contacts - common /contacts_hb/ - & gacontp_hb1(3,maxconts,maxres),gacontp_hb2(3,maxconts,maxres), - & gacontp_hb3(3,maxconts,maxres), - & gacontm_hb1(3,maxconts,maxres),gacontm_hb2(3,maxconts,maxres), - & gacontm_hb3(3,maxconts,maxres), - & gacont_hbr(3,maxconts,maxres), - & grij_hb_cont(3,maxconts,maxres), - & facont_hb(maxconts,maxres),ees0p(maxconts,maxres), - & ees0m(maxconts,maxres),d_cont(maxconts,maxres), - & num_cont_hb(maxres),jcont_hb(maxconts,maxres) -C 9/23/99 Added improper rotation matrices and matrices of dipole-dipole -C interactions -C Interactions of pseudo-dipoles generated by loc-el interactions. - double precision dip,dipderg,dipderx - common /dipint/ dip(4,maxconts,maxres),dipderg(4,maxconts,maxres), - & dipderx(3,5,4,maxconts,maxres) -C 10/30/99 Added other pre-computed vectors and matrices needed -C to calculate three - six-order el-loc correlation terms - double precision Ug,Ugder,Ug2,Ug2der,obrot,obrot2,obrot_der, - & obrot2_der,Ub2,Ub2der,mu,muder,EUg,EUgder,CUg,CUgder,gmu,gUb2, - & DUg,DUgder,DtUg2,DtUg2der,Ctobr,Ctobrder,Dtobr2,Dtobr2der, - & gtEUg - common /rotat/ Ug(2,2,maxres),Ugder(2,2,maxres),Ug2(2,2,maxres), - & Ug2der(2,2,maxres),obrot(2,maxres),obrot2(2,maxres), - & obrot_der(2,maxres),obrot2_der(2,maxres) -C This common block contains vectors and matrices dependent on a single -C amino-acid residue. - common /precomp1/ Ub2(2,maxres),Ub2der(2,maxres),mu(2,maxres), - & gmu(2,maxres),gUb2(2,maxres), - & EUg(2,2,maxres),EUgder(2,2,maxres),CUg(2,2,maxres), - & CUgder(2,2,maxres),DUg(2,2,maxres),Dugder(2,2,maxres), - & DtUg2(2,2,maxres),DtUg2der(2,2,maxres),Ctobr(2,maxres), - & Ctobrder(2,maxres),Dtobr2(2,maxres),Dtobr2der(2,maxres), - & gtEUg(2,2,maxres) -C This common block contains vectors and matrices dependent on two -C consecutive amino-acid residues. - double precision Ug2Db1t,Ug2Db1tder,CUgb2,CUgb2der,EUgC, - & EUgCder,EUgD,EUgDder,DtUg2EUg,DtUg2EUgder - common /precomp2/ Ug2Db1t(2,maxres),Ug2Db1tder(2,maxres), - & CUgb2(2,maxres),CUgb2der(2,maxres),EUgC(2,2,maxres), - & EUgCder(2,2,maxres),EUgD(2,2,maxres),EUgDder(2,2,maxres), - & DtUg2EUg(2,2,maxres),DtUg2EUgder(2,2,2,maxres), - & Ug2DtEUg(2,2,maxres),Ug2DtEUgder(2,2,2,maxres) - double precision costab,sintab,costab2,sintab2 - common /rotat_old/ costab(maxres),sintab(maxres), - & costab2(maxres),sintab2(maxres),muder(2,maxres) -C This common block contains dipole-interaction matrices and their -C Cartesian derivatives. - double precision a_chuj,a_chuj_der - common /dipmat/ a_chuj(2,2,maxconts,maxres), - & a_chuj_der(2,2,3,5,maxconts,maxres) - double precision AEA,AEAderg,AEAderx,AECA,AECAderg,AECAderx, - & ADtEA,ADtEAderg,ADtEAderx,AEAb1,AEAb1derg,AEAb1derx, - & AEAb2,AEAb2derg,AEAb2derx - common /diploc/ AEA(2,2,2),AEAderg(2,2,2),AEAderx(2,2,3,5,2,2), - & EAEA(2,2,2), EAEAderg(2,2,2,2), EAEAderx(2,2,3,5,2,2), - & AECA(2,2,2),AECAderg(2,2,2),AECAderx(2,2,3,5,2,2), - & ADtEA(2,2,2),ADtEAderg(2,2,2,2),ADtEAderx(2,2,3,5,2,2), - & ADtEA1(2,2,2),ADtEA1derg(2,2,2,2),ADtEA1derx(2,2,3,5,2,2), - & AEAb1(2,2,2),AEAb1derg(2,2,2),AEAb1derx(2,3,5,2,2,2), - & AEAb2(2,2,2),AEAb2derg(2,2,2,2),AEAb2derx(2,3,5,2,2,2), - & g_contij(3,2),ekont diff --git a/source/wham/src-HCD-5D/parmread.F b/source/wham/src-HCD-5D/parmread.F index 89004f4..ecf40a7 100644 --- a/source/wham/src-HCD-5D/parmread.F +++ b/source/wham/src-HCD-5D/parmread.F @@ -1064,8 +1064,8 @@ c Dtilde(2,2,i)=0.0d0 EEold(2,2,-i)=-b(10,i)+b(11,i) EEold(2,1,-i)=-b(12,i)+b(13,i) EEold(1,2,-i)=-b(12,i)-b(13,i) -c write(iout,*) "TU DOCHODZE" -c print *,"JESTEM" + write(iout,*) "TU DOCHODZE" + print *,"JESTEM" c ee(1,1,i)=1.0d0 c ee(2,2,i)=1.0d0 c ee(2,1,i)=0.0d0 diff --git a/source/wham/src-HCD-5D/read_constr_homology.F b/source/wham/src-HCD-5D/read_constr_homology.F index 168211e..7884fd5 100644 --- a/source/wham/src-HCD-5D/read_constr_homology.F +++ b/source/wham/src-HCD-5D/read_constr_homology.F @@ -184,13 +184,14 @@ c write(iout,*) "tpl_k_rescore - ",tpl_k_rescore do irec=nnt,nct ! loop for reading res sim if (read2sigma) then read (ientin,*,end=1401) i_tmp,rescore2_tmp,rescore_tmp, + & idomain_tmp, & rescore3_tmp,idomain_tmp i_tmp=i_tmp+nnt-1 idomain(k,i_tmp)=idomain_tmp rescore(k,i_tmp)=rescore_tmp rescore2(k,i_tmp)=rescore2_tmp rescore3(k,i_tmp)=rescore3_tmp - write(iout,'(a7,i5,3f10.5,i5)') "rescore", + write(iout,'(a7,i5,2f10.5,i5)') "rescore", & i_tmp,rescore2_tmp,rescore_tmp, & rescore3_tmp,idomain_tmp else @@ -358,6 +359,7 @@ c write (iout,*) "xxtpl(",k,i,") =",xxtpl(k,i) c write (iout,*) "yytpl(",k,i,") =",yytpl(k,i) c write (iout,*) "zztpl(",k,i,") =",zztpl(k,i) c write(iout,*) "rescore(",k,i,") =",rescore(k,i) +c sigma_d(k,i)=rescore(k,i) ! right expression ? sigma_d(k,i)=rescore3(k,i) ! right expression ? if (sigma_d(k,i).ne.0) & sigma_d(k,i)=1.0d0/(sigma_d(k,i)*sigma_d(k,i))