1 subroutine etotal(energia)
7 cMS$ATTRIBUTES C :: proc_proc
12 double precision weights_(n_ene)
13 double precision time00
16 include 'COMMON.SETUP'
17 include 'COMMON.IOUNITS'
18 double precision energia(0:n_ene)
19 include 'COMMON.LOCAL'
20 include 'COMMON.FFIELD'
21 include 'COMMON.DERIV'
22 include 'COMMON.INTERACT'
23 include 'COMMON.SBRIDGE'
24 include 'COMMON.CHAIN'
27 include 'COMMON.QRESTR'
28 include 'COMMON.CONTROL'
29 include 'COMMON.TIME1'
30 include 'COMMON.SPLITELE'
31 include 'COMMON.TORCNSTR'
33 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
34 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
35 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
36 & eliptran,Eafmforce,Etube,
37 & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
38 integer n_corr,n_corr1
40 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
41 c & " nfgtasks",nfgtasks
42 if (nfgtasks.gt.1) then
44 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
45 if (fg_rank.eq.0) then
46 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
47 c print *,"Processor",myrank," BROADCAST iorder"
48 C FG master sets up the WEIGHTS_ array which will be broadcast to the
49 C FG slaves as WEIGHTS array.
71 weights_(28)=wdfa_dist
74 weights_(31)=wdfa_beta
75 C FG Master broadcasts the WEIGHTS_ array
76 call MPI_Bcast(weights_(1),n_ene,
77 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
79 C FG slaves receive the WEIGHTS array
80 call MPI_Bcast(weights(1),n_ene,
81 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
103 wdfa_dist=weights_(28)
104 wdfa_tor=weights_(29)
105 wdfa_nei=weights_(30)
106 wdfa_beta=weights_(31)
108 time_Bcast=time_Bcast+MPI_Wtime()-time00
109 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
110 c call chainbuild_cart
118 c print *,'Processor',myrank,' calling etotal ipot=',ipot
119 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
121 c if (modecalc.eq.12.or.modecalc.eq.14) then
122 c call int_from_cart1(.false.)
129 C Compute the side-chain and electrostatic interaction energy
132 goto (101,102,103,104,105,106) ipot
133 C Lennard-Jones potential.
135 cd print '(a)','Exit ELJ'
137 C Lennard-Jones-Kihara potential (shifted).
140 C Berne-Pechukas potential (dilated LJ, angular dependence).
143 C Gay-Berne potential (shifted LJ, angular dependence).
145 C print *,"bylem w egb"
147 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
150 C Soft-sphere potential
151 106 call e_softsphere(evdw)
153 C Calculate electrostatic (H-bonding) energy of the main chain.
157 C BARTEK for dfa test!
158 if (wdfa_dist.gt.0) then
163 c print*, 'edfad is finished!', edfadis
164 if (wdfa_tor.gt.0) then
169 c print*, 'edfat is finished!', edfator
170 if (wdfa_nei.gt.0) then
175 c print*, 'edfan is finished!', edfanei
176 if (wdfa_beta.gt.0) then
183 cmc Sep-06: egb takes care of dynamic ss bonds too
185 c if (dyn_ss) call dyn_set_nss
187 c print *,"Processor",myrank," computed USCSC"
193 time_vec=time_vec+MPI_Wtime()-time01
195 C Introduction of shielding effect first for each peptide group
196 C the shielding factor is set this factor is describing how each
197 C peptide group is shielded by side-chains
198 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
199 C write (iout,*) "shield_mode",shield_mode
200 if (shield_mode.eq.1) then
202 else if (shield_mode.eq.2) then
205 c print *,"Processor",myrank," left VEC_AND_DERIV"
208 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
209 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
210 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
211 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
213 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
214 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
215 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
216 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
218 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
227 write (iout,*) "Soft-spheer ELEC potential"
228 c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
232 c time_enecalc=time_enecalc+MPI_Wtime()-time00
234 c print *,"Processor",myrank," computed UELEC"
236 C Calculate excluded-volume interaction energy between peptide groups
241 call escp(evdw2,evdw2_14)
247 c write (iout,*) "Soft-sphere SCP potential"
248 call escp_soft_sphere(evdw2,evdw2_14)
251 c Calculate the bond-stretching energy
255 C Calculate the disulfide-bridge and other energy and the contributions
256 C from other distance constraints.
257 cd write (iout,*) 'Calling EHPB'
259 cd print *,'EHPB exitted succesfully.'
261 C Calculate the virtual-bond-angle energy.
263 if (wang.gt.0d0) then
264 if (tor_mode.eq.0) then
267 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
275 if (with_theta_constr) call etheta_constr(ethetacnstr)
276 c print *,"Processor",myrank," computed UB"
278 C Calculate the SC local energy.
280 C print *,"TU DOCHODZE?"
282 c print *,"Processor",myrank," computed USC"
284 C Calculate the virtual-bond torsional energy.
286 cd print *,'nterm=',nterm
287 C print *,"tor",tor_mode
288 if (wtor.gt.0.0d0) then
289 if (tor_mode.eq.0) then
292 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
300 if (ndih_constr.gt.0) call etor_constr(edihcnstr)
301 c print *,"Processor",myrank," computed Utor"
302 if (constr_homology.ge.1) then
303 call e_modeller(ehomology_constr)
304 c print *,'iset=',iset,'me=',me,ehomology_constr,
305 c & 'Processor',fg_rank,' CG group',kolor,
306 c & ' absolute rank',MyRank
308 ehomology_constr=0.0d0
311 C 6/23/01 Calculate double-torsional energy
313 if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
318 c print *,"Processor",myrank," computed Utord"
320 C 21/5/07 Calculate local sicdechain correlation energy
322 if (wsccor.gt.0.0d0) then
323 call eback_sc_corr(esccor)
327 C print *,"PRZED MULIt"
328 c print *,"Processor",myrank," computed Usccorr"
330 C 12/1/95 Multi-body terms
334 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
335 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
336 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
337 c write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
338 c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
346 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
347 c write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
350 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
351 c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
355 c print *,"Processor",myrank," computed Ucorr"
356 c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
357 if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
358 call e_saxs(Esaxs_constr)
359 c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
360 else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
361 call e_saxsC(Esaxs_constr)
362 c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
367 C If performing constraint dynamics, call the constraint energy
368 C after the equilibration time
369 c if(usampl.and.totT.gt.eq_time) then
370 c write (iout,*) "usampl",usampl
374 call Econstr_back_qlike
382 C 01/27/2015 added by adasko
383 C the energy component below is energy transfer into lipid environment
384 C based on partition function
385 C print *,"przed lipidami"
386 if (wliptran.gt.0) then
387 call Eliptransfer(eliptran)
389 C print *,"za lipidami"
390 if (AFMlog.gt.0) then
391 call AFMforce(Eafmforce)
392 else if (selfguide.gt.0) then
393 call AFMvel(Eafmforce)
395 if (TUBElog.eq.1) then
396 C print *,"just before call"
398 elseif (TUBElog.eq.2) then
399 call calctube2(Etube)
405 time_enecalc=time_enecalc+MPI_Wtime()-time00
407 c print *,"Processor",myrank," computed Uconstr"
416 energia(2)=evdw2-evdw2_14
433 energia(8)=eello_turn3
434 energia(9)=eello_turn4
441 energia(19)=edihcnstr
443 energia(20)=Uconst+Uconst_back
446 energia(23)=Eafmforce
447 energia(24)=ethetacnstr
449 energia(26)=Esaxs_constr
450 energia(27)=ehomology_constr
455 c write (iout,*) "esaxs_constr",energia(26)
456 c Here are the energies showed per procesor if the are more processors
457 c per molecule then we sum it up in sum_energy subroutine
458 c print *," Processor",myrank," calls SUM_ENERGY"
459 call sum_energy(energia,.true.)
460 c write (iout,*) "After sum_energy: esaxs_constr",energia(26)
461 if (dyn_ss) call dyn_set_nss
462 c print *," Processor",myrank," left SUM_ENERGY"
464 time_sumene=time_sumene+MPI_Wtime()-time00
468 c-------------------------------------------------------------------------------
469 subroutine sum_energy(energia,reduce)
475 cMS$ATTRIBUTES C :: proc_proc
481 double precision time00
483 include 'COMMON.SETUP'
484 include 'COMMON.IOUNITS'
485 double precision energia(0:n_ene),enebuff(0:n_ene+1)
486 include 'COMMON.FFIELD'
487 include 'COMMON.DERIV'
488 include 'COMMON.INTERACT'
489 include 'COMMON.SBRIDGE'
490 include 'COMMON.CHAIN'
492 include 'COMMON.CONTROL'
493 include 'COMMON.TIME1'
496 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
497 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
498 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
499 & eliptran,Eafmforce,Etube,
500 & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
501 double precision Uconst,etot
503 if (nfgtasks.gt.1 .and. reduce) then
505 write (iout,*) "energies before REDUCE"
506 call enerprint(energia)
510 enebuff(i)=energia(i)
513 call MPI_Barrier(FG_COMM,IERR)
514 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
516 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
517 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
519 write (iout,*) "energies after REDUCE"
520 call enerprint(energia)
523 time_Reduce=time_Reduce+MPI_Wtime()-time00
525 if (fg_rank.eq.0) then
529 evdw2=energia(2)+energia(18)
545 eello_turn3=energia(8)
546 eello_turn4=energia(9)
553 edihcnstr=energia(19)
558 Eafmforce=energia(23)
559 ethetacnstr=energia(24)
561 esaxs_constr=energia(26)
562 ehomology_constr=energia(27)
568 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
569 & +wang*ebe+wtor*etors+wscloc*escloc
570 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
571 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
572 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
573 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
574 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
575 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
578 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
579 & +wang*ebe+wtor*etors+wscloc*escloc
580 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
581 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
582 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
583 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
585 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
586 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
593 if (isnan(etot).ne.0) energia(0)=1.0d+99
595 if (isnan(etot)) energia(0)=1.0d+99
600 idumm=proc_proc(etot,i)
602 call proc_proc(etot,i)
604 if(i.eq.1)energia(0)=1.0d+99
611 c-------------------------------------------------------------------------------
612 subroutine sum_gradient
618 cMS$ATTRIBUTES C :: proc_proc
624 double precision time00,time01
626 double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
627 & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
628 & ,gloc_scbuf(3,-1:maxres)
629 include 'COMMON.SETUP'
630 include 'COMMON.IOUNITS'
631 include 'COMMON.FFIELD'
632 include 'COMMON.DERIV'
633 include 'COMMON.INTERACT'
634 include 'COMMON.SBRIDGE'
635 include 'COMMON.CHAIN'
637 include 'COMMON.CONTROL'
638 include 'COMMON.TIME1'
639 include 'COMMON.MAXGRAD'
640 include 'COMMON.SCCOR'
641 c include 'COMMON.MD'
642 include 'COMMON.QRESTR'
644 double precision scalar
645 double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
646 &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
647 &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
648 &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
649 &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
655 write (iout,*) "sum_gradient gvdwc, gvdwx"
657 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
658 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
663 write (iout,*) "sum_gradient gsaxsc, gsaxsx"
665 write (iout,'(i3,3e15.5,5x,3e15.5)')
666 & i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
671 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
672 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
673 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
676 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
677 C in virtual-bond-vector coordinates
680 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
682 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
683 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
685 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
687 c write (iout,'(i5,3f10.5,2x,f10.5)')
688 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
690 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
692 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
693 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
699 write (iout,*) "gsaxsc"
701 write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
708 gradbufc(j,i)=wsc*gvdwc(j,i)+
709 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
710 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
711 & wel_loc*gel_loc_long(j,i)+
712 & wcorr*gradcorr_long(j,i)+
713 & wcorr5*gradcorr5_long(j,i)+
714 & wcorr6*gradcorr6_long(j,i)+
715 & wturn6*gcorr6_turn_long(j,i)+
717 & +wliptran*gliptranc(j,i)
719 & +welec*gshieldc(j,i)
720 & +wcorr*gshieldc_ec(j,i)
721 & +wturn3*gshieldc_t3(j,i)
722 & +wturn4*gshieldc_t4(j,i)
723 & +wel_loc*gshieldc_ll(j,i)
724 & +wtube*gg_tube(j,i)
731 gradbufc(j,i)=wsc*gvdwc(j,i)+
732 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
733 & welec*gelc_long(j,i)+
735 & wel_loc*gel_loc_long(j,i)+
736 & wcorr*gradcorr_long(j,i)+
737 & wcorr5*gradcorr5_long(j,i)+
738 & wcorr6*gradcorr6_long(j,i)+
739 & wturn6*gcorr6_turn_long(j,i)+
741 & +wliptran*gliptranc(j,i)
743 & +welec*gshieldc(j,i)
744 & +wcorr*gshieldc_ec(j,i)
745 & +wturn4*gshieldc_t4(j,i)
746 & +wel_loc*gshieldc_ll(j,i)
747 & +wtube*gg_tube(j,i)
754 gradbufc(j,i)=gradbufc(j,i)+
755 & wdfa_dist*gdfad(j,i)+
756 & wdfa_tor*gdfat(j,i)+
757 & wdfa_nei*gdfan(j,i)+
758 & wdfa_beta*gdfab(j,i)
762 write (iout,*) "gradc from gradbufc"
764 write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
769 if (nfgtasks.gt.1) then
772 write (iout,*) "gradbufc before allreduce"
774 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
780 gradbufc_sum(j,i)=gradbufc(j,i)
783 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
784 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
785 c time_reduce=time_reduce+MPI_Wtime()-time00
787 c write (iout,*) "gradbufc_sum after allreduce"
789 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
794 c time_allreduce=time_allreduce+MPI_Wtime()-time00
802 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
803 write (iout,*) (i," jgrad_start",jgrad_start(i),
804 & " jgrad_end ",jgrad_end(i),
805 & i=igrad_start,igrad_end)
808 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
809 c do not parallelize this part.
811 c do i=igrad_start,igrad_end
812 c do j=jgrad_start(i),jgrad_end(i)
814 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
819 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
823 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
827 write (iout,*) "gradbufc after summing"
829 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
836 write (iout,*) "gradbufc"
838 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
844 gradbufc_sum(j,i)=gradbufc(j,i)
849 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
853 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
858 c gradbufc(k,i)=0.0d0
862 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
867 write (iout,*) "gradbufc after summing"
869 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
877 gradbufc(k,nres)=0.0d0
882 C print *,gradbufc(1,13)
883 C print *,welec*gelc(1,13)
884 C print *,wel_loc*gel_loc(1,13)
885 C print *,0.5d0*(wscp*gvdwc_scpp(1,13))
886 C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
887 C print *,wel_loc*gel_loc_long(1,13)
888 C print *,gradafm(1,13),"AFM"
889 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
890 & wel_loc*gel_loc(j,i)+
891 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
892 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
893 & wel_loc*gel_loc_long(j,i)+
894 & wcorr*gradcorr_long(j,i)+
895 & wcorr5*gradcorr5_long(j,i)+
896 & wcorr6*gradcorr6_long(j,i)+
897 & wturn6*gcorr6_turn_long(j,i))+
899 & wcorr*gradcorr(j,i)+
900 & wturn3*gcorr3_turn(j,i)+
901 & wturn4*gcorr4_turn(j,i)+
902 & wcorr5*gradcorr5(j,i)+
903 & wcorr6*gradcorr6(j,i)+
904 & wturn6*gcorr6_turn(j,i)+
905 & wsccor*gsccorc(j,i)
906 & +wscloc*gscloc(j,i)
907 & +wliptran*gliptranc(j,i)
909 & +welec*gshieldc(j,i)
910 & +welec*gshieldc_loc(j,i)
911 & +wcorr*gshieldc_ec(j,i)
912 & +wcorr*gshieldc_loc_ec(j,i)
913 & +wturn3*gshieldc_t3(j,i)
914 & +wturn3*gshieldc_loc_t3(j,i)
915 & +wturn4*gshieldc_t4(j,i)
916 & +wturn4*gshieldc_loc_t4(j,i)
917 & +wel_loc*gshieldc_ll(j,i)
918 & +wel_loc*gshieldc_loc_ll(j,i)
919 & +wtube*gg_tube(j,i)
922 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
923 & wel_loc*gel_loc(j,i)+
924 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
925 & welec*gelc_long(j,i)+
926 & wel_loc*gel_loc_long(j,i)+
927 & wcorr*gcorr_long(j,i)+
928 & wcorr5*gradcorr5_long(j,i)+
929 & wcorr6*gradcorr6_long(j,i)+
930 & wturn6*gcorr6_turn_long(j,i))+
932 & wcorr*gradcorr(j,i)+
933 & wturn3*gcorr3_turn(j,i)+
934 & wturn4*gcorr4_turn(j,i)+
935 & wcorr5*gradcorr5(j,i)+
936 & wcorr6*gradcorr6(j,i)+
937 & wturn6*gcorr6_turn(j,i)+
938 & wsccor*gsccorc(j,i)
939 & +wscloc*gscloc(j,i)
940 & +wliptran*gliptranc(j,i)
942 & +welec*gshieldc(j,i)
943 & +welec*gshieldc_loc(j,i)
944 & +wcorr*gshieldc_ec(j,i)
945 & +wcorr*gshieldc_loc_ec(j,i)
946 & +wturn3*gshieldc_t3(j,i)
947 & +wturn3*gshieldc_loc_t3(j,i)
948 & +wturn4*gshieldc_t4(j,i)
949 & +wturn4*gshieldc_loc_t4(j,i)
950 & +wel_loc*gshieldc_ll(j,i)
951 & +wel_loc*gshieldc_loc_ll(j,i)
952 & +wtube*gg_tube(j,i)
956 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
958 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
959 & wsccor*gsccorx(j,i)
960 & +wscloc*gsclocx(j,i)
961 & +wliptran*gliptranx(j,i)
962 & +welec*gshieldx(j,i)
963 & +wcorr*gshieldx_ec(j,i)
964 & +wturn3*gshieldx_t3(j,i)
965 & +wturn4*gshieldx_t4(j,i)
966 & +wel_loc*gshieldx_ll(j,i)
967 & +wtube*gg_tube_sc(j,i)
974 if (constr_homology.gt.0) then
977 gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
978 gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
983 write (iout,*) "gradc gradx gloc after adding"
985 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
986 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
990 write (iout,*) "gloc before adding corr"
992 write (iout,*) i,gloc(i,icg)
996 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
997 & +wcorr5*g_corr5_loc(i)
998 & +wcorr6*g_corr6_loc(i)
999 & +wturn4*gel_loc_turn4(i)
1000 & +wturn3*gel_loc_turn3(i)
1001 & +wturn6*gel_loc_turn6(i)
1002 & +wel_loc*gel_loc_loc(i)
1005 write (iout,*) "gloc after adding corr"
1007 write (iout,*) i,gloc(i,icg)
1011 if (nfgtasks.gt.1) then
1014 gradbufc(j,i)=gradc(j,i,icg)
1015 gradbufx(j,i)=gradx(j,i,icg)
1019 glocbuf(i)=gloc(i,icg)
1023 write (iout,*) "gloc_sc before reduce"
1026 write (iout,*) i,j,gloc_sc(j,i,icg)
1033 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1037 call MPI_Barrier(FG_COMM,IERR)
1038 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1040 call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1041 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1042 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1043 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1044 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1045 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1046 time_reduce=time_reduce+MPI_Wtime()-time00
1047 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1048 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1049 time_reduce=time_reduce+MPI_Wtime()-time00
1051 write (iout,*) "gradc after reduce"
1054 write (iout,*) i,j,gradc(j,i,icg)
1059 write (iout,*) "gloc_sc after reduce"
1062 write (iout,*) i,j,gloc_sc(j,i,icg)
1067 write (iout,*) "gloc after reduce"
1069 write (iout,*) i,gloc(i,icg)
1074 if (gnorm_check) then
1076 c Compute the maximum elements of the gradient
1086 gcorr3_turn_max=0.0d0
1087 gcorr4_turn_max=0.0d0
1090 gcorr6_turn_max=0.0d0
1100 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1101 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1102 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1103 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1104 & gvdwc_scp_max=gvdwc_scp_norm
1105 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1106 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1107 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1108 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1109 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1110 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1111 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1112 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1113 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1114 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1115 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1116 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1117 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1118 & gcorr3_turn(1,i)))
1119 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1120 & gcorr3_turn_max=gcorr3_turn_norm
1121 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1122 & gcorr4_turn(1,i)))
1123 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1124 & gcorr4_turn_max=gcorr4_turn_norm
1125 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1126 if (gradcorr5_norm.gt.gradcorr5_max)
1127 & gradcorr5_max=gradcorr5_norm
1128 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1129 if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1130 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1131 & gcorr6_turn(1,i)))
1132 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1133 & gcorr6_turn_max=gcorr6_turn_norm
1134 gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1135 if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1136 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1137 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1138 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1139 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1140 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1141 if (gradx_scp_norm.gt.gradx_scp_max)
1142 & gradx_scp_max=gradx_scp_norm
1143 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1144 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1145 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1146 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1147 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1148 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1149 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1150 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1153 #if (defined AIX || defined CRAY)
1154 open(istat,file=statname,position="append")
1156 open(istat,file=statname,access="append")
1158 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1159 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1160 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1161 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1162 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1163 & gsccorrx_max,gsclocx_max
1165 if (gvdwc_max.gt.1.0d4) then
1166 write (iout,*) "gvdwc gvdwx gradb gradbx"
1168 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1169 & gradb(j,i),gradbx(j,i),j=1,3)
1171 call pdbout(0.0d0,'cipiszcze',iout)
1177 write (iout,*) "gradc gradx gloc"
1179 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1180 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1184 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1188 c-------------------------------------------------------------------------------
1189 subroutine rescale_weights(t_bath)
1195 include 'DIMENSIONS'
1196 include 'COMMON.IOUNITS'
1197 include 'COMMON.FFIELD'
1198 include 'COMMON.SBRIDGE'
1199 include 'COMMON.CONTROL'
1200 double precision t_bath
1201 double precision facT,facT2,facT3,facT4,facT5
1202 double precision kfac /2.4d0/
1203 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1205 c facT=2*temp0/(t_bath+temp0)
1206 if (rescale_mode.eq.0) then
1212 else if (rescale_mode.eq.1) then
1213 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1214 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1215 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1216 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1217 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1218 else if (rescale_mode.eq.2) then
1224 facT=licznik/dlog(dexp(x)+dexp(-x))
1225 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1226 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1227 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1228 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1230 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1231 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1233 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1237 if (shield_mode.gt.0) then
1238 wscp=weights(2)*fact
1240 wvdwpp=weights(16)*fact
1242 welec=weights(3)*fact
1243 wcorr=weights(4)*fact3
1244 wcorr5=weights(5)*fact4
1245 wcorr6=weights(6)*fact5
1246 wel_loc=weights(7)*fact2
1247 wturn3=weights(8)*fact2
1248 wturn4=weights(9)*fact3
1249 wturn6=weights(10)*fact5
1250 wtor=weights(13)*fact
1251 wtor_d=weights(14)*fact2
1252 wsccor=weights(21)*fact
1253 if (scale_umb) wumb=t_bath/temp0
1254 c write (iout,*) "scale_umb",scale_umb
1255 c write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1259 C------------------------------------------------------------------------
1260 subroutine enerprint(energia)
1262 include 'DIMENSIONS'
1263 include 'COMMON.IOUNITS'
1264 include 'COMMON.FFIELD'
1265 include 'COMMON.SBRIDGE'
1266 include 'COMMON.QRESTR'
1267 double precision energia(0:n_ene)
1268 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1269 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1270 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1272 & eliptran,Eafmforce,Etube,
1273 & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1278 evdw2=energia(2)+energia(18)
1290 eello_turn3=energia(8)
1291 eello_turn4=energia(9)
1292 eello_turn6=energia(10)
1298 edihcnstr=energia(19)
1302 eliptran=energia(22)
1303 Eafmforce=energia(23)
1304 ethetacnstr=energia(24)
1307 ehomology_constr=energia(27)
1309 edfadis = energia(28)
1310 edfator = energia(29)
1311 edfanei = energia(30)
1312 edfabet = energia(31)
1314 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1315 & estr,wbond,ebe,wang,
1316 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1318 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1319 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1320 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1321 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1322 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1323 & edfabet,wdfa_beta,
1325 10 format (/'Virtual-chain energies:'//
1326 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1327 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1328 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1329 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1330 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1331 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1332 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1333 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1334 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1335 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1336 & ' (SS bridges & dist. cnstr.)'/
1337 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1338 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1339 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1340 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1341 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1342 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1343 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1344 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1345 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1346 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1347 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1348 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1349 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1350 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1351 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1352 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1353 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1354 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1355 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1356 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1357 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1358 & 'ETOT= ',1pE16.6,' (total)')
1361 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1362 & estr,wbond,ebe,wang,
1363 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1365 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1366 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1367 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1368 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1369 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1370 & edfabet,wdfa_beta,
1372 10 format (/'Virtual-chain energies:'//
1373 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1374 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1375 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1376 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1377 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1378 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1379 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1380 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1381 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1382 & ' (SS bridges & dist. restr.)'/
1383 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1384 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1385 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1386 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1387 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1388 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1389 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1390 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1391 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1392 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1393 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1394 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1395 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1396 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1397 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1398 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1399 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1400 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1401 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1402 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1403 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1404 & 'ETOT= ',1pE16.6,' (total)')
1408 C-----------------------------------------------------------------------
1409 subroutine elj(evdw)
1411 C This subroutine calculates the interaction energy of nonbonded side chains
1412 C assuming the LJ potential of interaction.
1415 double precision accur
1416 include 'DIMENSIONS'
1417 parameter (accur=1.0d-10)
1418 include 'COMMON.GEO'
1419 include 'COMMON.VAR'
1420 include 'COMMON.LOCAL'
1421 include 'COMMON.CHAIN'
1422 include 'COMMON.DERIV'
1423 include 'COMMON.INTERACT'
1424 include 'COMMON.TORSION'
1425 include 'COMMON.SBRIDGE'
1426 include 'COMMON.NAMES'
1427 include 'COMMON.IOUNITS'
1428 include 'COMMON.CONTACTS'
1429 double precision gg(3)
1430 double precision evdw,evdwij
1431 integer i,j,k,itypi,itypj,itypi1,num_conti,iint
1432 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1434 double precision fcont,fprimcont
1435 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1437 do i=iatsc_s,iatsc_e
1438 itypi=iabs(itype(i))
1439 if (itypi.eq.ntyp1) cycle
1440 itypi1=iabs(itype(i+1))
1447 C Calculate SC interaction energy.
1449 do iint=1,nint_gr(i)
1450 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1451 cd & 'iend=',iend(i,iint)
1452 do j=istart(i,iint),iend(i,iint)
1453 itypj=iabs(itype(j))
1454 if (itypj.eq.ntyp1) cycle
1458 C Change 12/1/95 to calculate four-body interactions
1459 rij=xj*xj+yj*yj+zj*zj
1461 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1462 eps0ij=eps(itypi,itypj)
1464 C have you changed here?
1468 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1469 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1470 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1471 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1472 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1473 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1476 C Calculate the components of the gradient in DC and X
1478 fac=-rrij*(e1+evdwij)
1483 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1484 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1485 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1486 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1490 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1494 C 12/1/95, revised on 5/20/97
1496 C Calculate the contact function. The ith column of the array JCONT will
1497 C contain the numbers of atoms that make contacts with the atom I (of numbers
1498 C greater than I). The arrays FACONT and GACONT will contain the values of
1499 C the contact function and its derivative.
1501 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1502 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1503 C Uncomment next line, if the correlation interactions are contact function only
1504 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1506 sigij=sigma(itypi,itypj)
1507 r0ij=rs0(itypi,itypj)
1509 C Check whether the SC's are not too far to make a contact.
1512 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1513 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1515 if (fcont.gt.0.0D0) then
1516 C If the SC-SC distance if close to sigma, apply spline.
1517 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1518 cAdam & fcont1,fprimcont1)
1519 cAdam fcont1=1.0d0-fcont1
1520 cAdam if (fcont1.gt.0.0d0) then
1521 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1522 cAdam fcont=fcont*fcont1
1524 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1525 cga eps0ij=1.0d0/dsqrt(eps0ij)
1527 cga gg(k)=gg(k)*eps0ij
1529 cga eps0ij=-evdwij*eps0ij
1530 C Uncomment for AL's type of SC correlation interactions.
1531 cadam eps0ij=-evdwij
1532 num_conti=num_conti+1
1533 jcont(num_conti,i)=j
1534 facont(num_conti,i)=fcont*eps0ij
1535 fprimcont=eps0ij*fprimcont/rij
1537 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1538 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1539 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1540 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1541 gacont(1,num_conti,i)=-fprimcont*xj
1542 gacont(2,num_conti,i)=-fprimcont*yj
1543 gacont(3,num_conti,i)=-fprimcont*zj
1544 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1545 cd write (iout,'(2i3,3f10.5)')
1546 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1552 num_cont(i)=num_conti
1556 gvdwc(j,i)=expon*gvdwc(j,i)
1557 gvdwx(j,i)=expon*gvdwx(j,i)
1560 C******************************************************************************
1564 C To save time, the factor of EXPON has been extracted from ALL components
1565 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1568 C******************************************************************************
1571 C-----------------------------------------------------------------------------
1572 subroutine eljk(evdw)
1574 C This subroutine calculates the interaction energy of nonbonded side chains
1575 C assuming the LJK potential of interaction.
1578 include 'DIMENSIONS'
1579 include 'COMMON.GEO'
1580 include 'COMMON.VAR'
1581 include 'COMMON.LOCAL'
1582 include 'COMMON.CHAIN'
1583 include 'COMMON.DERIV'
1584 include 'COMMON.INTERACT'
1585 include 'COMMON.IOUNITS'
1586 include 'COMMON.NAMES'
1587 double precision gg(3)
1588 double precision evdw,evdwij
1589 integer i,j,k,itypi,itypj,itypi1,iint
1590 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1591 & fac_augm,e_augm,r_inv_ij,r_shift_inv
1593 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1595 do i=iatsc_s,iatsc_e
1596 itypi=iabs(itype(i))
1597 if (itypi.eq.ntyp1) cycle
1598 itypi1=iabs(itype(i+1))
1603 C Calculate SC interaction energy.
1605 do iint=1,nint_gr(i)
1606 do j=istart(i,iint),iend(i,iint)
1607 itypj=iabs(itype(j))
1608 if (itypj.eq.ntyp1) cycle
1612 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1613 fac_augm=rrij**expon
1614 e_augm=augm(itypi,itypj)*fac_augm
1615 r_inv_ij=dsqrt(rrij)
1617 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1618 fac=r_shift_inv**expon
1619 C have you changed here?
1623 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1624 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1625 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1626 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1627 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1628 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1629 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1632 C Calculate the components of the gradient in DC and X
1634 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1639 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1640 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1641 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1642 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1646 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1654 gvdwc(j,i)=expon*gvdwc(j,i)
1655 gvdwx(j,i)=expon*gvdwx(j,i)
1660 C-----------------------------------------------------------------------------
1661 subroutine ebp(evdw)
1663 C This subroutine calculates the interaction energy of nonbonded side chains
1664 C assuming the Berne-Pechukas potential of interaction.
1667 include 'DIMENSIONS'
1668 include 'COMMON.GEO'
1669 include 'COMMON.VAR'
1670 include 'COMMON.LOCAL'
1671 include 'COMMON.CHAIN'
1672 include 'COMMON.DERIV'
1673 include 'COMMON.NAMES'
1674 include 'COMMON.INTERACT'
1675 include 'COMMON.IOUNITS'
1676 include 'COMMON.CALC'
1678 common /srutu/ icall
1679 double precision evdw
1680 integer itypi,itypj,itypi1,iint,ind
1681 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1682 c double precision rrsave(maxdim)
1685 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1687 c if (icall.eq.0) then
1693 do i=iatsc_s,iatsc_e
1694 itypi=iabs(itype(i))
1695 if (itypi.eq.ntyp1) cycle
1696 itypi1=iabs(itype(i+1))
1700 dxi=dc_norm(1,nres+i)
1701 dyi=dc_norm(2,nres+i)
1702 dzi=dc_norm(3,nres+i)
1703 c dsci_inv=dsc_inv(itypi)
1704 dsci_inv=vbld_inv(i+nres)
1706 C Calculate SC interaction energy.
1708 do iint=1,nint_gr(i)
1709 do j=istart(i,iint),iend(i,iint)
1711 itypj=iabs(itype(j))
1712 if (itypj.eq.ntyp1) cycle
1713 c dscj_inv=dsc_inv(itypj)
1714 dscj_inv=vbld_inv(j+nres)
1715 chi1=chi(itypi,itypj)
1716 chi2=chi(itypj,itypi)
1723 alf12=0.5D0*(alf1+alf2)
1724 C For diagnostics only!!!
1737 dxj=dc_norm(1,nres+j)
1738 dyj=dc_norm(2,nres+j)
1739 dzj=dc_norm(3,nres+j)
1740 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1741 cd if (icall.eq.0) then
1747 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1749 C Calculate whole angle-dependent part of epsilon and contributions
1750 C to its derivatives
1751 C have you changed here?
1752 fac=(rrij*sigsq)**expon2
1755 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1756 eps2der=evdwij*eps3rt
1757 eps3der=evdwij*eps2rt
1758 evdwij=evdwij*eps2rt*eps3rt
1761 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1763 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1764 cd & restyp(itypi),i,restyp(itypj),j,
1765 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1766 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1767 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1770 C Calculate gradient components.
1771 e1=e1*eps1*eps2rt**2*eps3rt**2
1772 fac=-expon*(e1+evdwij)
1775 C Calculate radial part of the gradient
1779 C Calculate the angular part of the gradient and sum add the contributions
1780 C to the appropriate components of the Cartesian gradient.
1788 C-----------------------------------------------------------------------------
1789 subroutine egb(evdw)
1791 C This subroutine calculates the interaction energy of nonbonded side chains
1792 C assuming the Gay-Berne potential of interaction.
1795 include 'DIMENSIONS'
1796 include 'COMMON.GEO'
1797 include 'COMMON.VAR'
1798 include 'COMMON.LOCAL'
1799 include 'COMMON.CHAIN'
1800 include 'COMMON.DERIV'
1801 include 'COMMON.NAMES'
1802 include 'COMMON.INTERACT'
1803 include 'COMMON.IOUNITS'
1804 include 'COMMON.CALC'
1805 include 'COMMON.CONTROL'
1806 include 'COMMON.SPLITELE'
1807 include 'COMMON.SBRIDGE'
1809 integer xshift,yshift,zshift,subchap
1810 double precision evdw
1811 integer itypi,itypj,itypi1,iint,ind
1812 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1813 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1814 & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
1815 & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
1816 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1818 ccccc energy_dec=.false.
1819 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1822 c if (icall.eq.0) lprn=.false.
1824 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1825 C we have the original box)
1829 do i=iatsc_s,iatsc_e
1830 itypi=iabs(itype(i))
1831 if (itypi.eq.ntyp1) cycle
1832 itypi1=iabs(itype(i+1))
1836 C Return atom into box, boxxsize is size of box in x dimension
1838 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1839 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1840 C Condition for being inside the proper box
1841 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1842 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
1846 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1847 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1848 C Condition for being inside the proper box
1849 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1850 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
1854 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1855 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1856 C Condition for being inside the proper box
1857 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1858 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
1862 if (xi.lt.0) xi=xi+boxxsize
1864 if (yi.lt.0) yi=yi+boxysize
1866 if (zi.lt.0) zi=zi+boxzsize
1867 C define scaling factor for lipids
1869 C if (positi.le.0) positi=positi+boxzsize
1871 C first for peptide groups
1872 c for each residue check if it is in lipid or lipid water border area
1873 if ((zi.gt.bordlipbot)
1874 &.and.(zi.lt.bordliptop)) then
1875 C the energy transfer exist
1876 if (zi.lt.buflipbot) then
1877 C what fraction I am in
1879 & ((zi-bordlipbot)/lipbufthick)
1880 C lipbufthick is thickenes of lipid buffore
1881 sslipi=sscalelip(fracinbuf)
1882 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1883 elseif (zi.gt.bufliptop) then
1884 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1885 sslipi=sscalelip(fracinbuf)
1886 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1896 C xi=xi+xshift*boxxsize
1897 C yi=yi+yshift*boxysize
1898 C zi=zi+zshift*boxzsize
1900 dxi=dc_norm(1,nres+i)
1901 dyi=dc_norm(2,nres+i)
1902 dzi=dc_norm(3,nres+i)
1903 c dsci_inv=dsc_inv(itypi)
1904 dsci_inv=vbld_inv(i+nres)
1905 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1906 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1908 C Calculate SC interaction energy.
1910 do iint=1,nint_gr(i)
1911 do j=istart(i,iint),iend(i,iint)
1912 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1914 c write(iout,*) "PRZED ZWYKLE", evdwij
1915 call dyn_ssbond_ene(i,j,evdwij)
1916 c write(iout,*) "PO ZWYKLE", evdwij
1919 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1920 & 'evdw',i,j,evdwij,' ss'
1921 C triple bond artifac removal
1922 do k=j+1,iend(i,iint)
1923 C search over all next residues
1924 if (dyn_ss_mask(k)) then
1925 C check if they are cysteins
1926 C write(iout,*) 'k=',k
1928 c write(iout,*) "PRZED TRI", evdwij
1929 evdwij_przed_tri=evdwij
1930 call triple_ssbond_ene(i,j,k,evdwij)
1931 c if(evdwij_przed_tri.ne.evdwij) then
1932 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1935 c write(iout,*) "PO TRI", evdwij
1936 C call the energy function that removes the artifical triple disulfide
1937 C bond the soubroutine is located in ssMD.F
1939 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1940 & 'evdw',i,j,evdwij,'tss'
1941 endif!dyn_ss_mask(k)
1945 itypj=iabs(itype(j))
1946 if (itypj.eq.ntyp1) cycle
1947 c dscj_inv=dsc_inv(itypj)
1948 dscj_inv=vbld_inv(j+nres)
1949 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1950 c & 1.0d0/vbld(j+nres)
1951 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1952 sig0ij=sigma(itypi,itypj)
1953 chi1=chi(itypi,itypj)
1954 chi2=chi(itypj,itypi)
1961 alf12=0.5D0*(alf1+alf2)
1962 C For diagnostics only!!!
1975 C Return atom J into box the original box
1977 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1978 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1979 C Condition for being inside the proper box
1980 c if ((xj.gt.((0.5d0)*boxxsize)).or.
1981 c & (xj.lt.((-0.5d0)*boxxsize))) then
1985 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1986 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1987 C Condition for being inside the proper box
1988 c if ((yj.gt.((0.5d0)*boxysize)).or.
1989 c & (yj.lt.((-0.5d0)*boxysize))) then
1993 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1994 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1995 C Condition for being inside the proper box
1996 c if ((zj.gt.((0.5d0)*boxzsize)).or.
1997 c & (zj.lt.((-0.5d0)*boxzsize))) then
2001 if (xj.lt.0) xj=xj+boxxsize
2003 if (yj.lt.0) yj=yj+boxysize
2005 if (zj.lt.0) zj=zj+boxzsize
2006 if ((zj.gt.bordlipbot)
2007 &.and.(zj.lt.bordliptop)) then
2008 C the energy transfer exist
2009 if (zj.lt.buflipbot) then
2010 C what fraction I am in
2012 & ((zj-bordlipbot)/lipbufthick)
2013 C lipbufthick is thickenes of lipid buffore
2014 sslipj=sscalelip(fracinbuf)
2015 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2016 elseif (zj.gt.bufliptop) then
2017 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2018 sslipj=sscalelip(fracinbuf)
2019 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2028 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2029 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2030 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2031 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2032 C write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2033 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2034 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2035 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2036 C print *,sslipi,sslipj,bordlipbot,zi,zj
2037 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2045 xj=xj_safe+xshift*boxxsize
2046 yj=yj_safe+yshift*boxysize
2047 zj=zj_safe+zshift*boxzsize
2048 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2049 if(dist_temp.lt.dist_init) then
2059 if (subchap.eq.1) then
2068 dxj=dc_norm(1,nres+j)
2069 dyj=dc_norm(2,nres+j)
2070 dzj=dc_norm(3,nres+j)
2074 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2075 c write (iout,*) "j",j," dc_norm",
2076 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2077 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2079 sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
2080 sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
2082 c write (iout,'(a7,4f8.3)')
2083 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2084 if (sss.gt.0.0d0) then
2085 C Calculate angle-dependent terms of energy and contributions to their
2089 sig=sig0ij*dsqrt(sigsq)
2090 rij_shift=1.0D0/rij-sig+sig0ij
2091 c for diagnostics; uncomment
2092 c rij_shift=1.2*sig0ij
2093 C I hate to put IF's in the loops, but here don't have another choice!!!!
2094 if (rij_shift.le.0.0D0) then
2096 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2097 cd & restyp(itypi),i,restyp(itypj),j,
2098 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2102 c---------------------------------------------------------------
2103 rij_shift=1.0D0/rij_shift
2104 fac=rij_shift**expon
2105 C here to start with
2110 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2111 eps2der=evdwij*eps3rt
2112 eps3der=evdwij*eps2rt
2113 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2114 C &((sslipi+sslipj)/2.0d0+
2115 C &(2.0d0-sslipi-sslipj)/2.0d0)
2116 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2117 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2118 evdwij=evdwij*eps2rt*eps3rt
2119 evdw=evdw+evdwij*sss
2121 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2123 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2124 & restyp(itypi),i,restyp(itypj),j,
2125 & epsi,sigm,chi1,chi2,chip1,chip2,
2126 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2127 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2131 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2134 C Calculate gradient components.
2135 e1=e1*eps1*eps2rt**2*eps3rt**2
2136 fac=-expon*(e1+evdwij)*rij_shift
2139 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
2140 c & evdwij,fac,sigma(itypi,itypj),expon
2141 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2143 C Calculate the radial part of the gradient
2144 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2145 &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2146 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2147 &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2148 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2149 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2155 C Calculate angular part of the gradient.
2165 c write (iout,*) "Number of loop steps in EGB:",ind
2166 cccc energy_dec=.false.
2169 C-----------------------------------------------------------------------------
2170 subroutine egbv(evdw)
2172 C This subroutine calculates the interaction energy of nonbonded side chains
2173 C assuming the Gay-Berne-Vorobjev potential of interaction.
2176 include 'DIMENSIONS'
2177 include 'COMMON.GEO'
2178 include 'COMMON.VAR'
2179 include 'COMMON.LOCAL'
2180 include 'COMMON.CHAIN'
2181 include 'COMMON.DERIV'
2182 include 'COMMON.NAMES'
2183 include 'COMMON.INTERACT'
2184 include 'COMMON.IOUNITS'
2185 include 'COMMON.CALC'
2186 integer xshift,yshift,zshift,subchap
2188 common /srutu/ icall
2190 double precision evdw
2191 integer itypi,itypj,itypi1,iint,ind
2192 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2193 & xi,yi,zi,fac_augm,e_augm
2194 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2195 & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
2196 & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
2197 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2199 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2202 c if (icall.eq.0) lprn=.true.
2204 do i=iatsc_s,iatsc_e
2205 itypi=iabs(itype(i))
2206 if (itypi.eq.ntyp1) cycle
2207 itypi1=iabs(itype(i+1))
2212 if (xi.lt.0) xi=xi+boxxsize
2214 if (yi.lt.0) yi=yi+boxysize
2216 if (zi.lt.0) zi=zi+boxzsize
2217 C define scaling factor for lipids
2219 C if (positi.le.0) positi=positi+boxzsize
2221 C first for peptide groups
2222 c for each residue check if it is in lipid or lipid water border area
2223 if ((zi.gt.bordlipbot)
2224 &.and.(zi.lt.bordliptop)) then
2225 C the energy transfer exist
2226 if (zi.lt.buflipbot) then
2227 C what fraction I am in
2229 & ((zi-bordlipbot)/lipbufthick)
2230 C lipbufthick is thickenes of lipid buffore
2231 sslipi=sscalelip(fracinbuf)
2232 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2233 elseif (zi.gt.bufliptop) then
2234 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2235 sslipi=sscalelip(fracinbuf)
2236 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2246 dxi=dc_norm(1,nres+i)
2247 dyi=dc_norm(2,nres+i)
2248 dzi=dc_norm(3,nres+i)
2249 c dsci_inv=dsc_inv(itypi)
2250 dsci_inv=vbld_inv(i+nres)
2252 C Calculate SC interaction energy.
2254 do iint=1,nint_gr(i)
2255 do j=istart(i,iint),iend(i,iint)
2257 itypj=iabs(itype(j))
2258 if (itypj.eq.ntyp1) cycle
2259 c dscj_inv=dsc_inv(itypj)
2260 dscj_inv=vbld_inv(j+nres)
2261 sig0ij=sigma(itypi,itypj)
2262 r0ij=r0(itypi,itypj)
2263 chi1=chi(itypi,itypj)
2264 chi2=chi(itypj,itypi)
2271 alf12=0.5D0*(alf1+alf2)
2272 C For diagnostics only!!!
2286 if (xj.lt.0) xj=xj+boxxsize
2288 if (yj.lt.0) yj=yj+boxysize
2290 if (zj.lt.0) zj=zj+boxzsize
2291 if ((zj.gt.bordlipbot)
2292 &.and.(zj.lt.bordliptop)) then
2293 C the energy transfer exist
2294 if (zj.lt.buflipbot) then
2295 C what fraction I am in
2297 & ((zj-bordlipbot)/lipbufthick)
2298 C lipbufthick is thickenes of lipid buffore
2299 sslipj=sscalelip(fracinbuf)
2300 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2301 elseif (zj.gt.bufliptop) then
2302 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2303 sslipj=sscalelip(fracinbuf)
2304 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2313 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2314 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2315 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2316 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2317 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2318 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2319 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2320 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2328 xj=xj_safe+xshift*boxxsize
2329 yj=yj_safe+yshift*boxysize
2330 zj=zj_safe+zshift*boxzsize
2331 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2332 if(dist_temp.lt.dist_init) then
2342 if (subchap.eq.1) then
2351 dxj=dc_norm(1,nres+j)
2352 dyj=dc_norm(2,nres+j)
2353 dzj=dc_norm(3,nres+j)
2354 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2356 C Calculate angle-dependent terms of energy and contributions to their
2360 sig=sig0ij*dsqrt(sigsq)
2361 rij_shift=1.0D0/rij-sig+r0ij
2362 C I hate to put IF's in the loops, but here don't have another choice!!!!
2363 if (rij_shift.le.0.0D0) then
2368 c---------------------------------------------------------------
2369 rij_shift=1.0D0/rij_shift
2370 fac=rij_shift**expon
2373 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2374 eps2der=evdwij*eps3rt
2375 eps3der=evdwij*eps2rt
2376 fac_augm=rrij**expon
2377 e_augm=augm(itypi,itypj)*fac_augm
2378 evdwij=evdwij*eps2rt*eps3rt
2379 evdw=evdw+evdwij+e_augm
2381 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2383 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2384 & restyp(itypi),i,restyp(itypj),j,
2385 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2386 & chi1,chi2,chip1,chip2,
2387 & eps1,eps2rt**2,eps3rt**2,
2388 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2391 C Calculate gradient components.
2392 e1=e1*eps1*eps2rt**2*eps3rt**2
2393 fac=-expon*(e1+evdwij)*rij_shift
2395 fac=rij*fac-2*expon*rrij*e_augm
2396 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2397 C Calculate the radial part of the gradient
2401 C Calculate angular part of the gradient.
2407 C-----------------------------------------------------------------------------
2408 subroutine sc_angular
2409 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2410 C om12. Called by ebp, egb, and egbv.
2412 include 'COMMON.CALC'
2413 include 'COMMON.IOUNITS'
2417 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2418 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2419 om12=dxi*dxj+dyi*dyj+dzi*dzj
2421 C Calculate eps1(om12) and its derivative in om12
2422 faceps1=1.0D0-om12*chiom12
2423 faceps1_inv=1.0D0/faceps1
2424 eps1=dsqrt(faceps1_inv)
2425 C Following variable is eps1*deps1/dom12
2426 eps1_om12=faceps1_inv*chiom12
2431 c write (iout,*) "om12",om12," eps1",eps1
2432 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2437 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2438 sigsq=1.0D0-facsig*faceps1_inv
2439 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2440 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2441 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2447 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2448 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2450 C Calculate eps2 and its derivatives in om1, om2, and om12.
2453 chipom12=chip12*om12
2454 facp=1.0D0-om12*chipom12
2456 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2457 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2458 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2459 C Following variable is the square root of eps2
2460 eps2rt=1.0D0-facp1*facp_inv
2461 C Following three variables are the derivatives of the square root of eps
2462 C in om1, om2, and om12.
2463 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2464 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2465 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2466 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2467 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2468 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2469 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2470 c & " eps2rt_om12",eps2rt_om12
2471 C Calculate whole angle-dependent part of epsilon and contributions
2472 C to its derivatives
2475 C----------------------------------------------------------------------------
2477 implicit real*8 (a-h,o-z)
2478 include 'DIMENSIONS'
2479 include 'COMMON.CHAIN'
2480 include 'COMMON.DERIV'
2481 include 'COMMON.CALC'
2482 include 'COMMON.IOUNITS'
2483 double precision dcosom1(3),dcosom2(3)
2484 cc print *,'sss=',sss
2485 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2486 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2487 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2488 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2492 c eom12=evdwij*eps1_om12
2494 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2495 c & " sigder",sigder
2496 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2497 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2499 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2500 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2503 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2505 c write (iout,*) "gg",(gg(k),k=1,3)
2507 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2508 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2509 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2510 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2511 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2512 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2513 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2514 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2515 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2516 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2519 C Calculate the components of the gradient in DC and X
2523 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2527 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2528 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2532 C-----------------------------------------------------------------------
2533 subroutine e_softsphere(evdw)
2535 C This subroutine calculates the interaction energy of nonbonded side chains
2536 C assuming the LJ potential of interaction.
2538 implicit real*8 (a-h,o-z)
2539 include 'DIMENSIONS'
2540 parameter (accur=1.0d-10)
2541 include 'COMMON.GEO'
2542 include 'COMMON.VAR'
2543 include 'COMMON.LOCAL'
2544 include 'COMMON.CHAIN'
2545 include 'COMMON.DERIV'
2546 include 'COMMON.INTERACT'
2547 include 'COMMON.TORSION'
2548 include 'COMMON.SBRIDGE'
2549 include 'COMMON.NAMES'
2550 include 'COMMON.IOUNITS'
2551 include 'COMMON.CONTACTS'
2553 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2555 do i=iatsc_s,iatsc_e
2556 itypi=iabs(itype(i))
2557 if (itypi.eq.ntyp1) cycle
2558 itypi1=iabs(itype(i+1))
2563 C Calculate SC interaction energy.
2565 do iint=1,nint_gr(i)
2566 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2567 cd & 'iend=',iend(i,iint)
2568 do j=istart(i,iint),iend(i,iint)
2569 itypj=iabs(itype(j))
2570 if (itypj.eq.ntyp1) cycle
2574 rij=xj*xj+yj*yj+zj*zj
2575 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2576 r0ij=r0(itypi,itypj)
2578 c print *,i,j,r0ij,dsqrt(rij)
2579 if (rij.lt.r0ijsq) then
2580 evdwij=0.25d0*(rij-r0ijsq)**2
2588 C Calculate the components of the gradient in DC and X
2594 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2595 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2596 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2597 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2601 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2609 C--------------------------------------------------------------------------
2610 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2613 C Soft-sphere potential of p-p interaction
2615 implicit real*8 (a-h,o-z)
2616 include 'DIMENSIONS'
2617 include 'COMMON.CONTROL'
2618 include 'COMMON.IOUNITS'
2619 include 'COMMON.GEO'
2620 include 'COMMON.VAR'
2621 include 'COMMON.LOCAL'
2622 include 'COMMON.CHAIN'
2623 include 'COMMON.DERIV'
2624 include 'COMMON.INTERACT'
2625 include 'COMMON.CONTACTS'
2626 include 'COMMON.TORSION'
2627 include 'COMMON.VECTORS'
2628 include 'COMMON.FFIELD'
2630 integer xshift,yshift,zshift
2631 C write(iout,*) 'In EELEC_soft_sphere'
2638 do i=iatel_s,iatel_e
2639 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2643 xmedi=c(1,i)+0.5d0*dxi
2644 ymedi=c(2,i)+0.5d0*dyi
2645 zmedi=c(3,i)+0.5d0*dzi
2646 xmedi=mod(xmedi,boxxsize)
2647 if (xmedi.lt.0) xmedi=xmedi+boxxsize
2648 ymedi=mod(ymedi,boxysize)
2649 if (ymedi.lt.0) ymedi=ymedi+boxysize
2650 zmedi=mod(zmedi,boxzsize)
2651 if (zmedi.lt.0) zmedi=zmedi+boxzsize
2653 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2654 do j=ielstart(i),ielend(i)
2655 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2659 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2660 r0ij=rpp(iteli,itelj)
2669 if (xj.lt.0) xj=xj+boxxsize
2671 if (yj.lt.0) yj=yj+boxysize
2673 if (zj.lt.0) zj=zj+boxzsize
2674 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2682 xj=xj_safe+xshift*boxxsize
2683 yj=yj_safe+yshift*boxysize
2684 zj=zj_safe+zshift*boxzsize
2685 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2686 if(dist_temp.lt.dist_init) then
2696 if (isubchap.eq.1) then
2705 rij=xj*xj+yj*yj+zj*zj
2706 sss=sscale(sqrt(rij))
2707 sssgrad=sscagrad(sqrt(rij))
2708 if (rij.lt.r0ijsq) then
2709 evdw1ij=0.25d0*(rij-r0ijsq)**2
2715 evdw1=evdw1+evdw1ij*sss
2717 C Calculate contributions to the Cartesian gradient.
2719 ggg(1)=fac*xj*sssgrad
2720 ggg(2)=fac*yj*sssgrad
2721 ggg(3)=fac*zj*sssgrad
2723 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2724 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2727 * Loop over residues i+1 thru j-1.
2731 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2736 cgrad do i=nnt,nct-1
2738 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2740 cgrad do j=i+1,nct-1
2742 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2748 c------------------------------------------------------------------------------
2749 subroutine vec_and_deriv
2750 implicit real*8 (a-h,o-z)
2751 include 'DIMENSIONS'
2755 include 'COMMON.IOUNITS'
2756 include 'COMMON.GEO'
2757 include 'COMMON.VAR'
2758 include 'COMMON.LOCAL'
2759 include 'COMMON.CHAIN'
2760 include 'COMMON.VECTORS'
2761 include 'COMMON.SETUP'
2762 include 'COMMON.TIME1'
2763 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2764 C Compute the local reference systems. For reference system (i), the
2765 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2766 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2768 do i=ivec_start,ivec_end
2772 if (i.eq.nres-1) then
2773 C Case of the last full residue
2774 C Compute the Z-axis
2775 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2776 costh=dcos(pi-theta(nres))
2777 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2781 C Compute the derivatives of uz
2783 uzder(2,1,1)=-dc_norm(3,i-1)
2784 uzder(3,1,1)= dc_norm(2,i-1)
2785 uzder(1,2,1)= dc_norm(3,i-1)
2787 uzder(3,2,1)=-dc_norm(1,i-1)
2788 uzder(1,3,1)=-dc_norm(2,i-1)
2789 uzder(2,3,1)= dc_norm(1,i-1)
2792 uzder(2,1,2)= dc_norm(3,i)
2793 uzder(3,1,2)=-dc_norm(2,i)
2794 uzder(1,2,2)=-dc_norm(3,i)
2796 uzder(3,2,2)= dc_norm(1,i)
2797 uzder(1,3,2)= dc_norm(2,i)
2798 uzder(2,3,2)=-dc_norm(1,i)
2800 C Compute the Y-axis
2803 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2805 C Compute the derivatives of uy
2808 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2809 & -dc_norm(k,i)*dc_norm(j,i-1)
2810 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2812 uyder(j,j,1)=uyder(j,j,1)-costh
2813 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2818 uygrad(l,k,j,i)=uyder(l,k,j)
2819 uzgrad(l,k,j,i)=uzder(l,k,j)
2823 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2824 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2825 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2826 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2829 C Compute the Z-axis
2830 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2831 costh=dcos(pi-theta(i+2))
2832 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2836 C Compute the derivatives of uz
2838 uzder(2,1,1)=-dc_norm(3,i+1)
2839 uzder(3,1,1)= dc_norm(2,i+1)
2840 uzder(1,2,1)= dc_norm(3,i+1)
2842 uzder(3,2,1)=-dc_norm(1,i+1)
2843 uzder(1,3,1)=-dc_norm(2,i+1)
2844 uzder(2,3,1)= dc_norm(1,i+1)
2847 uzder(2,1,2)= dc_norm(3,i)
2848 uzder(3,1,2)=-dc_norm(2,i)
2849 uzder(1,2,2)=-dc_norm(3,i)
2851 uzder(3,2,2)= dc_norm(1,i)
2852 uzder(1,3,2)= dc_norm(2,i)
2853 uzder(2,3,2)=-dc_norm(1,i)
2855 C Compute the Y-axis
2858 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2860 C Compute the derivatives of uy
2863 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2864 & -dc_norm(k,i)*dc_norm(j,i+1)
2865 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2867 uyder(j,j,1)=uyder(j,j,1)-costh
2868 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2873 uygrad(l,k,j,i)=uyder(l,k,j)
2874 uzgrad(l,k,j,i)=uzder(l,k,j)
2878 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2879 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2880 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2881 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2885 vbld_inv_temp(1)=vbld_inv(i+1)
2886 if (i.lt.nres-1) then
2887 vbld_inv_temp(2)=vbld_inv(i+2)
2889 vbld_inv_temp(2)=vbld_inv(i)
2894 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2895 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2900 #if defined(PARVEC) && defined(MPI)
2901 if (nfgtasks1.gt.1) then
2903 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2904 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2905 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2906 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2907 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2909 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2910 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2912 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2913 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2914 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2915 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2916 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2917 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2918 time_gather=time_gather+MPI_Wtime()-time00
2922 if (fg_rank.eq.0) then
2923 write (iout,*) "Arrays UY and UZ"
2925 write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2932 C--------------------------------------------------------------------------
2933 subroutine set_matrices
2934 implicit real*8 (a-h,o-z)
2935 include 'DIMENSIONS'
2938 include "COMMON.SETUP"
2940 integer status(MPI_STATUS_SIZE)
2942 include 'COMMON.IOUNITS'
2943 include 'COMMON.GEO'
2944 include 'COMMON.VAR'
2945 include 'COMMON.LOCAL'
2946 include 'COMMON.CHAIN'
2947 include 'COMMON.DERIV'
2948 include 'COMMON.INTERACT'
2949 include 'COMMON.CONTACTS'
2950 include 'COMMON.TORSION'
2951 include 'COMMON.VECTORS'
2952 include 'COMMON.FFIELD'
2953 double precision auxvec(2),auxmat(2,2)
2955 C Compute the virtual-bond-torsional-angle dependent quantities needed
2956 C to calculate the el-loc multibody terms of various order.
2958 c write(iout,*) 'nphi=',nphi,nres
2959 c write(iout,*) "itype2loc",itype2loc
2961 do i=ivec_start+2,ivec_end+2
2965 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2966 iti = itype2loc(itype(i-2))
2970 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2971 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2972 iti1 = itype2loc(itype(i-1))
2976 write(iout,*),"i",i,i-2," iti",iti," iti1",iti1
2978 cost1=dcos(theta(i-1))
2979 sint1=dsin(theta(i-1))
2981 sint1cub=sint1sq*sint1
2982 sint1cost1=2*sint1*cost1
2983 c write (iout,*) "bnew1",i,iti
2984 c write (iout,*) (bnew1(k,1,iti),k=1,3)
2985 c write (iout,*) (bnew1(k,2,iti),k=1,3)
2986 c write (iout,*) "bnew2",i,iti
2987 c write (iout,*) (bnew2(k,1,iti),k=1,3)
2988 c write (iout,*) (bnew2(k,2,iti),k=1,3)
2990 b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2992 gtb1(k,i-2)=cost1*b1k-sint1sq*
2993 & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2994 b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2996 gtb2(k,i-2)=cost1*b2k-sint1sq*
2997 & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3000 aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3001 cc(1,k,i-2)=sint1sq*aux
3002 gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3003 & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3004 aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3005 dd(1,k,i-2)=sint1sq*aux
3006 gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3007 & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3009 cc(2,1,i-2)=cc(1,2,i-2)
3010 cc(2,2,i-2)=-cc(1,1,i-2)
3011 gtcc(2,1,i-2)=gtcc(1,2,i-2)
3012 gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3013 dd(2,1,i-2)=dd(1,2,i-2)
3014 dd(2,2,i-2)=-dd(1,1,i-2)
3015 gtdd(2,1,i-2)=gtdd(1,2,i-2)
3016 gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3019 aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3020 EE(l,k,i-2)=sint1sq*aux
3021 gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3024 EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3025 EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3026 EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3027 EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3028 gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3029 gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3030 gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3031 c b1tilde(1,i-2)=b1(1,i-2)
3032 c b1tilde(2,i-2)=-b1(2,i-2)
3033 c b2tilde(1,i-2)=b2(1,i-2)
3034 c b2tilde(2,i-2)=-b2(2,i-2)
3036 write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3037 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3038 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3039 write (iout,*) 'theta=', theta(i-1)
3042 if (i.gt. nnt+2 .and. i.lt.nct+2) then
3043 iti = itype2loc(itype(i-2))
3047 c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3048 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3049 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3050 iti1 = itype2loc(itype(i-1))
3060 CC(k,l,i-2)=ccold(k,l,iti)
3061 DD(k,l,i-2)=ddold(k,l,iti)
3062 EE(k,l,i-2)=eeold(k,l,iti)
3067 b1tilde(1,i-2)= b1(1,i-2)
3068 b1tilde(2,i-2)=-b1(2,i-2)
3069 b2tilde(1,i-2)= b2(1,i-2)
3070 b2tilde(2,i-2)=-b2(2,i-2)
3072 Ctilde(1,1,i-2)= CC(1,1,i-2)
3073 Ctilde(1,2,i-2)= CC(1,2,i-2)
3074 Ctilde(2,1,i-2)=-CC(2,1,i-2)
3075 Ctilde(2,2,i-2)=-CC(2,2,i-2)
3077 Dtilde(1,1,i-2)= DD(1,1,i-2)
3078 Dtilde(1,2,i-2)= DD(1,2,i-2)
3079 Dtilde(2,1,i-2)=-DD(2,1,i-2)
3080 Dtilde(2,2,i-2)=-DD(2,2,i-2)
3082 write(iout,*) "i",i," iti",iti
3083 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3084 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3088 do i=ivec_start+2,ivec_end+2
3092 if (i .lt. nres+1) then
3129 if (i .gt. 3 .and. i .lt. nres+1) then
3130 obrot_der(1,i-2)=-sin1
3131 obrot_der(2,i-2)= cos1
3132 Ugder(1,1,i-2)= sin1
3133 Ugder(1,2,i-2)=-cos1
3134 Ugder(2,1,i-2)=-cos1
3135 Ugder(2,2,i-2)=-sin1
3138 obrot2_der(1,i-2)=-dwasin2
3139 obrot2_der(2,i-2)= dwacos2
3140 Ug2der(1,1,i-2)= dwasin2
3141 Ug2der(1,2,i-2)=-dwacos2
3142 Ug2der(2,1,i-2)=-dwacos2
3143 Ug2der(2,2,i-2)=-dwasin2
3145 obrot_der(1,i-2)=0.0d0
3146 obrot_der(2,i-2)=0.0d0
3147 Ugder(1,1,i-2)=0.0d0
3148 Ugder(1,2,i-2)=0.0d0
3149 Ugder(2,1,i-2)=0.0d0
3150 Ugder(2,2,i-2)=0.0d0
3151 obrot2_der(1,i-2)=0.0d0
3152 obrot2_der(2,i-2)=0.0d0
3153 Ug2der(1,1,i-2)=0.0d0
3154 Ug2der(1,2,i-2)=0.0d0
3155 Ug2der(2,1,i-2)=0.0d0
3156 Ug2der(2,2,i-2)=0.0d0
3158 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3159 if (i.gt. nnt+2 .and. i.lt.nct+2) then
3160 iti = itype2loc(itype(i-2))
3164 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3165 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3166 iti1 = itype2loc(itype(i-1))
3170 cd write (iout,*) '*******i',i,' iti1',iti
3171 cd write (iout,*) 'b1',b1(:,iti)
3172 cd write (iout,*) 'b2',b2(:,iti)
3173 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3174 c if (i .gt. iatel_s+2) then
3175 if (i .gt. nnt+2) then
3176 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3178 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3179 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3181 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3182 c & EE(1,2,iti),EE(2,2,i)
3183 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3184 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3185 c write(iout,*) "Macierz EUG",
3186 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3188 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3190 call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3191 call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3192 call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3193 call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3194 call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3205 DtUg2(l,k,i-2)=0.0d0
3209 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3210 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3212 muder(k,i-2)=Ub2der(k,i-2)
3214 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3215 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3216 if (itype(i-1).le.ntyp) then
3217 iti1 = itype2loc(itype(i-1))
3225 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3226 c mu(k,i-2)=b1(k,i-1)
3227 c mu(k,i-2)=Ub2(k,i-2)
3231 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3232 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3233 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3234 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3235 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3236 & ((ee(l,k,i-2),l=1,2),k=1,2)
3239 cd write (iout,*) 'mu1',mu1(:,i-2)
3240 cd write (iout,*) 'mu2',mu2(:,i-2)
3241 cd write (iout,*) 'mu',i-2,mu(:,i-2)
3242 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3244 call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3245 call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3246 call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3247 call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3248 call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3249 C Vectors and matrices dependent on a single virtual-bond dihedral.
3250 call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3251 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3252 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3253 call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3254 call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3255 call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3256 call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3257 call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3258 call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3261 C Matrices dependent on two consecutive virtual-bond dihedrals.
3262 C The order of matrices is from left to right.
3263 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3265 c do i=max0(ivec_start,2),ivec_end
3267 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3268 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3269 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3270 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3271 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3272 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3273 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3274 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3277 #if defined(MPI) && defined(PARMAT)
3279 c if (fg_rank.eq.0) then
3280 write (iout,*) "Arrays UG and UGDER before GATHER"
3282 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3283 & ((ug(l,k,i),l=1,2),k=1,2),
3284 & ((ugder(l,k,i),l=1,2),k=1,2)
3286 write (iout,*) "Arrays UG2 and UG2DER"
3288 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3289 & ((ug2(l,k,i),l=1,2),k=1,2),
3290 & ((ug2der(l,k,i),l=1,2),k=1,2)
3292 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3294 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3295 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3296 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3298 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3300 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3301 & costab(i),sintab(i),costab2(i),sintab2(i)
3303 write (iout,*) "Array MUDER"
3305 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3309 if (nfgtasks.gt.1) then
3311 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3312 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3313 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3315 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3316 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3318 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3319 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3321 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3322 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3324 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3325 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3327 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3328 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3330 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3331 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3333 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3334 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3335 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3336 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3337 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3338 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3339 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3340 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3341 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3342 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3343 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3344 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3345 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3347 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3348 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3350 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3351 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3353 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3354 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3356 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3357 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3359 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3360 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3362 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3363 & ivec_count(fg_rank1),
3364 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3366 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3367 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3369 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3370 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3372 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3373 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3375 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3376 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3378 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3379 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3381 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3382 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3384 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3385 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3387 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3388 & ivec_count(fg_rank1),
3389 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3391 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3392 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3394 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3395 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3397 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3398 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3400 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3401 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3403 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3404 & ivec_count(fg_rank1),
3405 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3407 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3408 & ivec_count(fg_rank1),
3409 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3411 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3412 & ivec_count(fg_rank1),
3413 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3414 & MPI_MAT2,FG_COMM1,IERR)
3415 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3416 & ivec_count(fg_rank1),
3417 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3418 & MPI_MAT2,FG_COMM1,IERR)
3421 c Passes matrix info through the ring
3424 if (irecv.lt.0) irecv=nfgtasks1-1
3427 if (inext.ge.nfgtasks1) inext=0
3429 c write (iout,*) "isend",isend," irecv",irecv
3431 lensend=lentyp(isend)
3432 lenrecv=lentyp(irecv)
3433 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3434 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3435 c & MPI_ROTAT1(lensend),inext,2200+isend,
3436 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3437 c & iprev,2200+irecv,FG_COMM,status,IERR)
3438 c write (iout,*) "Gather ROTAT1"
3440 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3441 c & MPI_ROTAT2(lensend),inext,3300+isend,
3442 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3443 c & iprev,3300+irecv,FG_COMM,status,IERR)
3444 c write (iout,*) "Gather ROTAT2"
3446 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3447 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3448 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3449 & iprev,4400+irecv,FG_COMM,status,IERR)
3450 c write (iout,*) "Gather ROTAT_OLD"
3452 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3453 & MPI_PRECOMP11(lensend),inext,5500+isend,
3454 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3455 & iprev,5500+irecv,FG_COMM,status,IERR)
3456 c write (iout,*) "Gather PRECOMP11"
3458 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3459 & MPI_PRECOMP12(lensend),inext,6600+isend,
3460 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3461 & iprev,6600+irecv,FG_COMM,status,IERR)
3462 c write (iout,*) "Gather PRECOMP12"
3464 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3466 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3467 & MPI_ROTAT2(lensend),inext,7700+isend,
3468 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3469 & iprev,7700+irecv,FG_COMM,status,IERR)
3470 c write (iout,*) "Gather PRECOMP21"
3472 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3473 & MPI_PRECOMP22(lensend),inext,8800+isend,
3474 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3475 & iprev,8800+irecv,FG_COMM,status,IERR)
3476 c write (iout,*) "Gather PRECOMP22"
3478 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3479 & MPI_PRECOMP23(lensend),inext,9900+isend,
3480 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3481 & MPI_PRECOMP23(lenrecv),
3482 & iprev,9900+irecv,FG_COMM,status,IERR)
3483 c write (iout,*) "Gather PRECOMP23"
3488 if (irecv.lt.0) irecv=nfgtasks1-1
3491 time_gather=time_gather+MPI_Wtime()-time00
3494 c if (fg_rank.eq.0) then
3495 write (iout,*) "Arrays UG and UGDER"
3497 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3498 & ((ug(l,k,i),l=1,2),k=1,2),
3499 & ((ugder(l,k,i),l=1,2),k=1,2)
3501 write (iout,*) "Arrays UG2 and UG2DER"
3503 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3504 & ((ug2(l,k,i),l=1,2),k=1,2),
3505 & ((ug2der(l,k,i),l=1,2),k=1,2)
3507 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3509 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3510 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3511 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3513 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3515 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3516 & costab(i),sintab(i),costab2(i),sintab2(i)
3518 write (iout,*) "Array MUDER"
3520 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3526 cd iti = itype2loc(itype(i))
3529 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3530 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3535 C-----------------------------------------------------------------------------
3536 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3538 C This subroutine calculates the average interaction energy and its gradient
3539 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3540 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3541 C The potential depends both on the distance of peptide-group centers and on
3542 C the orientation of the CA-CA virtual bonds.
3544 implicit real*8 (a-h,o-z)
3548 include 'DIMENSIONS'
3549 include 'COMMON.CONTROL'
3550 include 'COMMON.SETUP'
3551 include 'COMMON.IOUNITS'
3552 include 'COMMON.GEO'
3553 include 'COMMON.VAR'
3554 include 'COMMON.LOCAL'
3555 include 'COMMON.CHAIN'
3556 include 'COMMON.DERIV'
3557 include 'COMMON.INTERACT'
3558 include 'COMMON.CONTACTS'
3559 include 'COMMON.TORSION'
3560 include 'COMMON.VECTORS'
3561 include 'COMMON.FFIELD'
3562 include 'COMMON.TIME1'
3563 include 'COMMON.SPLITELE'
3564 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3565 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3566 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3567 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3568 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3569 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3571 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3573 double precision scal_el /1.0d0/
3575 double precision scal_el /0.5d0/
3578 C 13-go grudnia roku pamietnego...
3579 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3580 & 0.0d0,1.0d0,0.0d0,
3581 & 0.0d0,0.0d0,1.0d0/
3582 cd write(iout,*) 'In EELEC'
3584 cd write(iout,*) 'Type',i
3585 cd write(iout,*) 'B1',B1(:,i)
3586 cd write(iout,*) 'B2',B2(:,i)
3587 cd write(iout,*) 'CC',CC(:,:,i)
3588 cd write(iout,*) 'DD',DD(:,:,i)
3589 cd write(iout,*) 'EE',EE(:,:,i)
3591 cd call check_vecgrad
3593 if (icheckgrad.eq.1) then
3595 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3597 dc_norm(k,i)=dc(k,i)*fac
3599 c write (iout,*) 'i',i,' fac',fac
3602 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3603 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3604 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3605 c call vec_and_deriv
3611 time_mat=time_mat+MPI_Wtime()-time01
3615 cd write (iout,*) 'i=',i
3617 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3620 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3621 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3634 cd print '(a)','Enter EELEC'
3635 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3637 gel_loc_loc(i)=0.0d0
3642 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3644 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3646 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3647 do i=iturn3_start,iturn3_end
3649 C write(iout,*) "tu jest i",i
3650 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3651 C changes suggested by Ana to avoid out of bounds
3652 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3653 c & .or.((i+4).gt.nres)
3654 c & .or.((i-1).le.0)
3655 C end of changes by Ana
3656 & .or. itype(i+2).eq.ntyp1
3657 & .or. itype(i+3).eq.ntyp1) cycle
3658 C Adam: Instructions below will switch off existing interactions
3660 c if(itype(i-1).eq.ntyp1)cycle
3662 c if(i.LT.nres-3)then
3663 c if (itype(i+4).eq.ntyp1) cycle
3668 dx_normi=dc_norm(1,i)
3669 dy_normi=dc_norm(2,i)
3670 dz_normi=dc_norm(3,i)
3671 xmedi=c(1,i)+0.5d0*dxi
3672 ymedi=c(2,i)+0.5d0*dyi
3673 zmedi=c(3,i)+0.5d0*dzi
3674 xmedi=mod(xmedi,boxxsize)
3675 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3676 ymedi=mod(ymedi,boxysize)
3677 if (ymedi.lt.0) ymedi=ymedi+boxysize
3678 zmedi=mod(zmedi,boxzsize)
3679 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3681 call eelecij(i,i+2,ees,evdw1,eel_loc)
3682 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3683 num_cont_hb(i)=num_conti
3685 do i=iturn4_start,iturn4_end
3687 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3688 C changes suggested by Ana to avoid out of bounds
3689 c & .or.((i+5).gt.nres)
3690 c & .or.((i-1).le.0)
3691 C end of changes suggested by Ana
3692 & .or. itype(i+3).eq.ntyp1
3693 & .or. itype(i+4).eq.ntyp1
3694 c & .or. itype(i+5).eq.ntyp1
3695 c & .or. itype(i).eq.ntyp1
3696 c & .or. itype(i-1).eq.ntyp1
3701 dx_normi=dc_norm(1,i)
3702 dy_normi=dc_norm(2,i)
3703 dz_normi=dc_norm(3,i)
3704 xmedi=c(1,i)+0.5d0*dxi
3705 ymedi=c(2,i)+0.5d0*dyi
3706 zmedi=c(3,i)+0.5d0*dzi
3707 C Return atom into box, boxxsize is size of box in x dimension
3709 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3710 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3711 C Condition for being inside the proper box
3712 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3713 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3717 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3718 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3719 C Condition for being inside the proper box
3720 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3721 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3725 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3726 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3727 C Condition for being inside the proper box
3728 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3729 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3732 xmedi=mod(xmedi,boxxsize)
3733 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3734 ymedi=mod(ymedi,boxysize)
3735 if (ymedi.lt.0) ymedi=ymedi+boxysize
3736 zmedi=mod(zmedi,boxzsize)
3737 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3739 num_conti=num_cont_hb(i)
3740 c write(iout,*) "JESTEM W PETLI"
3741 call eelecij(i,i+3,ees,evdw1,eel_loc)
3742 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3743 & call eturn4(i,eello_turn4)
3744 num_cont_hb(i)=num_conti
3746 C Loop over all neighbouring boxes
3751 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3754 do i=iatel_s,iatel_e
3757 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3758 C changes suggested by Ana to avoid out of bounds
3759 c & .or.((i+2).gt.nres)
3760 c & .or.((i-1).le.0)
3761 C end of changes by Ana
3762 c & .or. itype(i+2).eq.ntyp1
3763 c & .or. itype(i-1).eq.ntyp1
3768 dx_normi=dc_norm(1,i)
3769 dy_normi=dc_norm(2,i)
3770 dz_normi=dc_norm(3,i)
3771 xmedi=c(1,i)+0.5d0*dxi
3772 ymedi=c(2,i)+0.5d0*dyi
3773 zmedi=c(3,i)+0.5d0*dzi
3774 xmedi=mod(xmedi,boxxsize)
3775 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3776 ymedi=mod(ymedi,boxysize)
3777 if (ymedi.lt.0) ymedi=ymedi+boxysize
3778 zmedi=mod(zmedi,boxzsize)
3779 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3780 C xmedi=xmedi+xshift*boxxsize
3781 C ymedi=ymedi+yshift*boxysize
3782 C zmedi=zmedi+zshift*boxzsize
3784 C Return tom into box, boxxsize is size of box in x dimension
3786 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3787 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3788 C Condition for being inside the proper box
3789 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3790 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3794 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3795 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3796 C Condition for being inside the proper box
3797 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3798 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3802 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3803 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3804 cC Condition for being inside the proper box
3805 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3806 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3810 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3811 num_conti=num_cont_hb(i)
3813 do j=ielstart(i),ielend(i)
3815 C write (iout,*) i,j
3817 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3818 C changes suggested by Ana to avoid out of bounds
3819 c & .or.((j+2).gt.nres)
3820 c & .or.((j-1).le.0)
3821 C end of changes by Ana
3822 c & .or.itype(j+2).eq.ntyp1
3823 c & .or.itype(j-1).eq.ntyp1
3825 call eelecij(i,j,ees,evdw1,eel_loc)
3827 num_cont_hb(i)=num_conti
3833 c write (iout,*) "Number of loop steps in EELEC:",ind
3835 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3836 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3838 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3839 ccc eel_loc=eel_loc+eello_turn3
3840 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3843 C-------------------------------------------------------------------------------
3844 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3845 implicit real*8 (a-h,o-z)
3846 include 'DIMENSIONS'
3850 include 'COMMON.CONTROL'
3851 include 'COMMON.IOUNITS'
3852 include 'COMMON.GEO'
3853 include 'COMMON.VAR'
3854 include 'COMMON.LOCAL'
3855 include 'COMMON.CHAIN'
3856 include 'COMMON.DERIV'
3857 include 'COMMON.INTERACT'
3858 include 'COMMON.CONTACTS'
3859 include 'COMMON.TORSION'
3860 include 'COMMON.VECTORS'
3861 include 'COMMON.FFIELD'
3862 include 'COMMON.TIME1'
3863 include 'COMMON.SPLITELE'
3864 include 'COMMON.SHIELD'
3865 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3866 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3867 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3868 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3869 & gmuij2(4),gmuji2(4)
3870 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3871 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3873 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3875 double precision scal_el /1.0d0/
3877 double precision scal_el /0.5d0/
3880 C 13-go grudnia roku pamietnego...
3881 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3882 & 0.0d0,1.0d0,0.0d0,
3883 & 0.0d0,0.0d0,1.0d0/
3884 integer xshift,yshift,zshift
3885 c time00=MPI_Wtime()
3886 cd write (iout,*) "eelecij",i,j
3890 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3891 aaa=app(iteli,itelj)
3892 bbb=bpp(iteli,itelj)
3893 ael6i=ael6(iteli,itelj)
3894 ael3i=ael3(iteli,itelj)
3898 dx_normj=dc_norm(1,j)
3899 dy_normj=dc_norm(2,j)
3900 dz_normj=dc_norm(3,j)
3901 C xj=c(1,j)+0.5D0*dxj-xmedi
3902 C yj=c(2,j)+0.5D0*dyj-ymedi
3903 C zj=c(3,j)+0.5D0*dzj-zmedi
3908 if (xj.lt.0) xj=xj+boxxsize
3910 if (yj.lt.0) yj=yj+boxysize
3912 if (zj.lt.0) zj=zj+boxzsize
3913 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3914 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3922 xj=xj_safe+xshift*boxxsize
3923 yj=yj_safe+yshift*boxysize
3924 zj=zj_safe+zshift*boxzsize
3925 dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3926 if(dist_temp.lt.dist_init) then
3936 if (isubchap.eq.1) then
3945 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3947 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3948 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3949 C Condition for being inside the proper box
3950 c if ((xj.gt.((0.5d0)*boxxsize)).or.
3951 c & (xj.lt.((-0.5d0)*boxxsize))) then
3955 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3956 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3957 C Condition for being inside the proper box
3958 c if ((yj.gt.((0.5d0)*boxysize)).or.
3959 c & (yj.lt.((-0.5d0)*boxysize))) then
3963 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3964 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3965 C Condition for being inside the proper box
3966 c if ((zj.gt.((0.5d0)*boxzsize)).or.
3967 c & (zj.lt.((-0.5d0)*boxzsize))) then
3970 C endif !endPBC condintion
3974 rij=xj*xj+yj*yj+zj*zj
3976 sss=sscale(sqrt(rij))
3977 sssgrad=sscagrad(sqrt(rij))
3978 c if (sss.gt.0.0d0) then
3984 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3985 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3986 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3987 fac=cosa-3.0D0*cosb*cosg
3989 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3990 if (j.eq.i+2) ev1=scal_el*ev1
3995 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3999 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4000 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4001 if (shield_mode.gt.0) then
4004 el1=el1*fac_shield(i)**2*fac_shield(j)**2
4005 el2=el2*fac_shield(i)**2*fac_shield(j)**2
4014 evdw1=evdw1+evdwij*sss
4015 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4016 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4017 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
4018 cd & xmedi,ymedi,zmedi,xj,yj,zj
4020 if (energy_dec) then
4021 write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
4023 &,iteli,itelj,aaa,evdw1,sss
4024 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4025 &fac_shield(i),fac_shield(j)
4029 C Calculate contributions to the Cartesian gradient.
4032 facvdw=-6*rrmij*(ev1+evdwij)*sss
4033 facel=-3*rrmij*(el1+eesij)
4040 * Radial derivatives. First process both termini of the fragment (i,j)
4045 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4046 & (shield_mode.gt.0)) then
4048 do ilist=1,ishield_list(i)
4049 iresshield=shield_list(ilist,i)
4051 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4053 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4055 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4056 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4057 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4058 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4059 C if (iresshield.gt.i) then
4060 C do ishi=i+1,iresshield-1
4061 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4062 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4066 C do ishi=iresshield,i
4067 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4068 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4074 do ilist=1,ishield_list(j)
4075 iresshield=shield_list(ilist,j)
4077 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4079 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4081 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4082 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4084 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4085 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4086 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4087 C if (iresshield.gt.j) then
4088 C do ishi=j+1,iresshield-1
4089 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4090 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4094 C do ishi=iresshield,j
4095 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4096 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4103 gshieldc(k,i)=gshieldc(k,i)+
4104 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4105 gshieldc(k,j)=gshieldc(k,j)+
4106 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4107 gshieldc(k,i-1)=gshieldc(k,i-1)+
4108 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4109 gshieldc(k,j-1)=gshieldc(k,j-1)+
4110 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4115 c ghalf=0.5D0*ggg(k)
4116 c gelc(k,i)=gelc(k,i)+ghalf
4117 c gelc(k,j)=gelc(k,j)+ghalf
4119 c 9/28/08 AL Gradient compotents will be summed only at the end
4120 C print *,"before", gelc_long(1,i), gelc_long(1,j)
4122 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4123 C & +grad_shield(k,j)*eesij/fac_shield(j)
4124 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4125 C & +grad_shield(k,i)*eesij/fac_shield(i)
4126 C gelc_long(k,i-1)=gelc_long(k,i-1)
4127 C & +grad_shield(k,i)*eesij/fac_shield(i)
4128 C gelc_long(k,j-1)=gelc_long(k,j-1)
4129 C & +grad_shield(k,j)*eesij/fac_shield(j)
4131 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4134 * Loop over residues i+1 thru j-1.
4138 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4141 if (sss.gt.0.0) then
4142 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4143 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4144 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4151 c ghalf=0.5D0*ggg(k)
4152 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4153 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4155 c 9/28/08 AL Gradient compotents will be summed only at the end
4157 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4158 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4161 * Loop over residues i+1 thru j-1.
4165 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4170 facvdw=(ev1+evdwij)*sss
4173 fac=-3*rrmij*(facvdw+facvdw+facel)
4178 * Radial derivatives. First process both termini of the fragment (i,j)
4181 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4183 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4185 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4187 c ghalf=0.5D0*ggg(k)
4188 c gelc(k,i)=gelc(k,i)+ghalf
4189 c gelc(k,j)=gelc(k,j)+ghalf
4191 c 9/28/08 AL Gradient compotents will be summed only at the end
4193 gelc_long(k,j)=gelc(k,j)+ggg(k)
4194 gelc_long(k,i)=gelc(k,i)-ggg(k)
4197 * Loop over residues i+1 thru j-1.
4201 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4204 c 9/28/08 AL Gradient compotents will be summed only at the end
4205 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4206 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4207 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4209 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4210 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4216 ecosa=2.0D0*fac3*fac1+fac4
4219 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4220 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4222 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4223 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4225 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4226 cd & (dcosg(k),k=1,3)
4228 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4229 & fac_shield(i)**2*fac_shield(j)**2
4232 c ghalf=0.5D0*ggg(k)
4233 c gelc(k,i)=gelc(k,i)+ghalf
4234 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4235 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4236 c gelc(k,j)=gelc(k,j)+ghalf
4237 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4238 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4242 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4245 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4248 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4249 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4250 & *fac_shield(i)**2*fac_shield(j)**2
4252 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4253 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4254 & *fac_shield(i)**2*fac_shield(j)**2
4255 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4256 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4258 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4262 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4263 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4264 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4266 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4267 C energy of a peptide unit is assumed in the form of a second-order
4268 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4269 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4270 C are computed for EVERY pair of non-contiguous peptide groups.
4273 if (j.lt.nres-1) then
4285 muij(kkk)=mu(k,i)*mu(l,j)
4286 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4288 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4289 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4290 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4291 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4292 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4293 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4298 write (iout,*) 'EELEC: i',i,' j',j
4299 write (iout,*) 'j',j,' j1',j1,' j2',j2
4300 write(iout,*) 'muij',muij
4302 ury=scalar(uy(1,i),erij)
4303 urz=scalar(uz(1,i),erij)
4304 vry=scalar(uy(1,j),erij)
4305 vrz=scalar(uz(1,j),erij)
4306 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4307 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4308 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4309 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4310 fac=dsqrt(-ael6i)*r3ij
4312 write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4313 write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4314 & "uyvz",scalar(uy(1,i),uz(1,j)),
4315 & "uzvy",scalar(uz(1,i),uy(1,j)),
4316 & "uzvz",scalar(uz(1,i),uz(1,j))
4317 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4318 write (iout,*) "fac",fac
4325 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4328 cd write (iout,'(4i5,4f10.5)')
4329 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4330 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4331 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4332 cd & uy(:,j),uz(:,j)
4333 cd write (iout,'(4f10.5)')
4334 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4335 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4336 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4337 cd write (iout,'(9f10.5/)')
4338 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4339 C Derivatives of the elements of A in virtual-bond vectors
4340 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4342 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4343 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4344 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4345 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4346 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4347 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4348 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4349 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4350 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4351 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4352 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4353 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4355 C Compute radial contributions to the gradient
4373 C Add the contributions coming from er
4376 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4377 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4378 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4379 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4382 C Derivatives in DC(i)
4383 cgrad ghalf1=0.5d0*agg(k,1)
4384 cgrad ghalf2=0.5d0*agg(k,2)
4385 cgrad ghalf3=0.5d0*agg(k,3)
4386 cgrad ghalf4=0.5d0*agg(k,4)
4387 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4388 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4389 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4390 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4391 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4392 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4393 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4394 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4395 C Derivatives in DC(i+1)
4396 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4397 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4398 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4399 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4400 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4401 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4402 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4403 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4404 C Derivatives in DC(j)
4405 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4406 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4407 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4408 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4409 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4410 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4411 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4412 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4413 C Derivatives in DC(j+1) or DC(nres-1)
4414 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4415 & -3.0d0*vryg(k,3)*ury)
4416 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4417 & -3.0d0*vrzg(k,3)*ury)
4418 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4419 & -3.0d0*vryg(k,3)*urz)
4420 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4421 & -3.0d0*vrzg(k,3)*urz)
4422 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4424 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4437 aggi(k,l)=-aggi(k,l)
4438 aggi1(k,l)=-aggi1(k,l)
4439 aggj(k,l)=-aggj(k,l)
4440 aggj1(k,l)=-aggj1(k,l)
4443 if (j.lt.nres-1) then
4449 aggi(k,l)=-aggi(k,l)
4450 aggi1(k,l)=-aggi1(k,l)
4451 aggj(k,l)=-aggj(k,l)
4452 aggj1(k,l)=-aggj1(k,l)
4463 aggi(k,l)=-aggi(k,l)
4464 aggi1(k,l)=-aggi1(k,l)
4465 aggj(k,l)=-aggj(k,l)
4466 aggj1(k,l)=-aggj1(k,l)
4471 IF (wel_loc.gt.0.0d0) THEN
4472 C Contribution to the local-electrostatic energy coming from the i-j pair
4473 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4476 write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4478 write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4479 & " wel_loc",wel_loc
4481 if (shield_mode.eq.0) then
4488 eel_loc_ij=eel_loc_ij
4489 & *fac_shield(i)*fac_shield(j)
4490 c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4491 c & 'eelloc',i,j,eel_loc_ij
4492 C Now derivative over eel_loc
4493 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4494 & (shield_mode.gt.0)) then
4497 do ilist=1,ishield_list(i)
4498 iresshield=shield_list(ilist,i)
4500 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4503 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4505 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4506 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4510 do ilist=1,ishield_list(j)
4511 iresshield=shield_list(ilist,j)
4513 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4516 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4518 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4519 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4526 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4527 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4528 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4529 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4530 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4531 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4532 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4533 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4538 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4539 c & ' eel_loc_ij',eel_loc_ij
4540 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4541 C Calculate patrial derivative for theta angle
4543 geel_loc_ij=(a22*gmuij1(1)
4547 & *fac_shield(i)*fac_shield(j)
4548 c write(iout,*) "derivative over thatai"
4549 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4551 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4552 & geel_loc_ij*wel_loc
4553 c write(iout,*) "derivative over thatai-1"
4554 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4561 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4562 & geel_loc_ij*wel_loc
4563 & *fac_shield(i)*fac_shield(j)
4565 c Derivative over j residue
4566 geel_loc_ji=a22*gmuji1(1)
4570 c write(iout,*) "derivative over thataj"
4571 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4574 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4575 & geel_loc_ji*wel_loc
4576 & *fac_shield(i)*fac_shield(j)
4583 c write(iout,*) "derivative over thataj-1"
4584 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4586 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4587 & geel_loc_ji*wel_loc
4588 & *fac_shield(i)*fac_shield(j)
4590 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4592 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4593 & 'eelloc',i,j,eel_loc_ij
4594 c if (eel_loc_ij.ne.0)
4595 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4596 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4598 eel_loc=eel_loc+eel_loc_ij
4599 C Partial derivatives in virtual-bond dihedral angles gamma
4601 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4602 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4603 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4604 & *fac_shield(i)*fac_shield(j)
4606 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4607 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4608 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4609 & *fac_shield(i)*fac_shield(j)
4610 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4612 ggg(l)=(agg(l,1)*muij(1)+
4613 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4614 & *fac_shield(i)*fac_shield(j)
4615 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4616 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4617 cgrad ghalf=0.5d0*ggg(l)
4618 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4619 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4623 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4626 C Remaining derivatives of eello
4628 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4629 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4630 & *fac_shield(i)*fac_shield(j)
4632 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4633 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4634 & *fac_shield(i)*fac_shield(j)
4636 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4637 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4638 & *fac_shield(i)*fac_shield(j)
4640 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4641 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4642 & *fac_shield(i)*fac_shield(j)
4646 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4647 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4648 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4649 & .and. num_conti.le.maxconts) then
4650 c write (iout,*) i,j," entered corr"
4652 C Calculate the contact function. The ith column of the array JCONT will
4653 C contain the numbers of atoms that make contacts with the atom I (of numbers
4654 C greater than I). The arrays FACONT and GACONT will contain the values of
4655 C the contact function and its derivative.
4656 c r0ij=1.02D0*rpp(iteli,itelj)
4657 c r0ij=1.11D0*rpp(iteli,itelj)
4658 r0ij=2.20D0*rpp(iteli,itelj)
4659 c r0ij=1.55D0*rpp(iteli,itelj)
4660 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4661 if (fcont.gt.0.0D0) then
4662 num_conti=num_conti+1
4663 if (num_conti.gt.maxconts) then
4664 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4665 & ' will skip next contacts for this conf.'
4667 jcont_hb(num_conti,i)=j
4668 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4669 cd & " jcont_hb",jcont_hb(num_conti,i)
4670 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4671 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4672 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4674 d_cont(num_conti,i)=rij
4675 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4676 C --- Electrostatic-interaction matrix ---
4677 a_chuj(1,1,num_conti,i)=a22
4678 a_chuj(1,2,num_conti,i)=a23
4679 a_chuj(2,1,num_conti,i)=a32
4680 a_chuj(2,2,num_conti,i)=a33
4681 C --- Gradient of rij
4683 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4690 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4691 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4692 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4693 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4694 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4699 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4700 C Calculate contact energies
4702 wij=cosa-3.0D0*cosb*cosg
4705 c fac3=dsqrt(-ael6i)/r0ij**3
4706 fac3=dsqrt(-ael6i)*r3ij
4707 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4708 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4709 if (ees0tmp.gt.0) then
4710 ees0pij=dsqrt(ees0tmp)
4714 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4715 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4716 if (ees0tmp.gt.0) then
4717 ees0mij=dsqrt(ees0tmp)
4722 if (shield_mode.eq.0) then
4726 ees0plist(num_conti,i)=j
4727 C fac_shield(i)=0.4d0
4728 C fac_shield(j)=0.6d0
4730 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4731 & *fac_shield(i)*fac_shield(j)
4732 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4733 & *fac_shield(i)*fac_shield(j)
4734 C Diagnostics. Comment out or remove after debugging!
4735 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4736 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4737 c ees0m(num_conti,i)=0.0D0
4739 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4740 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4741 C Angular derivatives of the contact function
4742 ees0pij1=fac3/ees0pij
4743 ees0mij1=fac3/ees0mij
4744 fac3p=-3.0D0*fac3*rrmij
4745 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4746 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4748 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4749 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4750 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4751 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4752 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4753 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4754 ecosap=ecosa1+ecosa2
4755 ecosbp=ecosb1+ecosb2
4756 ecosgp=ecosg1+ecosg2
4757 ecosam=ecosa1-ecosa2
4758 ecosbm=ecosb1-ecosb2
4759 ecosgm=ecosg1-ecosg2
4768 facont_hb(num_conti,i)=fcont
4769 fprimcont=fprimcont/rij
4770 cd facont_hb(num_conti,i)=1.0D0
4771 C Following line is for diagnostics.
4774 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4775 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4778 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4779 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4781 gggp(1)=gggp(1)+ees0pijp*xj
4782 gggp(2)=gggp(2)+ees0pijp*yj
4783 gggp(3)=gggp(3)+ees0pijp*zj
4784 gggm(1)=gggm(1)+ees0mijp*xj
4785 gggm(2)=gggm(2)+ees0mijp*yj
4786 gggm(3)=gggm(3)+ees0mijp*zj
4787 C Derivatives due to the contact function
4788 gacont_hbr(1,num_conti,i)=fprimcont*xj
4789 gacont_hbr(2,num_conti,i)=fprimcont*yj
4790 gacont_hbr(3,num_conti,i)=fprimcont*zj
4793 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4794 c following the change of gradient-summation algorithm.
4796 cgrad ghalfp=0.5D0*gggp(k)
4797 cgrad ghalfm=0.5D0*gggm(k)
4798 gacontp_hb1(k,num_conti,i)=!ghalfp
4799 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4800 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4801 & *fac_shield(i)*fac_shield(j)
4803 gacontp_hb2(k,num_conti,i)=!ghalfp
4804 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4805 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4806 & *fac_shield(i)*fac_shield(j)
4808 gacontp_hb3(k,num_conti,i)=gggp(k)
4809 & *fac_shield(i)*fac_shield(j)
4811 gacontm_hb1(k,num_conti,i)=!ghalfm
4812 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4813 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4814 & *fac_shield(i)*fac_shield(j)
4816 gacontm_hb2(k,num_conti,i)=!ghalfm
4817 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4818 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4819 & *fac_shield(i)*fac_shield(j)
4821 gacontm_hb3(k,num_conti,i)=gggm(k)
4822 & *fac_shield(i)*fac_shield(j)
4825 C Diagnostics. Comment out or remove after debugging!
4827 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4828 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4829 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4830 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4831 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4832 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4835 endif ! num_conti.le.maxconts
4838 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4841 ghalf=0.5d0*agg(l,k)
4842 aggi(l,k)=aggi(l,k)+ghalf
4843 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4844 aggj(l,k)=aggj(l,k)+ghalf
4847 if (j.eq.nres-1 .and. i.lt.j-2) then
4850 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4855 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4858 C-----------------------------------------------------------------------------
4859 subroutine eturn3(i,eello_turn3)
4860 C Third- and fourth-order contributions from turns
4861 implicit real*8 (a-h,o-z)
4862 include 'DIMENSIONS'
4863 include 'COMMON.IOUNITS'
4864 include 'COMMON.GEO'
4865 include 'COMMON.VAR'
4866 include 'COMMON.LOCAL'
4867 include 'COMMON.CHAIN'
4868 include 'COMMON.DERIV'
4869 include 'COMMON.INTERACT'
4870 include 'COMMON.CONTACTS'
4871 include 'COMMON.TORSION'
4872 include 'COMMON.VECTORS'
4873 include 'COMMON.FFIELD'
4874 include 'COMMON.CONTROL'
4875 include 'COMMON.SHIELD'
4877 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4878 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4879 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4880 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4881 & auxgmat2(2,2),auxgmatt2(2,2)
4882 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4883 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4884 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4885 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4888 c write (iout,*) "eturn3",i,j,j1,j2
4893 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4895 C Third-order contributions
4902 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4903 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4904 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4905 c auxalary matices for theta gradient
4906 c auxalary matrix for i+1 and constant i+2
4907 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4908 c auxalary matrix for i+2 and constant i+1
4909 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4910 call transpose2(auxmat(1,1),auxmat1(1,1))
4911 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4912 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4913 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4914 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4915 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4916 if (shield_mode.eq.0) then
4923 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4924 & *fac_shield(i)*fac_shield(j)
4925 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4926 & *fac_shield(i)*fac_shield(j)
4927 if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4930 C Derivatives in theta
4931 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4932 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4933 & *fac_shield(i)*fac_shield(j)
4934 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4935 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4936 & *fac_shield(i)*fac_shield(j)
4939 C Derivatives in shield mode
4940 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4941 & (shield_mode.gt.0)) then
4944 do ilist=1,ishield_list(i)
4945 iresshield=shield_list(ilist,i)
4947 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4949 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4951 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4952 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4956 do ilist=1,ishield_list(j)
4957 iresshield=shield_list(ilist,j)
4959 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4961 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4963 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4964 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4971 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4972 & grad_shield(k,i)*eello_t3/fac_shield(i)
4973 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4974 & grad_shield(k,j)*eello_t3/fac_shield(j)
4975 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4976 & grad_shield(k,i)*eello_t3/fac_shield(i)
4977 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4978 & grad_shield(k,j)*eello_t3/fac_shield(j)
4982 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4983 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
4984 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
4985 cd & ' eello_turn3_num',4*eello_turn3_num
4986 C Derivatives in gamma(i)
4987 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4988 call transpose2(auxmat2(1,1),auxmat3(1,1))
4989 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4990 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4991 & *fac_shield(i)*fac_shield(j)
4992 C Derivatives in gamma(i+1)
4993 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4994 call transpose2(auxmat2(1,1),auxmat3(1,1))
4995 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4996 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4997 & +0.5d0*(pizda(1,1)+pizda(2,2))
4998 & *fac_shield(i)*fac_shield(j)
4999 C Cartesian derivatives
5001 c ghalf1=0.5d0*agg(l,1)
5002 c ghalf2=0.5d0*agg(l,2)
5003 c ghalf3=0.5d0*agg(l,3)
5004 c ghalf4=0.5d0*agg(l,4)
5005 a_temp(1,1)=aggi(l,1)!+ghalf1
5006 a_temp(1,2)=aggi(l,2)!+ghalf2
5007 a_temp(2,1)=aggi(l,3)!+ghalf3
5008 a_temp(2,2)=aggi(l,4)!+ghalf4
5009 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5010 gcorr3_turn(l,i)=gcorr3_turn(l,i)
5011 & +0.5d0*(pizda(1,1)+pizda(2,2))
5012 & *fac_shield(i)*fac_shield(j)
5014 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5015 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5016 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5017 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5018 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5019 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5020 & +0.5d0*(pizda(1,1)+pizda(2,2))
5021 & *fac_shield(i)*fac_shield(j)
5022 a_temp(1,1)=aggj(l,1)!+ghalf1
5023 a_temp(1,2)=aggj(l,2)!+ghalf2
5024 a_temp(2,1)=aggj(l,3)!+ghalf3
5025 a_temp(2,2)=aggj(l,4)!+ghalf4
5026 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5027 gcorr3_turn(l,j)=gcorr3_turn(l,j)
5028 & +0.5d0*(pizda(1,1)+pizda(2,2))
5029 & *fac_shield(i)*fac_shield(j)
5030 a_temp(1,1)=aggj1(l,1)
5031 a_temp(1,2)=aggj1(l,2)
5032 a_temp(2,1)=aggj1(l,3)
5033 a_temp(2,2)=aggj1(l,4)
5034 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5035 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5036 & +0.5d0*(pizda(1,1)+pizda(2,2))
5037 & *fac_shield(i)*fac_shield(j)
5041 C-------------------------------------------------------------------------------
5042 subroutine eturn4(i,eello_turn4)
5043 C Third- and fourth-order contributions from turns
5044 implicit real*8 (a-h,o-z)
5045 include 'DIMENSIONS'
5046 include 'COMMON.IOUNITS'
5047 include 'COMMON.GEO'
5048 include 'COMMON.VAR'
5049 include 'COMMON.LOCAL'
5050 include 'COMMON.CHAIN'
5051 include 'COMMON.DERIV'
5052 include 'COMMON.INTERACT'
5053 include 'COMMON.CONTACTS'
5054 include 'COMMON.TORSION'
5055 include 'COMMON.VECTORS'
5056 include 'COMMON.FFIELD'
5057 include 'COMMON.CONTROL'
5058 include 'COMMON.SHIELD'
5060 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5061 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5062 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5063 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5064 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
5065 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5066 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5067 double precision agg(3,4),aggi(3,4),aggi1(3,4),
5068 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5069 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5070 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5073 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5075 C Fourth-order contributions
5083 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5084 cd call checkint_turn4(i,a_temp,eello_turn4_num)
5085 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5086 c write(iout,*)"WCHODZE W PROGRAM"
5091 iti1=itype2loc(itype(i+1))
5092 iti2=itype2loc(itype(i+2))
5093 iti3=itype2loc(itype(i+3))
5094 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5095 call transpose2(EUg(1,1,i+1),e1t(1,1))
5096 call transpose2(Eug(1,1,i+2),e2t(1,1))
5097 call transpose2(Eug(1,1,i+3),e3t(1,1))
5098 C Ematrix derivative in theta
5099 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5100 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5101 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5102 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5103 c eta1 in derivative theta
5104 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5105 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5106 c auxgvec is derivative of Ub2 so i+3 theta
5107 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5108 c auxalary matrix of E i+1
5109 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5112 s1=scalar2(b1(1,i+2),auxvec(1))
5113 c derivative of theta i+2 with constant i+3
5114 gs23=scalar2(gtb1(1,i+2),auxvec(1))
5115 c derivative of theta i+2 with constant i+2
5116 gs32=scalar2(b1(1,i+2),auxgvec(1))
5117 c derivative of E matix in theta of i+1
5118 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5120 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5121 c ea31 in derivative theta
5122 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5123 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5124 c auxilary matrix auxgvec of Ub2 with constant E matirx
5125 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5126 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5127 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5131 s2=scalar2(b1(1,i+1),auxvec(1))
5132 c derivative of theta i+1 with constant i+3
5133 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5134 c derivative of theta i+2 with constant i+1
5135 gs21=scalar2(b1(1,i+1),auxgvec(1))
5136 c derivative of theta i+3 with constant i+1
5137 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5138 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5140 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5141 c two derivatives over diffetent matrices
5142 c gtae3e2 is derivative over i+3
5143 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5144 c ae3gte2 is derivative over i+2
5145 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5146 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5147 c three possible derivative over theta E matices
5149 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5151 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5153 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5154 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5156 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5157 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5158 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5159 if (shield_mode.eq.0) then
5166 eello_turn4=eello_turn4-(s1+s2+s3)
5167 & *fac_shield(i)*fac_shield(j)
5168 eello_t4=-(s1+s2+s3)
5169 & *fac_shield(i)*fac_shield(j)
5170 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5171 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5172 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5173 C Now derivative over shield:
5174 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5175 & (shield_mode.gt.0)) then
5178 do ilist=1,ishield_list(i)
5179 iresshield=shield_list(ilist,i)
5181 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5183 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5185 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5186 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5190 do ilist=1,ishield_list(j)
5191 iresshield=shield_list(ilist,j)
5193 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5195 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5197 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5198 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5205 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5206 & grad_shield(k,i)*eello_t4/fac_shield(i)
5207 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5208 & grad_shield(k,j)*eello_t4/fac_shield(j)
5209 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5210 & grad_shield(k,i)*eello_t4/fac_shield(i)
5211 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5212 & grad_shield(k,j)*eello_t4/fac_shield(j)
5221 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5222 cd & ' eello_turn4_num',8*eello_turn4_num
5224 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5225 & -(gs13+gsE13+gsEE1)*wturn4
5226 & *fac_shield(i)*fac_shield(j)
5227 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5228 & -(gs23+gs21+gsEE2)*wturn4
5229 & *fac_shield(i)*fac_shield(j)
5231 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5232 & -(gs32+gsE31+gsEE3)*wturn4
5233 & *fac_shield(i)*fac_shield(j)
5235 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5238 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5239 & 'eturn4',i,j,-(s1+s2+s3)
5240 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5241 c & ' eello_turn4_num',8*eello_turn4_num
5242 C Derivatives in gamma(i)
5243 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5244 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5245 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5246 s1=scalar2(b1(1,i+2),auxvec(1))
5247 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5248 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5249 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5250 & *fac_shield(i)*fac_shield(j)
5251 C Derivatives in gamma(i+1)
5252 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5253 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5254 s2=scalar2(b1(1,i+1),auxvec(1))
5255 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5256 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5257 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5258 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5259 & *fac_shield(i)*fac_shield(j)
5260 C Derivatives in gamma(i+2)
5261 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5262 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5263 s1=scalar2(b1(1,i+2),auxvec(1))
5264 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5265 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5266 s2=scalar2(b1(1,i+1),auxvec(1))
5267 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5268 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5269 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5270 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5271 & *fac_shield(i)*fac_shield(j)
5272 C Cartesian derivatives
5273 C Derivatives of this turn contributions in DC(i+2)
5274 if (j.lt.nres-1) then
5276 a_temp(1,1)=agg(l,1)
5277 a_temp(1,2)=agg(l,2)
5278 a_temp(2,1)=agg(l,3)
5279 a_temp(2,2)=agg(l,4)
5280 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5281 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5282 s1=scalar2(b1(1,i+2),auxvec(1))
5283 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5284 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5285 s2=scalar2(b1(1,i+1),auxvec(1))
5286 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5287 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5288 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5290 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5291 & *fac_shield(i)*fac_shield(j)
5294 C Remaining derivatives of this turn contribution
5296 a_temp(1,1)=aggi(l,1)
5297 a_temp(1,2)=aggi(l,2)
5298 a_temp(2,1)=aggi(l,3)
5299 a_temp(2,2)=aggi(l,4)
5300 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5301 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5302 s1=scalar2(b1(1,i+2),auxvec(1))
5303 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5304 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5305 s2=scalar2(b1(1,i+1),auxvec(1))
5306 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5307 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5308 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5309 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5310 & *fac_shield(i)*fac_shield(j)
5311 a_temp(1,1)=aggi1(l,1)
5312 a_temp(1,2)=aggi1(l,2)
5313 a_temp(2,1)=aggi1(l,3)
5314 a_temp(2,2)=aggi1(l,4)
5315 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5316 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5317 s1=scalar2(b1(1,i+2),auxvec(1))
5318 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5319 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5320 s2=scalar2(b1(1,i+1),auxvec(1))
5321 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5322 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5323 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5324 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5325 & *fac_shield(i)*fac_shield(j)
5326 a_temp(1,1)=aggj(l,1)
5327 a_temp(1,2)=aggj(l,2)
5328 a_temp(2,1)=aggj(l,3)
5329 a_temp(2,2)=aggj(l,4)
5330 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5331 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5332 s1=scalar2(b1(1,i+2),auxvec(1))
5333 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5334 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5335 s2=scalar2(b1(1,i+1),auxvec(1))
5336 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5337 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5338 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5339 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5340 & *fac_shield(i)*fac_shield(j)
5341 a_temp(1,1)=aggj1(l,1)
5342 a_temp(1,2)=aggj1(l,2)
5343 a_temp(2,1)=aggj1(l,3)
5344 a_temp(2,2)=aggj1(l,4)
5345 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5346 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5347 s1=scalar2(b1(1,i+2),auxvec(1))
5348 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5349 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5350 s2=scalar2(b1(1,i+1),auxvec(1))
5351 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5352 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5353 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5354 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5355 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5356 & *fac_shield(i)*fac_shield(j)
5360 C-----------------------------------------------------------------------------
5361 subroutine vecpr(u,v,w)
5362 implicit real*8(a-h,o-z)
5363 dimension u(3),v(3),w(3)
5364 w(1)=u(2)*v(3)-u(3)*v(2)
5365 w(2)=-u(1)*v(3)+u(3)*v(1)
5366 w(3)=u(1)*v(2)-u(2)*v(1)
5369 C-----------------------------------------------------------------------------
5370 subroutine unormderiv(u,ugrad,unorm,ungrad)
5371 C This subroutine computes the derivatives of a normalized vector u, given
5372 C the derivatives computed without normalization conditions, ugrad. Returns
5375 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5376 double precision vec(3)
5377 double precision scalar
5379 c write (2,*) 'ugrad',ugrad
5382 vec(i)=scalar(ugrad(1,i),u(1))
5384 c write (2,*) 'vec',vec
5387 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5390 c write (2,*) 'ungrad',ungrad
5393 C-----------------------------------------------------------------------------
5394 subroutine escp_soft_sphere(evdw2,evdw2_14)
5396 C This subroutine calculates the excluded-volume interaction energy between
5397 C peptide-group centers and side chains and its gradient in virtual-bond and
5398 C side-chain vectors.
5400 implicit real*8 (a-h,o-z)
5401 include 'DIMENSIONS'
5402 include 'COMMON.GEO'
5403 include 'COMMON.VAR'
5404 include 'COMMON.LOCAL'
5405 include 'COMMON.CHAIN'
5406 include 'COMMON.DERIV'
5407 include 'COMMON.INTERACT'
5408 include 'COMMON.FFIELD'
5409 include 'COMMON.IOUNITS'
5410 include 'COMMON.CONTROL'
5412 integer xshift,yshift,zshift
5416 cd print '(a)','Enter ESCP'
5417 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5421 do i=iatscp_s,iatscp_e
5422 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5424 xi=0.5D0*(c(1,i)+c(1,i+1))
5425 yi=0.5D0*(c(2,i)+c(2,i+1))
5426 zi=0.5D0*(c(3,i)+c(3,i+1))
5427 C Return atom into box, boxxsize is size of box in x dimension
5429 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5430 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5431 C Condition for being inside the proper box
5432 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5433 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5437 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5438 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5439 C Condition for being inside the proper box
5440 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5441 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5445 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5446 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5447 cC Condition for being inside the proper box
5448 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5449 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5453 if (xi.lt.0) xi=xi+boxxsize
5455 if (yi.lt.0) yi=yi+boxysize
5457 if (zi.lt.0) zi=zi+boxzsize
5458 C xi=xi+xshift*boxxsize
5459 C yi=yi+yshift*boxysize
5460 C zi=zi+zshift*boxzsize
5461 do iint=1,nscp_gr(i)
5463 do j=iscpstart(i,iint),iscpend(i,iint)
5464 if (itype(j).eq.ntyp1) cycle
5465 itypj=iabs(itype(j))
5466 C Uncomment following three lines for SC-p interactions
5470 C Uncomment following three lines for Ca-p interactions
5475 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5476 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5477 C Condition for being inside the proper box
5478 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5479 c & (xj.lt.((-0.5d0)*boxxsize))) then
5483 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5484 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5485 cC Condition for being inside the proper box
5486 c if ((yj.gt.((0.5d0)*boxysize)).or.
5487 c & (yj.lt.((-0.5d0)*boxysize))) then
5491 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5492 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5493 C Condition for being inside the proper box
5494 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5495 c & (zj.lt.((-0.5d0)*boxzsize))) then
5498 if (xj.lt.0) xj=xj+boxxsize
5500 if (yj.lt.0) yj=yj+boxysize
5502 if (zj.lt.0) zj=zj+boxzsize
5503 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5511 xj=xj_safe+xshift*boxxsize
5512 yj=yj_safe+yshift*boxysize
5513 zj=zj_safe+zshift*boxzsize
5514 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5515 if(dist_temp.lt.dist_init) then
5525 if (subchap.eq.1) then
5538 rij=xj*xj+yj*yj+zj*zj
5542 if (rij.lt.r0ijsq) then
5543 evdwij=0.25d0*(rij-r0ijsq)**2
5551 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5556 cgrad if (j.lt.i) then
5557 cd write (iout,*) 'j<i'
5558 C Uncomment following three lines for SC-p interactions
5560 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5563 cd write (iout,*) 'j>i'
5565 cgrad ggg(k)=-ggg(k)
5566 C Uncomment following line for SC-p interactions
5567 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5571 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5573 cgrad kstart=min0(i+1,j)
5574 cgrad kend=max0(i-1,j-1)
5575 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5576 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5577 cgrad do k=kstart,kend
5579 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5583 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5584 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5595 C-----------------------------------------------------------------------------
5596 subroutine escp(evdw2,evdw2_14)
5598 C This subroutine calculates the excluded-volume interaction energy between
5599 C peptide-group centers and side chains and its gradient in virtual-bond and
5600 C side-chain vectors.
5602 implicit real*8 (a-h,o-z)
5603 include 'DIMENSIONS'
5604 include 'COMMON.GEO'
5605 include 'COMMON.VAR'
5606 include 'COMMON.LOCAL'
5607 include 'COMMON.CHAIN'
5608 include 'COMMON.DERIV'
5609 include 'COMMON.INTERACT'
5610 include 'COMMON.FFIELD'
5611 include 'COMMON.IOUNITS'
5612 include 'COMMON.CONTROL'
5613 include 'COMMON.SPLITELE'
5614 integer xshift,yshift,zshift
5618 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5619 cd print '(a)','Enter ESCP'
5620 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5624 if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5625 do i=iatscp_s,iatscp_e
5626 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5628 xi=0.5D0*(c(1,i)+c(1,i+1))
5629 yi=0.5D0*(c(2,i)+c(2,i+1))
5630 zi=0.5D0*(c(3,i)+c(3,i+1))
5632 if (xi.lt.0) xi=xi+boxxsize
5634 if (yi.lt.0) yi=yi+boxysize
5636 if (zi.lt.0) zi=zi+boxzsize
5637 c xi=xi+xshift*boxxsize
5638 c yi=yi+yshift*boxysize
5639 c zi=zi+zshift*boxzsize
5640 c print *,xi,yi,zi,'polozenie i'
5641 C Return atom into box, boxxsize is size of box in x dimension
5643 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5644 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5645 C Condition for being inside the proper box
5646 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5647 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5651 c print *,xi,boxxsize,"pierwszy"
5653 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5654 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5655 C Condition for being inside the proper box
5656 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5657 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5661 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5662 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5663 C Condition for being inside the proper box
5664 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5665 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5668 do iint=1,nscp_gr(i)
5670 do j=iscpstart(i,iint),iscpend(i,iint)
5671 itypj=iabs(itype(j))
5672 if (itypj.eq.ntyp1) cycle
5673 C Uncomment following three lines for SC-p interactions
5677 C Uncomment following three lines for Ca-p interactions
5682 if (xj.lt.0) xj=xj+boxxsize
5684 if (yj.lt.0) yj=yj+boxysize
5686 if (zj.lt.0) zj=zj+boxzsize
5688 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5689 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5690 C Condition for being inside the proper box
5691 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5692 c & (xj.lt.((-0.5d0)*boxxsize))) then
5696 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5697 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5698 cC Condition for being inside the proper box
5699 c if ((yj.gt.((0.5d0)*boxysize)).or.
5700 c & (yj.lt.((-0.5d0)*boxysize))) then
5704 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5705 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5706 C Condition for being inside the proper box
5707 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5708 c & (zj.lt.((-0.5d0)*boxzsize))) then
5711 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5712 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5720 xj=xj_safe+xshift*boxxsize
5721 yj=yj_safe+yshift*boxysize
5722 zj=zj_safe+zshift*boxzsize
5723 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5724 if(dist_temp.lt.dist_init) then
5734 if (subchap.eq.1) then
5743 c print *,xj,yj,zj,'polozenie j'
5744 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5746 sss=sscale(1.0d0/(dsqrt(rrij)))
5747 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5748 c if (sss.eq.0) print *,'czasem jest OK'
5749 if (sss.le.0.0d0) cycle
5750 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5752 e1=fac*fac*aad(itypj,iteli)
5753 e2=fac*bad(itypj,iteli)
5754 if (iabs(j-i) .le. 2) then
5757 evdw2_14=evdw2_14+(e1+e2)*sss
5760 evdw2=evdw2+evdwij*sss
5761 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5762 & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5765 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5767 fac=-(evdwij+e1)*rrij*sss
5768 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5772 cgrad if (j.lt.i) then
5773 cd write (iout,*) 'j<i'
5774 C Uncomment following three lines for SC-p interactions
5776 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5779 cd write (iout,*) 'j>i'
5781 cgrad ggg(k)=-ggg(k)
5782 C Uncomment following line for SC-p interactions
5783 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5784 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5788 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5790 cgrad kstart=min0(i+1,j)
5791 cgrad kend=max0(i-1,j-1)
5792 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5793 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5794 cgrad do k=kstart,kend
5796 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5800 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5801 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5803 c endif !endif for sscale cutoff
5813 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5814 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5815 gradx_scp(j,i)=expon*gradx_scp(j,i)
5818 C******************************************************************************
5822 C To save time the factor EXPON has been extracted from ALL components
5823 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5826 C******************************************************************************
5829 C--------------------------------------------------------------------------
5830 subroutine edis(ehpb)
5832 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5834 implicit real*8 (a-h,o-z)
5835 include 'DIMENSIONS'
5836 include 'COMMON.SBRIDGE'
5837 include 'COMMON.CHAIN'
5838 include 'COMMON.DERIV'
5839 include 'COMMON.VAR'
5840 include 'COMMON.INTERACT'
5841 include 'COMMON.IOUNITS'
5842 include 'COMMON.CONTROL'
5843 dimension ggg(3),ggg_peak(3,1000)
5848 c 8/21/18 AL: added explicit restraints on reference coords
5849 c write (iout,*) "restr_on_coord",restr_on_coord
5850 if (restr_on_coord) then
5854 if (itype(i).eq.ntyp1) cycle
5856 ecoor=ecoor+(c(j,i)-cref(j,i))**2
5857 ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5859 if (itype(i).ne.10) then
5861 ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5862 ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5865 if (energy_dec) write (iout,*)
5866 & "i",i," bfac",bfac(i)," ecoor",ecoor
5867 ehpb=ehpb+0.5d0*bfac(i)*ecoor
5871 C write (iout,*) ,"link_end",link_end,constr_dist
5872 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5873 c write(iout,*)'link_start=',link_start,' link_end=',link_end,
5874 c & " constr_dist",constr_dist," link_start_peak",link_start_peak,
5875 c & " link_end_peak",link_end_peak
5876 if (link_end.eq.0.and.link_end_peak.eq.0) return
5877 do i=link_start_peak,link_end_peak
5879 c print *,"i",i," link_end_peak",link_end_peak," ipeak",
5880 c & ipeak(1,i),ipeak(2,i)
5881 do ip=ipeak(1,i),ipeak(2,i)
5886 C iii and jjj point to the residues for which the distance is assigned.
5887 c if (ii.gt.nres) then
5894 if (ii.gt.nres) then
5899 if (jj.gt.nres) then
5904 aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5905 aux=dexp(-scal_peak*aux)
5906 ehpb_peak=ehpb_peak+aux
5907 fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5908 & forcon_peak(ip))*aux/dd
5910 ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5912 if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5913 & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5914 & forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5916 c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5917 ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5918 do ip=ipeak(1,i),ipeak(2,i)
5921 ggg(j)=ggg_peak(j,iip)/ehpb_peak
5925 C iii and jjj point to the residues for which the distance is assigned.
5926 c if (ii.gt.nres) then
5933 if (ii.gt.nres) then
5938 if (jj.gt.nres) then
5945 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5950 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5954 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5955 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5959 do i=link_start,link_end
5960 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5961 C CA-CA distance used in regularization of structure.
5964 C iii and jjj point to the residues for which the distance is assigned.
5965 if (ii.gt.nres) then
5970 if (jj.gt.nres) then
5975 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5976 c & dhpb(i),dhpb1(i),forcon(i)
5977 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5978 C distance and angle dependent SS bond potential.
5979 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5980 C & iabs(itype(jjj)).eq.1) then
5981 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5982 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5983 if (.not.dyn_ss .and. i.le.nss) then
5984 C 15/02/13 CC dynamic SSbond - additional check
5985 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5986 & iabs(itype(jjj)).eq.1) then
5987 call ssbond_ene(iii,jjj,eij)
5990 cd write (iout,*) "eij",eij
5991 cd & ' waga=',waga,' fac=',fac
5992 ! else if (ii.gt.nres .and. jj.gt.nres) then
5994 C Calculate the distance between the two points and its difference from the
5997 if (irestr_type(i).eq.11) then
5998 ehpb=ehpb+fordepth(i)!**4.0d0
5999 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6000 fac=fordepth(i)!**4.0d0
6001 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6002 if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6003 & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6004 & ehpb,irestr_type(i)
6005 else if (irestr_type(i).eq.10) then
6006 c AL 6//19/2018 cross-link restraints
6007 xdis = 0.5d0*(dd/forcon(i))**2
6008 expdis = dexp(-xdis)
6009 c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6010 aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6011 c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6012 c & " wboltzd",wboltzd
6013 ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6014 c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6015 fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6016 & *expdis/(aux*forcon(i)**2)
6017 if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6018 & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6019 & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6020 else if (irestr_type(i).eq.2) then
6021 c Quartic restraints
6022 ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6023 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6024 & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6025 & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6026 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6028 c Quadratic restraints
6030 C Get the force constant corresponding to this distance.
6032 C Calculate the contribution to energy.
6033 ehpb=ehpb+0.5d0*waga*rdis*rdis
6034 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6035 & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6036 & 0.5d0*waga*rdis*rdis,irestr_type(i)
6038 C Evaluate gradient.
6042 c Calculate Cartesian gradient
6044 ggg(j)=fac*(c(j,jj)-c(j,ii))
6046 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6047 C If this is a SC-SC distance, we need to calculate the contributions to the
6048 C Cartesian gradient in the SC vectors (ghpbx).
6051 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6056 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6060 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6061 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6067 C--------------------------------------------------------------------------
6068 subroutine ssbond_ene(i,j,eij)
6070 C Calculate the distance and angle dependent SS-bond potential energy
6071 C using a free-energy function derived based on RHF/6-31G** ab initio
6072 C calculations of diethyl disulfide.
6074 C A. Liwo and U. Kozlowska, 11/24/03
6076 implicit real*8 (a-h,o-z)
6077 include 'DIMENSIONS'
6078 include 'COMMON.SBRIDGE'
6079 include 'COMMON.CHAIN'
6080 include 'COMMON.DERIV'
6081 include 'COMMON.LOCAL'
6082 include 'COMMON.INTERACT'
6083 include 'COMMON.VAR'
6084 include 'COMMON.IOUNITS'
6085 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6086 itypi=iabs(itype(i))
6090 dxi=dc_norm(1,nres+i)
6091 dyi=dc_norm(2,nres+i)
6092 dzi=dc_norm(3,nres+i)
6093 c dsci_inv=dsc_inv(itypi)
6094 dsci_inv=vbld_inv(nres+i)
6095 itypj=iabs(itype(j))
6096 c dscj_inv=dsc_inv(itypj)
6097 dscj_inv=vbld_inv(nres+j)
6101 dxj=dc_norm(1,nres+j)
6102 dyj=dc_norm(2,nres+j)
6103 dzj=dc_norm(3,nres+j)
6104 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6109 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6110 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6111 om12=dxi*dxj+dyi*dyj+dzi*dzj
6113 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6114 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6120 deltat12=om2-om1+2.0d0
6122 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6123 & +akct*deltad*deltat12
6124 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6125 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6126 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6127 c & " deltat12",deltat12," eij",eij
6128 ed=2*akcm*deltad+akct*deltat12
6130 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6131 eom1=-2*akth*deltat1-pom1-om2*pom2
6132 eom2= 2*akth*deltat2+pom1-om1*pom2
6135 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6136 ghpbx(k,i)=ghpbx(k,i)-ggk
6137 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6138 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6139 ghpbx(k,j)=ghpbx(k,j)+ggk
6140 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6141 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6142 ghpbc(k,i)=ghpbc(k,i)-ggk
6143 ghpbc(k,j)=ghpbc(k,j)+ggk
6146 C Calculate the components of the gradient in DC and X
6150 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
6155 C--------------------------------------------------------------------------
6156 subroutine ebond(estr)
6158 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6160 implicit real*8 (a-h,o-z)
6161 include 'DIMENSIONS'
6162 include 'COMMON.LOCAL'
6163 include 'COMMON.GEO'
6164 include 'COMMON.INTERACT'
6165 include 'COMMON.DERIV'
6166 include 'COMMON.VAR'
6167 include 'COMMON.CHAIN'
6168 include 'COMMON.IOUNITS'
6169 include 'COMMON.NAMES'
6170 include 'COMMON.FFIELD'
6171 include 'COMMON.CONTROL'
6172 include 'COMMON.SETUP'
6173 double precision u(3),ud(3)
6176 do i=ibondp_start,ibondp_end
6177 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6178 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6180 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6181 c & *dc(j,i-1)/vbld(i)
6183 c if (energy_dec) write(iout,*)
6184 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6186 C Checking if it involves dummy (NH3+ or COO-) group
6187 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6188 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
6189 diff = vbld(i)-vbldpDUM
6190 if (energy_dec) write(iout,*) "dum_bond",i,diff
6192 C NO vbldp0 is the equlibrium lenght of spring for peptide group
6193 diff = vbld(i)-vbldp0
6195 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6196 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6199 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6201 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6205 estr=0.5d0*AKP*estr+estr1
6207 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6209 do i=ibond_start,ibond_end
6211 if (iti.ne.10 .and. iti.ne.ntyp1) then
6214 diff=vbld(i+nres)-vbldsc0(1,iti)
6215 if (energy_dec) write (iout,*)
6216 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6217 & AKSC(1,iti),AKSC(1,iti)*diff*diff
6218 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6220 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6224 diff=vbld(i+nres)-vbldsc0(j,iti)
6225 ud(j)=aksc(j,iti)*diff
6226 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6240 uprod2=uprod2*u(k)*u(k)
6244 usumsqder=usumsqder+ud(j)*uprod2
6246 estr=estr+uprod/usum
6248 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6256 C--------------------------------------------------------------------------
6257 subroutine ebend(etheta)
6259 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6260 C angles gamma and its derivatives in consecutive thetas and gammas.
6262 implicit real*8 (a-h,o-z)
6263 include 'DIMENSIONS'
6264 include 'COMMON.LOCAL'
6265 include 'COMMON.GEO'
6266 include 'COMMON.INTERACT'
6267 include 'COMMON.DERIV'
6268 include 'COMMON.VAR'
6269 include 'COMMON.CHAIN'
6270 include 'COMMON.IOUNITS'
6271 include 'COMMON.NAMES'
6272 include 'COMMON.FFIELD'
6273 include 'COMMON.CONTROL'
6274 include 'COMMON.TORCNSTR'
6275 common /calcthet/ term1,term2,termm,diffak,ratak,
6276 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6277 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6278 double precision y(2),z(2)
6280 c time11=dexp(-2*time)
6283 c write (*,'(a,i2)') 'EBEND ICG=',icg
6284 do i=ithet_start,ithet_end
6285 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6286 & .or.itype(i).eq.ntyp1) cycle
6287 C Zero the energy function and its derivative at 0 or pi.
6288 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6290 ichir1=isign(1,itype(i-2))
6291 ichir2=isign(1,itype(i))
6292 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6293 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6294 if (itype(i-1).eq.10) then
6295 itype1=isign(10,itype(i-2))
6296 ichir11=isign(1,itype(i-2))
6297 ichir12=isign(1,itype(i-2))
6298 itype2=isign(10,itype(i))
6299 ichir21=isign(1,itype(i))
6300 ichir22=isign(1,itype(i))
6303 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6306 if (phii.ne.phii) phii=150.0
6316 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6319 if (phii1.ne.phii1) phii1=150.0
6331 C Calculate the "mean" value of theta from the part of the distribution
6332 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6333 C In following comments this theta will be referred to as t_c.
6334 thet_pred_mean=0.0d0
6336 athetk=athet(k,it,ichir1,ichir2)
6337 bthetk=bthet(k,it,ichir1,ichir2)
6339 athetk=athet(k,itype1,ichir11,ichir12)
6340 bthetk=bthet(k,itype2,ichir21,ichir22)
6342 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6343 c write(iout,*) 'chuj tu', y(k),z(k)
6345 dthett=thet_pred_mean*ssd
6346 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6347 C Derivatives of the "mean" values in gamma1 and gamma2.
6348 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6349 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6350 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6351 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6353 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6354 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6355 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6356 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6358 if (theta(i).gt.pi-delta) then
6359 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6361 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6362 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6363 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6365 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6367 else if (theta(i).lt.delta) then
6368 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6369 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6370 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6372 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6373 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6376 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6379 etheta=etheta+ethetai
6380 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6381 & 'ebend',i,ethetai,theta(i),itype(i)
6382 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6383 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6384 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6387 C Ufff.... We've done all this!!!
6390 C---------------------------------------------------------------------------
6391 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6393 implicit real*8 (a-h,o-z)
6394 include 'DIMENSIONS'
6395 include 'COMMON.LOCAL'
6396 include 'COMMON.IOUNITS'
6397 common /calcthet/ term1,term2,termm,diffak,ratak,
6398 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6399 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6400 C Calculate the contributions to both Gaussian lobes.
6401 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6402 C The "polynomial part" of the "standard deviation" of this part of
6403 C the distributioni.
6404 ccc write (iout,*) thetai,thet_pred_mean
6407 sig=sig*thet_pred_mean+polthet(j,it)
6409 C Derivative of the "interior part" of the "standard deviation of the"
6410 C gamma-dependent Gaussian lobe in t_c.
6411 sigtc=3*polthet(3,it)
6413 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6416 C Set the parameters of both Gaussian lobes of the distribution.
6417 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6418 fac=sig*sig+sigc0(it)
6421 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6422 sigsqtc=-4.0D0*sigcsq*sigtc
6423 c print *,i,sig,sigtc,sigsqtc
6424 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6425 sigtc=-sigtc/(fac*fac)
6426 C Following variable is sigma(t_c)**(-2)
6427 sigcsq=sigcsq*sigcsq
6429 sig0inv=1.0D0/sig0i**2
6430 delthec=thetai-thet_pred_mean
6431 delthe0=thetai-theta0i
6432 term1=-0.5D0*sigcsq*delthec*delthec
6433 term2=-0.5D0*sig0inv*delthe0*delthe0
6434 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6435 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6436 C NaNs in taking the logarithm. We extract the largest exponent which is added
6437 C to the energy (this being the log of the distribution) at the end of energy
6438 C term evaluation for this virtual-bond angle.
6439 if (term1.gt.term2) then
6441 term2=dexp(term2-termm)
6445 term1=dexp(term1-termm)
6448 C The ratio between the gamma-independent and gamma-dependent lobes of
6449 C the distribution is a Gaussian function of thet_pred_mean too.
6450 diffak=gthet(2,it)-thet_pred_mean
6451 ratak=diffak/gthet(3,it)**2
6452 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6453 C Let's differentiate it in thet_pred_mean NOW.
6455 C Now put together the distribution terms to make complete distribution.
6456 termexp=term1+ak*term2
6457 termpre=sigc+ak*sig0i
6458 C Contribution of the bending energy from this theta is just the -log of
6459 C the sum of the contributions from the two lobes and the pre-exponential
6460 C factor. Simple enough, isn't it?
6461 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6462 C write (iout,*) 'termexp',termexp,termm,termpre,i
6463 C NOW the derivatives!!!
6464 C 6/6/97 Take into account the deformation.
6465 E_theta=(delthec*sigcsq*term1
6466 & +ak*delthe0*sig0inv*term2)/termexp
6467 E_tc=((sigtc+aktc*sig0i)/termpre
6468 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6469 & aktc*term2)/termexp)
6472 c-----------------------------------------------------------------------------
6473 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6474 implicit real*8 (a-h,o-z)
6475 include 'DIMENSIONS'
6476 include 'COMMON.LOCAL'
6477 include 'COMMON.IOUNITS'
6478 common /calcthet/ term1,term2,termm,diffak,ratak,
6479 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6480 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6481 delthec=thetai-thet_pred_mean
6482 delthe0=thetai-theta0i
6483 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6484 t3 = thetai-thet_pred_mean
6488 t14 = t12+t6*sigsqtc
6490 t21 = thetai-theta0i
6496 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6497 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6498 & *(-t12*t9-ak*sig0inv*t27)
6502 C--------------------------------------------------------------------------
6503 subroutine ebend(etheta)
6505 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6506 C angles gamma and its derivatives in consecutive thetas and gammas.
6507 C ab initio-derived potentials from
6508 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6510 implicit real*8 (a-h,o-z)
6511 include 'DIMENSIONS'
6512 include 'COMMON.LOCAL'
6513 include 'COMMON.GEO'
6514 include 'COMMON.INTERACT'
6515 include 'COMMON.DERIV'
6516 include 'COMMON.VAR'
6517 include 'COMMON.CHAIN'
6518 include 'COMMON.IOUNITS'
6519 include 'COMMON.NAMES'
6520 include 'COMMON.FFIELD'
6521 include 'COMMON.CONTROL'
6522 include 'COMMON.TORCNSTR'
6523 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6524 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6525 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6526 & sinph1ph2(maxdouble,maxdouble)
6527 logical lprn /.false./, lprn1 /.false./
6529 do i=ithet_start,ithet_end
6530 c print *,i,itype(i-1),itype(i),itype(i-2)
6531 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6532 & .or.itype(i).eq.ntyp1) cycle
6533 C print *,i,theta(i)
6534 if (iabs(itype(i+1)).eq.20) iblock=2
6535 if (iabs(itype(i+1)).ne.20) iblock=1
6539 theti2=0.5d0*theta(i)
6540 ityp2=ithetyp((itype(i-1)))
6542 coskt(k)=dcos(k*theti2)
6543 sinkt(k)=dsin(k*theti2)
6546 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6549 if (phii.ne.phii) phii=150.0
6553 ityp1=ithetyp((itype(i-2)))
6554 C propagation of chirality for glycine type
6556 cosph1(k)=dcos(k*phii)
6557 sinph1(k)=dsin(k*phii)
6562 ityp1=ithetyp((itype(i-2)))
6567 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6570 if (phii1.ne.phii1) phii1=150.0
6575 ityp3=ithetyp((itype(i)))
6577 cosph2(k)=dcos(k*phii1)
6578 sinph2(k)=dsin(k*phii1)
6582 ityp3=ithetyp((itype(i)))
6588 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6591 ccl=cosph1(l)*cosph2(k-l)
6592 ssl=sinph1(l)*sinph2(k-l)
6593 scl=sinph1(l)*cosph2(k-l)
6594 csl=cosph1(l)*sinph2(k-l)
6595 cosph1ph2(l,k)=ccl-ssl
6596 cosph1ph2(k,l)=ccl+ssl
6597 sinph1ph2(l,k)=scl+csl
6598 sinph1ph2(k,l)=scl-csl
6602 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6603 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6604 write (iout,*) "coskt and sinkt"
6606 write (iout,*) k,coskt(k),sinkt(k)
6610 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6611 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6614 & write (iout,*) "k",k,"
6615 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6616 & " ethetai",ethetai
6619 write (iout,*) "cosph and sinph"
6621 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6623 write (iout,*) "cosph1ph2 and sinph2ph2"
6626 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6627 & sinph1ph2(l,k),sinph1ph2(k,l)
6630 write(iout,*) "ethetai",ethetai
6635 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6636 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6637 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6638 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6639 ethetai=ethetai+sinkt(m)*aux
6640 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6641 dephii=dephii+k*sinkt(m)*(
6642 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6643 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6644 dephii1=dephii1+k*sinkt(m)*(
6645 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6646 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6648 & write (iout,*) "m",m," k",k," bbthet",
6649 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6650 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6651 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6652 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6653 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6656 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6657 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6658 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6659 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6661 & write(iout,*) "ethetai",ethetai
6662 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6666 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6667 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6668 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6669 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6670 ethetai=ethetai+sinkt(m)*aux
6671 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6672 dephii=dephii+l*sinkt(m)*(
6673 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6674 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6675 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6676 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6677 dephii1=dephii1+(k-l)*sinkt(m)*(
6678 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6679 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6680 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6681 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6683 write (iout,*) "m",m," k",k," l",l," ffthet",
6684 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6685 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6686 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6687 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6688 & " ethetai",ethetai
6689 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6690 & cosph1ph2(k,l)*sinkt(m),
6691 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6700 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6701 & i,theta(i)*rad2deg,phii*rad2deg,
6702 & phii1*rad2deg,ethetai
6704 etheta=etheta+ethetai
6705 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6706 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6707 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6714 c-----------------------------------------------------------------------------
6715 subroutine esc(escloc)
6716 C Calculate the local energy of a side chain and its derivatives in the
6717 C corresponding virtual-bond valence angles THETA and the spherical angles
6719 implicit real*8 (a-h,o-z)
6720 include 'DIMENSIONS'
6721 include 'COMMON.GEO'
6722 include 'COMMON.LOCAL'
6723 include 'COMMON.VAR'
6724 include 'COMMON.INTERACT'
6725 include 'COMMON.DERIV'
6726 include 'COMMON.CHAIN'
6727 include 'COMMON.IOUNITS'
6728 include 'COMMON.NAMES'
6729 include 'COMMON.FFIELD'
6730 include 'COMMON.CONTROL'
6731 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6732 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6733 common /sccalc/ time11,time12,time112,theti,it,nlobit
6736 c write (iout,'(a)') 'ESC'
6737 do i=loc_start,loc_end
6739 if (it.eq.ntyp1) cycle
6740 if (it.eq.10) goto 1
6741 nlobit=nlob(iabs(it))
6742 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6743 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6744 theti=theta(i+1)-pipol
6749 if (x(2).gt.pi-delta) then
6753 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6755 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6756 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6758 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6759 & ddersc0(1),dersc(1))
6760 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6761 & ddersc0(3),dersc(3))
6763 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6765 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6766 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6767 & dersc0(2),esclocbi,dersc02)
6768 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6770 call splinthet(x(2),0.5d0*delta,ss,ssd)
6775 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6777 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6778 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6780 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6782 c write (iout,*) escloci
6783 else if (x(2).lt.delta) then
6787 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6789 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6790 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6792 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6793 & ddersc0(1),dersc(1))
6794 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6795 & ddersc0(3),dersc(3))
6797 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6799 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6800 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6801 & dersc0(2),esclocbi,dersc02)
6802 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6807 call splinthet(x(2),0.5d0*delta,ss,ssd)
6809 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6811 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6812 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6814 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6815 c write (iout,*) escloci
6817 call enesc(x,escloci,dersc,ddummy,.false.)
6820 escloc=escloc+escloci
6821 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6822 & 'escloc',i,escloci
6823 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6825 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6827 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6828 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6833 C---------------------------------------------------------------------------
6834 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6835 implicit real*8 (a-h,o-z)
6836 include 'DIMENSIONS'
6837 include 'COMMON.GEO'
6838 include 'COMMON.LOCAL'
6839 include 'COMMON.IOUNITS'
6840 common /sccalc/ time11,time12,time112,theti,it,nlobit
6841 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6842 double precision contr(maxlob,-1:1)
6844 c write (iout,*) 'it=',it,' nlobit=',nlobit
6848 if (mixed) ddersc(j)=0.0d0
6852 C Because of periodicity of the dependence of the SC energy in omega we have
6853 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6854 C To avoid underflows, first compute & store the exponents.
6862 z(k)=x(k)-censc(k,j,it)
6867 Axk=Axk+gaussc(l,k,j,it)*z(l)
6873 expfac=expfac+Ax(k,j,iii)*z(k)
6881 C As in the case of ebend, we want to avoid underflows in exponentiation and
6882 C subsequent NaNs and INFs in energy calculation.
6883 C Find the largest exponent
6887 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6891 cd print *,'it=',it,' emin=',emin
6893 C Compute the contribution to SC energy and derivatives
6898 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6899 if(adexp.ne.adexp) adexp=1.0
6902 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6904 cd print *,'j=',j,' expfac=',expfac
6905 escloc_i=escloc_i+expfac
6907 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6911 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6912 & +gaussc(k,2,j,it))*expfac
6919 dersc(1)=dersc(1)/cos(theti)**2
6920 ddersc(1)=ddersc(1)/cos(theti)**2
6923 escloci=-(dlog(escloc_i)-emin)
6925 dersc(j)=dersc(j)/escloc_i
6929 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6934 C------------------------------------------------------------------------------
6935 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6936 implicit real*8 (a-h,o-z)
6937 include 'DIMENSIONS'
6938 include 'COMMON.GEO'
6939 include 'COMMON.LOCAL'
6940 include 'COMMON.IOUNITS'
6941 common /sccalc/ time11,time12,time112,theti,it,nlobit
6942 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6943 double precision contr(maxlob)
6954 z(k)=x(k)-censc(k,j,it)
6960 Axk=Axk+gaussc(l,k,j,it)*z(l)
6966 expfac=expfac+Ax(k,j)*z(k)
6971 C As in the case of ebend, we want to avoid underflows in exponentiation and
6972 C subsequent NaNs and INFs in energy calculation.
6973 C Find the largest exponent
6976 if (emin.gt.contr(j)) emin=contr(j)
6980 C Compute the contribution to SC energy and derivatives
6984 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6985 escloc_i=escloc_i+expfac
6987 dersc(k)=dersc(k)+Ax(k,j)*expfac
6989 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6990 & +gaussc(1,2,j,it))*expfac
6994 dersc(1)=dersc(1)/cos(theti)**2
6995 dersc12=dersc12/cos(theti)**2
6996 escloci=-(dlog(escloc_i)-emin)
6998 dersc(j)=dersc(j)/escloc_i
7000 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7004 c----------------------------------------------------------------------------------
7005 subroutine esc(escloc)
7006 C Calculate the local energy of a side chain and its derivatives in the
7007 C corresponding virtual-bond valence angles THETA and the spherical angles
7008 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7009 C added by Urszula Kozlowska. 07/11/2007
7011 implicit real*8 (a-h,o-z)
7012 include 'DIMENSIONS'
7013 include 'COMMON.GEO'
7014 include 'COMMON.LOCAL'
7015 include 'COMMON.VAR'
7016 include 'COMMON.SCROT'
7017 include 'COMMON.INTERACT'
7018 include 'COMMON.DERIV'
7019 include 'COMMON.CHAIN'
7020 include 'COMMON.IOUNITS'
7021 include 'COMMON.NAMES'
7022 include 'COMMON.FFIELD'
7023 include 'COMMON.CONTROL'
7024 include 'COMMON.VECTORS'
7025 double precision x_prime(3),y_prime(3),z_prime(3)
7026 & , sumene,dsc_i,dp2_i,x(65),
7027 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7028 & de_dxx,de_dyy,de_dzz,de_dt
7029 double precision s1_t,s1_6_t,s2_t,s2_6_t
7031 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7032 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7033 & dt_dCi(3),dt_dCi1(3)
7034 common /sccalc/ time11,time12,time112,theti,it,nlobit
7037 do i=loc_start,loc_end
7038 if (itype(i).eq.ntyp1) cycle
7039 costtab(i+1) =dcos(theta(i+1))
7040 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7041 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7042 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7043 cosfac2=0.5d0/(1.0d0+costtab(i+1))
7044 cosfac=dsqrt(cosfac2)
7045 sinfac2=0.5d0/(1.0d0-costtab(i+1))
7046 sinfac=dsqrt(sinfac2)
7048 if (it.eq.10) goto 1
7050 C Compute the axes of tghe local cartesian coordinates system; store in
7051 c x_prime, y_prime and z_prime
7058 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7059 C & dc_norm(3,i+nres)
7061 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7062 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7065 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7068 c write (2,*) "x_prime",(x_prime(j),j=1,3)
7069 c write (2,*) "y_prime",(y_prime(j),j=1,3)
7070 c write (2,*) "z_prime",(z_prime(j),j=1,3)
7071 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7072 c & " xy",scalar(x_prime(1),y_prime(1)),
7073 c & " xz",scalar(x_prime(1),z_prime(1)),
7074 c & " yy",scalar(y_prime(1),y_prime(1)),
7075 c & " yz",scalar(y_prime(1),z_prime(1)),
7076 c & " zz",scalar(z_prime(1),z_prime(1))
7078 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7079 C to local coordinate system. Store in xx, yy, zz.
7085 xx = xx + x_prime(j)*dc_norm(j,i+nres)
7086 yy = yy + y_prime(j)*dc_norm(j,i+nres)
7087 zz = zz + z_prime(j)*dc_norm(j,i+nres)
7094 C Compute the energy of the ith side cbain
7096 c write (2,*) "xx",xx," yy",yy," zz",zz
7099 x(j) = sc_parmin(j,it)
7102 Cc diagnostics - remove later
7104 yy1 = dsin(alph(2))*dcos(omeg(2))
7105 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7106 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7107 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7109 C," --- ", xx_w,yy_w,zz_w
7112 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7113 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7115 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7116 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7118 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7119 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7120 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7121 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7122 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7124 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7125 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7126 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7127 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7128 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7130 dsc_i = 0.743d0+x(61)
7132 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7133 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7134 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7135 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7136 s1=(1+x(63))/(0.1d0 + dscp1)
7137 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7138 s2=(1+x(65))/(0.1d0 + dscp2)
7139 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7140 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7141 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7142 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7144 c & dscp1,dscp2,sumene
7145 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7146 escloc = escloc + sumene
7147 c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7152 C This section to check the numerical derivatives of the energy of ith side
7153 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7154 C #define DEBUG in the code to turn it on.
7156 write (2,*) "sumene =",sumene
7160 write (2,*) xx,yy,zz
7161 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7162 de_dxx_num=(sumenep-sumene)/aincr
7164 write (2,*) "xx+ sumene from enesc=",sumenep
7167 write (2,*) xx,yy,zz
7168 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7169 de_dyy_num=(sumenep-sumene)/aincr
7171 write (2,*) "yy+ sumene from enesc=",sumenep
7174 write (2,*) xx,yy,zz
7175 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7176 de_dzz_num=(sumenep-sumene)/aincr
7178 write (2,*) "zz+ sumene from enesc=",sumenep
7179 costsave=cost2tab(i+1)
7180 sintsave=sint2tab(i+1)
7181 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7182 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7183 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7184 de_dt_num=(sumenep-sumene)/aincr
7185 write (2,*) " t+ sumene from enesc=",sumenep
7186 cost2tab(i+1)=costsave
7187 sint2tab(i+1)=sintsave
7188 C End of diagnostics section.
7191 C Compute the gradient of esc
7193 c zz=zz*dsign(1.0,dfloat(itype(i)))
7194 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7195 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7196 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7197 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7198 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7199 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7200 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7201 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7202 pom1=(sumene3*sint2tab(i+1)+sumene1)
7203 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7204 pom2=(sumene4*cost2tab(i+1)+sumene2)
7205 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7206 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7207 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7208 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7210 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7211 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7212 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7214 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7215 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7216 & +(pom1+pom2)*pom_dx
7218 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7221 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7222 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7223 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7225 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7226 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7227 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7228 & +x(59)*zz**2 +x(60)*xx*zz
7229 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7230 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7231 & +(pom1-pom2)*pom_dy
7233 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7236 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7237 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7238 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7239 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7240 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7241 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7242 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7243 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7245 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7248 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7249 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7250 & +pom1*pom_dt1+pom2*pom_dt2
7252 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7257 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7258 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7259 cosfac2xx=cosfac2*xx
7260 sinfac2yy=sinfac2*yy
7262 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7264 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7266 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7267 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7268 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7269 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7270 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7271 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7272 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7273 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7274 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7275 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7279 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7280 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7281 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7282 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7285 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7286 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7287 dZZ_XYZ(k)=vbld_inv(i+nres)*
7288 & (z_prime(k)-zz*dC_norm(k,i+nres))
7290 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7291 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7295 dXX_Ctab(k,i)=dXX_Ci(k)
7296 dXX_C1tab(k,i)=dXX_Ci1(k)
7297 dYY_Ctab(k,i)=dYY_Ci(k)
7298 dYY_C1tab(k,i)=dYY_Ci1(k)
7299 dZZ_Ctab(k,i)=dZZ_Ci(k)
7300 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7301 dXX_XYZtab(k,i)=dXX_XYZ(k)
7302 dYY_XYZtab(k,i)=dYY_XYZ(k)
7303 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7307 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7308 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7309 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7310 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7311 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7313 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7314 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7315 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7316 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7317 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7318 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7319 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7320 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7322 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7323 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7325 C to check gradient call subroutine check_grad
7331 c------------------------------------------------------------------------------
7332 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7334 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7335 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7336 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7337 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7339 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7340 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7342 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7343 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7344 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7345 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7346 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7348 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7349 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7350 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7351 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7352 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7354 dsc_i = 0.743d0+x(61)
7356 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7357 & *(xx*cost2+yy*sint2))
7358 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7359 & *(xx*cost2-yy*sint2))
7360 s1=(1+x(63))/(0.1d0 + dscp1)
7361 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7362 s2=(1+x(65))/(0.1d0 + dscp2)
7363 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7364 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7365 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7370 c------------------------------------------------------------------------------
7371 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7373 C This procedure calculates two-body contact function g(rij) and its derivative:
7376 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7379 C where x=(rij-r0ij)/delta
7381 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7384 double precision rij,r0ij,eps0ij,fcont,fprimcont
7385 double precision x,x2,x4,delta
7389 if (x.lt.-1.0D0) then
7392 else if (x.le.1.0D0) then
7395 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7396 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7403 c------------------------------------------------------------------------------
7404 subroutine splinthet(theti,delta,ss,ssder)
7405 implicit real*8 (a-h,o-z)
7406 include 'DIMENSIONS'
7407 include 'COMMON.VAR'
7408 include 'COMMON.GEO'
7411 if (theti.gt.pipol) then
7412 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7414 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7419 c------------------------------------------------------------------------------
7420 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7422 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7423 double precision ksi,ksi2,ksi3,a1,a2,a3
7424 a1=fprim0*delta/(f1-f0)
7430 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7431 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7434 c------------------------------------------------------------------------------
7435 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7437 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7438 double precision ksi,ksi2,ksi3,a1,a2,a3
7443 a2=3*(f1x-f0x)-2*fprim0x*delta
7444 a3=fprim0x*delta-2*(f1x-f0x)
7445 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7448 C-----------------------------------------------------------------------------
7450 C-----------------------------------------------------------------------------
7451 subroutine etor(etors)
7452 implicit real*8 (a-h,o-z)
7453 include 'DIMENSIONS'
7454 include 'COMMON.VAR'
7455 include 'COMMON.GEO'
7456 include 'COMMON.LOCAL'
7457 include 'COMMON.TORSION'
7458 include 'COMMON.INTERACT'
7459 include 'COMMON.DERIV'
7460 include 'COMMON.CHAIN'
7461 include 'COMMON.NAMES'
7462 include 'COMMON.IOUNITS'
7463 include 'COMMON.FFIELD'
7464 include 'COMMON.TORCNSTR'
7465 include 'COMMON.CONTROL'
7467 C Set lprn=.true. for debugging
7471 do i=iphi_start,iphi_end
7473 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7474 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7475 itori=itortyp(itype(i-2))
7476 itori1=itortyp(itype(i-1))
7479 C Proline-Proline pair is a special case...
7480 if (itori.eq.3 .and. itori1.eq.3) then
7481 if (phii.gt.-dwapi3) then
7483 fac=1.0D0/(1.0D0-cosphi)
7484 etorsi=v1(1,3,3)*fac
7485 etorsi=etorsi+etorsi
7486 etors=etors+etorsi-v1(1,3,3)
7487 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7488 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7491 v1ij=v1(j+1,itori,itori1)
7492 v2ij=v2(j+1,itori,itori1)
7495 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7496 if (energy_dec) etors_ii=etors_ii+
7497 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7498 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7502 v1ij=v1(j,itori,itori1)
7503 v2ij=v2(j,itori,itori1)
7506 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7507 if (energy_dec) etors_ii=etors_ii+
7508 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7509 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7512 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7515 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7516 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7517 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7518 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7519 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7523 c------------------------------------------------------------------------------
7524 subroutine etor_d(etors_d)
7528 c----------------------------------------------------------------------------
7529 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7530 subroutine e_modeller(ehomology_constr)
7531 ehomology_constr=0.0d0
7532 write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7535 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7537 c------------------------------------------------------------------------------
7538 subroutine etor_d(etors_d)
7542 c----------------------------------------------------------------------------
7544 subroutine etor(etors)
7545 implicit real*8 (a-h,o-z)
7546 include 'DIMENSIONS'
7547 include 'COMMON.VAR'
7548 include 'COMMON.GEO'
7549 include 'COMMON.LOCAL'
7550 include 'COMMON.TORSION'
7551 include 'COMMON.INTERACT'
7552 include 'COMMON.DERIV'
7553 include 'COMMON.CHAIN'
7554 include 'COMMON.NAMES'
7555 include 'COMMON.IOUNITS'
7556 include 'COMMON.FFIELD'
7557 include 'COMMON.TORCNSTR'
7558 include 'COMMON.CONTROL'
7560 C Set lprn=.true. for debugging
7564 do i=iphi_start,iphi_end
7565 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7566 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7567 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7568 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7569 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7570 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7571 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7572 C For introducing the NH3+ and COO- group please check the etor_d for reference
7575 if (iabs(itype(i)).eq.20) then
7580 itori=itortyp(itype(i-2))
7581 itori1=itortyp(itype(i-1))
7584 C Regular cosine and sine terms
7585 do j=1,nterm(itori,itori1,iblock)
7586 v1ij=v1(j,itori,itori1,iblock)
7587 v2ij=v2(j,itori,itori1,iblock)
7590 etors=etors+v1ij*cosphi+v2ij*sinphi
7591 if (energy_dec) etors_ii=etors_ii+
7592 & v1ij*cosphi+v2ij*sinphi
7593 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7597 C E = SUM ----------------------------------- - v1
7598 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7600 cosphi=dcos(0.5d0*phii)
7601 sinphi=dsin(0.5d0*phii)
7602 do j=1,nlor(itori,itori1,iblock)
7603 vl1ij=vlor1(j,itori,itori1)
7604 vl2ij=vlor2(j,itori,itori1)
7605 vl3ij=vlor3(j,itori,itori1)
7606 pom=vl2ij*cosphi+vl3ij*sinphi
7607 pom1=1.0d0/(pom*pom+1.0d0)
7608 etors=etors+vl1ij*pom1
7609 if (energy_dec) etors_ii=etors_ii+
7612 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7614 C Subtract the constant term
7615 etors=etors-v0(itori,itori1,iblock)
7616 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7617 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7619 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7620 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7621 & (v1(j,itori,itori1,iblock),j=1,6),
7622 & (v2(j,itori,itori1,iblock),j=1,6)
7623 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7624 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7628 c----------------------------------------------------------------------------
7629 subroutine etor_d(etors_d)
7630 C 6/23/01 Compute double torsional energy
7631 implicit real*8 (a-h,o-z)
7632 include 'DIMENSIONS'
7633 include 'COMMON.VAR'
7634 include 'COMMON.GEO'
7635 include 'COMMON.LOCAL'
7636 include 'COMMON.TORSION'
7637 include 'COMMON.INTERACT'
7638 include 'COMMON.DERIV'
7639 include 'COMMON.CHAIN'
7640 include 'COMMON.NAMES'
7641 include 'COMMON.IOUNITS'
7642 include 'COMMON.FFIELD'
7643 include 'COMMON.TORCNSTR'
7645 C Set lprn=.true. for debugging
7649 c write(iout,*) "a tu??"
7650 do i=iphid_start,iphid_end
7651 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7652 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7653 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7654 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7655 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7656 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7657 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7658 & (itype(i+1).eq.ntyp1)) cycle
7659 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7660 itori=itortyp(itype(i-2))
7661 itori1=itortyp(itype(i-1))
7662 itori2=itortyp(itype(i))
7668 if (iabs(itype(i+1)).eq.20) iblock=2
7669 C Iblock=2 Proline type
7670 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7671 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7672 C if (itype(i+1).eq.ntyp1) iblock=3
7673 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7674 C IS or IS NOT need for this
7675 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7676 C is (itype(i-3).eq.ntyp1) ntblock=2
7677 C ntblock is N-terminal blocking group
7679 C Regular cosine and sine terms
7680 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7681 C Example of changes for NH3+ blocking group
7682 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7683 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7684 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7685 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7686 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7687 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7688 cosphi1=dcos(j*phii)
7689 sinphi1=dsin(j*phii)
7690 cosphi2=dcos(j*phii1)
7691 sinphi2=dsin(j*phii1)
7692 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7693 & v2cij*cosphi2+v2sij*sinphi2
7694 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7695 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7697 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7699 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7700 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7701 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7702 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7703 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7704 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7705 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7706 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7707 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7708 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7709 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7710 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7711 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7712 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7715 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7716 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7721 C----------------------------------------------------------------------------------
7722 C The rigorous attempt to derive energy function
7723 subroutine etor_kcc(etors)
7724 implicit real*8 (a-h,o-z)
7725 include 'DIMENSIONS'
7726 include 'COMMON.VAR'
7727 include 'COMMON.GEO'
7728 include 'COMMON.LOCAL'
7729 include 'COMMON.TORSION'
7730 include 'COMMON.INTERACT'
7731 include 'COMMON.DERIV'
7732 include 'COMMON.CHAIN'
7733 include 'COMMON.NAMES'
7734 include 'COMMON.IOUNITS'
7735 include 'COMMON.FFIELD'
7736 include 'COMMON.TORCNSTR'
7737 include 'COMMON.CONTROL'
7738 double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7740 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7741 C Set lprn=.true. for debugging
7744 C print *,"wchodze kcc"
7745 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7747 do i=iphi_start,iphi_end
7748 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7749 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7750 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7751 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7752 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7753 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7754 itori=itortyp(itype(i-2))
7755 itori1=itortyp(itype(i-1))
7760 C to avoid multiple devision by 2
7761 c theti22=0.5d0*theta(i)
7762 C theta 12 is the theta_1 /2
7763 C theta 22 is theta_2 /2
7764 c theti12=0.5d0*theta(i-1)
7765 C and appropriate sinus function
7766 sinthet1=dsin(theta(i-1))
7767 sinthet2=dsin(theta(i))
7768 costhet1=dcos(theta(i-1))
7769 costhet2=dcos(theta(i))
7770 C to speed up lets store its mutliplication
7771 sint1t2=sinthet2*sinthet1
7773 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7774 C +d_n*sin(n*gamma)) *
7775 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7776 C we have two sum 1) Non-Chebyshev which is with n and gamma
7777 nval=nterm_kcc_Tb(itori,itori1)
7783 c1(j)=c1(j-1)*costhet1
7784 c2(j)=c2(j-1)*costhet2
7787 do j=1,nterm_kcc(itori,itori1)
7791 sint1t2n=sint1t2n*sint1t2
7797 sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7798 gradvalct1=gradvalct1+
7799 & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7800 gradvalct2=gradvalct2+
7801 & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7804 gradvalct1=-gradvalct1*sinthet1
7805 gradvalct2=-gradvalct2*sinthet2
7811 sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7812 gradvalst1=gradvalst1+
7813 & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7814 gradvalst2=gradvalst2+
7815 & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7818 gradvalst1=-gradvalst1*sinthet1
7819 gradvalst2=-gradvalst2*sinthet2
7820 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7821 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7822 C glocig is the gradient local i site in gamma
7823 glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7824 C now gradient over theta_1
7825 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7826 & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7827 glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7828 & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7831 C derivative over gamma
7832 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7833 C derivative over theta1
7834 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7835 C now derivative over theta2
7836 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7838 write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7839 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7840 write (iout,*) "c1",(c1(k),k=0,nval),
7841 & " c2",(c2(k),k=0,nval)
7846 c---------------------------------------------------------------------------------------------
7847 subroutine etor_constr(edihcnstr)
7848 implicit real*8 (a-h,o-z)
7849 include 'DIMENSIONS'
7850 include 'COMMON.VAR'
7851 include 'COMMON.GEO'
7852 include 'COMMON.LOCAL'
7853 include 'COMMON.TORSION'
7854 include 'COMMON.INTERACT'
7855 include 'COMMON.DERIV'
7856 include 'COMMON.CHAIN'
7857 include 'COMMON.NAMES'
7858 include 'COMMON.IOUNITS'
7859 include 'COMMON.FFIELD'
7860 include 'COMMON.TORCNSTR'
7861 include 'COMMON.BOUNDS'
7862 include 'COMMON.CONTROL'
7863 ! 6/20/98 - dihedral angle constraints
7865 c do i=1,ndih_constr
7866 if (raw_psipred) then
7867 do i=idihconstr_start,idihconstr_end
7868 itori=idih_constr(i)
7870 gaudih_i=vpsipred(1,i)
7874 cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7875 dexpcos_i=dexp(-cos_i*cos_i)
7876 gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7877 gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7878 & *cos_i*dexpcos_i/s**2
7880 edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7881 gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7883 & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7884 & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7885 & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7886 & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7887 & -wdihc*dlog(gaudih_i)
7891 do i=idihconstr_start,idihconstr_end
7892 itori=idih_constr(i)
7894 difi=pinorm(phii-phi0(i))
7895 if (difi.gt.drange(i)) then
7897 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7898 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7899 else if (difi.lt.-drange(i)) then
7901 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7902 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7912 c----------------------------------------------------------------------------
7913 c MODELLER restraint function
7914 subroutine e_modeller(ehomology_constr)
7916 include 'DIMENSIONS'
7918 double precision ehomology_constr
7919 integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7920 integer katy, odleglosci, test7
7921 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7923 real*8 distance(max_template),distancek(max_template),
7924 & min_odl,godl(max_template),dih_diff(max_template)
7927 c FP - 30/10/2014 Temporary specifications for homology restraints
7929 double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7931 double precision, dimension (maxres) :: guscdiff,usc_diff
7932 double precision, dimension (max_template) ::
7933 & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7935 double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7936 & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7937 & betai,sum_sgodl,dij
7938 double precision dist,pinorm
7940 include 'COMMON.SBRIDGE'
7941 include 'COMMON.CHAIN'
7942 include 'COMMON.GEO'
7943 include 'COMMON.DERIV'
7944 include 'COMMON.LOCAL'
7945 include 'COMMON.INTERACT'
7946 include 'COMMON.VAR'
7947 include 'COMMON.IOUNITS'
7948 c include 'COMMON.MD'
7949 include 'COMMON.CONTROL'
7950 include 'COMMON.HOMOLOGY'
7951 include 'COMMON.QRESTR'
7953 c From subroutine Econstr_back
7955 include 'COMMON.NAMES'
7956 include 'COMMON.TIME1'
7961 distancek(i)=9999999.9
7967 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7969 C AL 5/2/14 - Introduce list of restraints
7970 c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7972 write(iout,*) "------- dist restrs start -------"
7974 do ii = link_start_homo,link_end_homo
7978 c write (iout,*) "dij(",i,j,") =",dij
7980 do k=1,constr_homology
7981 c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7982 if(.not.l_homo(k,ii)) then
7986 distance(k)=odl(k,ii)-dij
7987 c write (iout,*) "distance(",k,") =",distance(k)
7989 c For Gaussian-type Urestr
7991 distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7992 c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7993 c write (iout,*) "distancek(",k,") =",distancek(k)
7994 c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7996 c For Lorentzian-type Urestr
7998 if (waga_dist.lt.0.0d0) then
7999 sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8000 distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8001 & (distance(k)**2+sigma_odlir(k,ii)**2))
8005 c min_odl=minval(distancek)
8006 do kk=1,constr_homology
8007 if(l_homo(kk,ii)) then
8008 min_odl=distancek(kk)
8012 do kk=1,constr_homology
8013 if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8014 & min_odl=distancek(kk)
8017 c write (iout,* )"min_odl",min_odl
8019 write (iout,*) "ij dij",i,j,dij
8020 write (iout,*) "distance",(distance(k),k=1,constr_homology)
8021 write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8022 write (iout,* )"min_odl",min_odl
8027 if (waga_dist.ge.0.0d0) then
8033 do k=1,constr_homology
8034 c Nie wiem po co to liczycie jeszcze raz!
8035 c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8036 c & (2*(sigma_odl(i,j,k))**2))
8037 if(.not.l_homo(k,ii)) cycle
8038 if (waga_dist.ge.0.0d0) then
8040 c For Gaussian-type Urestr
8042 godl(k)=dexp(-distancek(k)+min_odl)
8043 odleg2=odleg2+godl(k)
8045 c For Lorentzian-type Urestr
8048 odleg2=odleg2+distancek(k)
8051 ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8052 ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8053 ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8054 ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8057 c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8058 c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8060 write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8061 write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8063 if (waga_dist.ge.0.0d0) then
8065 c For Gaussian-type Urestr
8067 odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8069 c For Lorentzian-type Urestr
8072 odleg=odleg+odleg2/constr_homology
8075 c write (iout,*) "odleg",odleg ! sum of -ln-s
8078 c For Gaussian-type Urestr
8080 if (waga_dist.ge.0.0d0) sum_godl=odleg2
8082 do k=1,constr_homology
8083 c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8084 c & *waga_dist)+min_odl
8085 c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8087 if(.not.l_homo(k,ii)) cycle
8088 if (waga_dist.ge.0.0d0) then
8089 c For Gaussian-type Urestr
8091 sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8093 c For Lorentzian-type Urestr
8096 sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8097 & sigma_odlir(k,ii)**2)**2)
8099 sum_sgodl=sum_sgodl+sgodl
8101 c sgodl2=sgodl2+sgodl
8102 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8103 c write(iout,*) "constr_homology=",constr_homology
8104 c write(iout,*) i, j, k, "TEST K"
8106 if (waga_dist.ge.0.0d0) then
8108 c For Gaussian-type Urestr
8110 grad_odl3=waga_homology(iset)*waga_dist
8111 & *sum_sgodl/(sum_godl*dij)
8113 c For Lorentzian-type Urestr
8116 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8117 c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8118 grad_odl3=-waga_homology(iset)*waga_dist*
8119 & sum_sgodl/(constr_homology*dij)
8122 c grad_odl3=sum_sgodl/(sum_godl*dij)
8125 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8126 c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8127 c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8129 ccc write(iout,*) godl, sgodl, grad_odl3
8131 c grad_odl=grad_odl+grad_odl3
8134 ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8135 ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8136 ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8137 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8138 ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8139 ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8140 ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8141 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8142 c if (i.eq.25.and.j.eq.27) then
8143 c write(iout,*) "jik",jik,"i",i,"j",j
8144 c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8145 c write(iout,*) "grad_odl3",grad_odl3
8146 c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8147 c write(iout,*) "ggodl",ggodl
8148 c write(iout,*) "ghpbc(",jik,i,")",
8149 c & ghpbc(jik,i),"ghpbc(",jik,j,")",
8153 ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8154 ccc & dLOG(odleg2),"-odleg=", -odleg
8156 enddo ! ii-loop for dist
8158 write(iout,*) "------- dist restrs end -------"
8159 c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8160 c & waga_d.eq.1.0d0) call sum_gradient
8162 c Pseudo-energy and gradient from dihedral-angle restraints from
8163 c homology templates
8164 c write (iout,*) "End of distance loop"
8167 c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8169 write(iout,*) "------- dih restrs start -------"
8170 do i=idihconstr_start_homo,idihconstr_end_homo
8171 write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8174 do i=idihconstr_start_homo,idihconstr_end_homo
8176 c betai=beta(i,i+1,i+2,i+3)
8178 c write (iout,*) "betai =",betai
8179 do k=1,constr_homology
8180 dih_diff(k)=pinorm(dih(k,i)-betai)
8181 cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8182 cd & ,sigma_dih(k,i)
8183 c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8184 c & -(6.28318-dih_diff(i,k))
8185 c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8186 c & 6.28318+dih_diff(i,k)
8188 kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8190 kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8192 c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8195 c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8198 c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8199 c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8201 write (iout,*) "i",i," betai",betai," kat2",kat2
8202 write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8204 if (kat2.le.1.0d-14) cycle
8205 kat=kat-dLOG(kat2/constr_homology)
8206 c write (iout,*) "kat",kat ! sum of -ln-s
8208 ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8209 ccc & dLOG(kat2), "-kat=", -kat
8211 c ----------------------------------------------------------------------
8213 c ----------------------------------------------------------------------
8217 do k=1,constr_homology
8219 sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
8221 sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd
8223 c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8224 sum_sgdih=sum_sgdih+sgdih
8226 c grad_dih3=sum_sgdih/sum_gdih
8227 grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8229 c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8230 ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8231 ccc & gloc(nphi+i-3,icg)
8232 gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8234 c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8236 ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8237 ccc & gloc(nphi+i-3,icg)
8239 enddo ! i-loop for dih
8241 write(iout,*) "------- dih restrs end -------"
8244 c Pseudo-energy and gradient for theta angle restraints from
8245 c homology templates
8246 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8250 c For constr_homology reference structures (FP)
8252 c Uconst_back_tot=0.0d0
8255 c Econstr_back legacy
8257 c do i=ithet_start,ithet_end
8260 c do i=loc_start,loc_end
8263 duscdiffx(j,i)=0.0d0
8268 c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8269 c write (iout,*) "waga_theta",waga_theta
8270 if (waga_theta.gt.0.0d0) then
8272 write (iout,*) "usampl",usampl
8273 write(iout,*) "------- theta restrs start -------"
8274 c do i=ithet_start,ithet_end
8275 c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8278 c write (iout,*) "maxres",maxres,"nres",nres
8280 do i=ithet_start,ithet_end
8283 c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8285 c Deviation of theta angles wrt constr_homology ref structures
8287 utheta_i=0.0d0 ! argument of Gaussian for single k
8288 gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8289 c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8290 c over residues in a fragment
8291 c write (iout,*) "theta(",i,")=",theta(i)
8292 do k=1,constr_homology
8294 c dtheta_i=theta(j)-thetaref(j,iref)
8295 c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8296 theta_diff(k)=thetatpl(k,i)-theta(i)
8297 cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8298 cd & ,sigma_theta(k,i)
8301 utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8302 c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8303 gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8304 gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk)
8305 c Gradient for single Gaussian restraint in subr Econstr_back
8306 c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8309 c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8310 c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8313 c Gradient for multiple Gaussian restraint
8314 sum_gtheta=gutheta_i
8316 do k=1,constr_homology
8317 c New generalized expr for multiple Gaussian from Econstr_back
8318 sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8320 c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8321 sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8323 c Final value of gradient using same var as in Econstr_back
8324 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8325 & +sum_sgtheta/sum_gtheta*waga_theta
8326 & *waga_homology(iset)
8327 c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8328 c & *waga_homology(iset)
8329 c dutheta(i)=sum_sgtheta/sum_gtheta
8331 c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8332 Eval=Eval-dLOG(gutheta_i/constr_homology)
8333 c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8334 c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8335 c Uconst_back=Uconst_back+utheta(i)
8336 enddo ! (i-loop for theta)
8338 write(iout,*) "------- theta restrs end -------"
8342 c Deviation of local SC geometry
8344 c Separation of two i-loops (instructed by AL - 11/3/2014)
8346 c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8347 c write (iout,*) "waga_d",waga_d
8350 write(iout,*) "------- SC restrs start -------"
8351 write (iout,*) "Initial duscdiff,duscdiffx"
8352 do i=loc_start,loc_end
8353 write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8354 & (duscdiffx(jik,i),jik=1,3)
8357 do i=loc_start,loc_end
8358 usc_diff_i=0.0d0 ! argument of Gaussian for single k
8359 guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8360 c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8361 c write(iout,*) "xxtab, yytab, zztab"
8362 c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8363 do k=1,constr_homology
8365 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8366 c Original sign inverted for calc of gradients (s. Econstr_back)
8367 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8368 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8369 c write(iout,*) "dxx, dyy, dzz"
8370 cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8372 usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
8373 c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8374 c uscdiffk(k)=usc_diff(i)
8375 guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8376 c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8377 c & " guscdiff2",guscdiff2(k)
8378 guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk)
8379 c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8380 c & xxref(j),yyref(j),zzref(j)
8385 c Generalized expression for multiple Gaussian acc to that for a single
8386 c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8388 c Original implementation
8389 c sum_guscdiff=guscdiff(i)
8391 c sum_sguscdiff=0.0d0
8392 c do k=1,constr_homology
8393 c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8394 c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8395 c sum_sguscdiff=sum_sguscdiff+sguscdiff
8398 c Implementation of new expressions for gradient (Jan. 2015)
8400 c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8401 do k=1,constr_homology
8403 c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8404 c before. Now the drivatives should be correct
8406 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8407 c Original sign inverted for calc of gradients (s. Econstr_back)
8408 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8409 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8411 c New implementation
8413 sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8414 & sigma_d(k,i) ! for the grad wrt r'
8415 c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8418 c New implementation
8419 sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8421 duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8422 & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8423 & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8424 duscdiff(jik,i)=duscdiff(jik,i)+
8425 & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8426 & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8427 duscdiffx(jik,i)=duscdiffx(jik,i)+
8428 & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8429 & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8432 write(iout,*) "jik",jik,"i",i
8433 write(iout,*) "dxx, dyy, dzz"
8434 write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8435 write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8436 c write(iout,*) "sum_sguscdiff",sum_sguscdiff
8437 cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8438 c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8439 c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8440 c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8441 c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8442 c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8443 c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8444 c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8445 c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8446 c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8447 c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8448 c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8454 c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
8455 c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8457 c write (iout,*) i," uscdiff",uscdiff(i)
8459 c Put together deviations from local geometry
8461 c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8462 c & wfrag_back(3,i,iset)*uscdiff(i)
8463 Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8464 c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8465 c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8466 c Uconst_back=Uconst_back+usc_diff(i)
8468 c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8470 c New implment: multiplied by sum_sguscdiff
8473 enddo ! (i-loop for dscdiff)
8478 write(iout,*) "------- SC restrs end -------"
8479 write (iout,*) "------ After SC loop in e_modeller ------"
8480 do i=loc_start,loc_end
8481 write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8482 write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8484 if (waga_theta.eq.1.0d0) then
8485 write (iout,*) "in e_modeller after SC restr end: dutheta"
8486 do i=ithet_start,ithet_end
8487 write (iout,*) i,dutheta(i)
8490 if (waga_d.eq.1.0d0) then
8491 write (iout,*) "e_modeller after SC loop: duscdiff/x"
8493 write (iout,*) i,(duscdiff(j,i),j=1,3)
8494 write (iout,*) i,(duscdiffx(j,i),j=1,3)
8499 c Total energy from homology restraints
8501 write (iout,*) "odleg",odleg," kat",kat
8504 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8506 c ehomology_constr=odleg+kat
8508 c For Lorentzian-type Urestr
8511 if (waga_dist.ge.0.0d0) then
8513 c For Gaussian-type Urestr
8515 ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8516 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8517 c write (iout,*) "ehomology_constr=",ehomology_constr
8520 c For Lorentzian-type Urestr
8522 ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8523 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8524 c write (iout,*) "ehomology_constr=",ehomology_constr
8527 write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8528 & "Eval",waga_theta,eval,
8529 & "Erot",waga_d,Erot
8530 write (iout,*) "ehomology_constr",ehomology_constr
8536 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8537 747 format(a12,i4,i4,i4,f8.3,f8.3)
8538 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8539 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8540 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8541 & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8543 c----------------------------------------------------------------------------
8544 C The rigorous attempt to derive energy function
8545 subroutine ebend_kcc(etheta)
8547 implicit real*8 (a-h,o-z)
8548 include 'DIMENSIONS'
8549 include 'COMMON.VAR'
8550 include 'COMMON.GEO'
8551 include 'COMMON.LOCAL'
8552 include 'COMMON.TORSION'
8553 include 'COMMON.INTERACT'
8554 include 'COMMON.DERIV'
8555 include 'COMMON.CHAIN'
8556 include 'COMMON.NAMES'
8557 include 'COMMON.IOUNITS'
8558 include 'COMMON.FFIELD'
8559 include 'COMMON.TORCNSTR'
8560 include 'COMMON.CONTROL'
8562 double precision thybt1(maxang_kcc)
8563 C Set lprn=.true. for debugging
8566 C print *,"wchodze kcc"
8567 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8569 do i=ithet_start,ithet_end
8570 c print *,i,itype(i-1),itype(i),itype(i-2)
8571 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8572 & .or.itype(i).eq.ntyp1) cycle
8573 iti=iabs(itortyp(itype(i-1)))
8574 sinthet=dsin(theta(i))
8575 costhet=dcos(theta(i))
8576 do j=1,nbend_kcc_Tb(iti)
8577 thybt1(j)=v1bend_chyb(j,iti)
8579 sumth1thyb=v1bend_chyb(0,iti)+
8580 & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8581 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8583 ihelp=nbend_kcc_Tb(iti)-1
8584 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8585 etheta=etheta+sumth1thyb
8586 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8587 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8591 c-------------------------------------------------------------------------------------
8592 subroutine etheta_constr(ethetacnstr)
8594 implicit real*8 (a-h,o-z)
8595 include 'DIMENSIONS'
8596 include 'COMMON.VAR'
8597 include 'COMMON.GEO'
8598 include 'COMMON.LOCAL'
8599 include 'COMMON.TORSION'
8600 include 'COMMON.INTERACT'
8601 include 'COMMON.DERIV'
8602 include 'COMMON.CHAIN'
8603 include 'COMMON.NAMES'
8604 include 'COMMON.IOUNITS'
8605 include 'COMMON.FFIELD'
8606 include 'COMMON.TORCNSTR'
8607 include 'COMMON.CONTROL'
8609 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8610 do i=ithetaconstr_start,ithetaconstr_end
8611 itheta=itheta_constr(i)
8612 thetiii=theta(itheta)
8613 difi=pinorm(thetiii-theta_constr0(i))
8614 if (difi.gt.theta_drange(i)) then
8615 difi=difi-theta_drange(i)
8616 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8617 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8618 & +for_thet_constr(i)*difi**3
8619 else if (difi.lt.-drange(i)) then
8621 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8622 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8623 & +for_thet_constr(i)*difi**3
8627 if (energy_dec) then
8628 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8629 & i,itheta,rad2deg*thetiii,
8630 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8631 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8632 & gloc(itheta+nphi-2,icg)
8637 c------------------------------------------------------------------------------
8638 subroutine eback_sc_corr(esccor)
8639 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8640 c conformational states; temporarily implemented as differences
8641 c between UNRES torsional potentials (dependent on three types of
8642 c residues) and the torsional potentials dependent on all 20 types
8643 c of residues computed from AM1 energy surfaces of terminally-blocked
8644 c amino-acid residues.
8645 implicit real*8 (a-h,o-z)
8646 include 'DIMENSIONS'
8647 include 'COMMON.VAR'
8648 include 'COMMON.GEO'
8649 include 'COMMON.LOCAL'
8650 include 'COMMON.TORSION'
8651 include 'COMMON.SCCOR'
8652 include 'COMMON.INTERACT'
8653 include 'COMMON.DERIV'
8654 include 'COMMON.CHAIN'
8655 include 'COMMON.NAMES'
8656 include 'COMMON.IOUNITS'
8657 include 'COMMON.FFIELD'
8658 include 'COMMON.CONTROL'
8660 C Set lprn=.true. for debugging
8663 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8665 do i=itau_start,itau_end
8666 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8668 isccori=isccortyp(itype(i-2))
8669 isccori1=isccortyp(itype(i-1))
8670 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8672 do intertyp=1,3 !intertyp
8673 cc Added 09 May 2012 (Adasko)
8674 cc Intertyp means interaction type of backbone mainchain correlation:
8675 c 1 = SC...Ca...Ca...Ca
8676 c 2 = Ca...Ca...Ca...SC
8677 c 3 = SC...Ca...Ca...SCi
8679 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8680 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8681 & (itype(i-1).eq.ntyp1)))
8682 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8683 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8684 & .or.(itype(i).eq.ntyp1)))
8685 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8686 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8687 & (itype(i-3).eq.ntyp1)))) cycle
8688 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8689 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8691 do j=1,nterm_sccor(isccori,isccori1)
8692 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8693 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8694 cosphi=dcos(j*tauangle(intertyp,i))
8695 sinphi=dsin(j*tauangle(intertyp,i))
8696 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8697 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8699 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8700 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8702 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8703 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8704 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8705 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8706 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8712 c----------------------------------------------------------------------------
8713 subroutine multibody(ecorr)
8714 C This subroutine calculates multi-body contributions to energy following
8715 C the idea of Skolnick et al. If side chains I and J make a contact and
8716 C at the same time side chains I+1 and J+1 make a contact, an extra
8717 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8718 implicit real*8 (a-h,o-z)
8719 include 'DIMENSIONS'
8720 include 'COMMON.IOUNITS'
8721 include 'COMMON.DERIV'
8722 include 'COMMON.INTERACT'
8723 include 'COMMON.CONTACTS'
8724 double precision gx(3),gx1(3)
8727 C Set lprn=.true. for debugging
8731 write (iout,'(a)') 'Contact function values:'
8733 write (iout,'(i2,20(1x,i2,f10.5))')
8734 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8749 num_conti=num_cont(i)
8750 num_conti1=num_cont(i1)
8755 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8756 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8757 cd & ' ishift=',ishift
8758 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8759 C The system gains extra energy.
8760 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8761 endif ! j1==j+-ishift
8770 c------------------------------------------------------------------------------
8771 double precision function esccorr(i,j,k,l,jj,kk)
8772 implicit real*8 (a-h,o-z)
8773 include 'DIMENSIONS'
8774 include 'COMMON.IOUNITS'
8775 include 'COMMON.DERIV'
8776 include 'COMMON.INTERACT'
8777 include 'COMMON.CONTACTS'
8778 include 'COMMON.SHIELD'
8779 double precision gx(3),gx1(3)
8784 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8785 C Calculate the multi-body contribution to energy.
8786 C Calculate multi-body contributions to the gradient.
8787 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8788 cd & k,l,(gacont(m,kk,k),m=1,3)
8790 gx(m) =ekl*gacont(m,jj,i)
8791 gx1(m)=eij*gacont(m,kk,k)
8792 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8793 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8794 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8795 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8799 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8804 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8810 c------------------------------------------------------------------------------
8811 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8812 C This subroutine calculates multi-body contributions to hydrogen-bonding
8813 implicit real*8 (a-h,o-z)
8814 include 'DIMENSIONS'
8815 include 'COMMON.IOUNITS'
8818 parameter (max_cont=maxconts)
8819 parameter (max_dim=26)
8820 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8821 double precision zapas(max_dim,maxconts,max_fg_procs),
8822 & zapas_recv(max_dim,maxconts,max_fg_procs)
8823 common /przechowalnia/ zapas
8824 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8825 & status_array(MPI_STATUS_SIZE,maxconts*2)
8827 include 'COMMON.SETUP'
8828 include 'COMMON.FFIELD'
8829 include 'COMMON.DERIV'
8830 include 'COMMON.INTERACT'
8831 include 'COMMON.CONTACTS'
8832 include 'COMMON.CONTROL'
8833 include 'COMMON.LOCAL'
8834 double precision gx(3),gx1(3),time00
8837 C Set lprn=.true. for debugging
8842 if (nfgtasks.le.1) goto 30
8844 write (iout,'(a)') 'Contact function values before RECEIVE:'
8846 write (iout,'(2i3,50(1x,i2,f5.2))')
8847 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8848 & j=1,num_cont_hb(i))
8852 do i=1,ntask_cont_from
8855 do i=1,ntask_cont_to
8858 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8860 C Make the list of contacts to send to send to other procesors
8861 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8863 do i=iturn3_start,iturn3_end
8864 c write (iout,*) "make contact list turn3",i," num_cont",
8866 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8868 do i=iturn4_start,iturn4_end
8869 c write (iout,*) "make contact list turn4",i," num_cont",
8871 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8875 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8877 do j=1,num_cont_hb(i)
8880 iproc=iint_sent_local(k,jjc,ii)
8881 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8882 if (iproc.gt.0) then
8883 ncont_sent(iproc)=ncont_sent(iproc)+1
8884 nn=ncont_sent(iproc)
8886 zapas(2,nn,iproc)=jjc
8887 zapas(3,nn,iproc)=facont_hb(j,i)
8888 zapas(4,nn,iproc)=ees0p(j,i)
8889 zapas(5,nn,iproc)=ees0m(j,i)
8890 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8891 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8892 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8893 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8894 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8895 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8896 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8897 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8898 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8899 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8900 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8901 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8902 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8903 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8904 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8905 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8906 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8907 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8908 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8909 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8910 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8917 & "Numbers of contacts to be sent to other processors",
8918 & (ncont_sent(i),i=1,ntask_cont_to)
8919 write (iout,*) "Contacts sent"
8920 do ii=1,ntask_cont_to
8922 iproc=itask_cont_to(ii)
8923 write (iout,*) nn," contacts to processor",iproc,
8924 & " of CONT_TO_COMM group"
8926 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8934 CorrelID1=nfgtasks+fg_rank+1
8936 C Receive the numbers of needed contacts from other processors
8937 do ii=1,ntask_cont_from
8938 iproc=itask_cont_from(ii)
8940 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8941 & FG_COMM,req(ireq),IERR)
8943 c write (iout,*) "IRECV ended"
8945 C Send the number of contacts needed by other processors
8946 do ii=1,ntask_cont_to
8947 iproc=itask_cont_to(ii)
8949 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8950 & FG_COMM,req(ireq),IERR)
8952 c write (iout,*) "ISEND ended"
8953 c write (iout,*) "number of requests (nn)",ireq
8956 & call MPI_Waitall(ireq,req,status_array,ierr)
8958 c & "Numbers of contacts to be received from other processors",
8959 c & (ncont_recv(i),i=1,ntask_cont_from)
8963 do ii=1,ntask_cont_from
8964 iproc=itask_cont_from(ii)
8966 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8967 c & " of CONT_TO_COMM group"
8971 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8972 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8973 c write (iout,*) "ireq,req",ireq,req(ireq)
8976 C Send the contacts to processors that need them
8977 do ii=1,ntask_cont_to
8978 iproc=itask_cont_to(ii)
8980 c write (iout,*) nn," contacts to processor",iproc,
8981 c & " of CONT_TO_COMM group"
8984 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8985 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8986 c write (iout,*) "ireq,req",ireq,req(ireq)
8988 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8992 c write (iout,*) "number of requests (contacts)",ireq
8993 c write (iout,*) "req",(req(i),i=1,4)
8996 & call MPI_Waitall(ireq,req,status_array,ierr)
8997 do iii=1,ntask_cont_from
8998 iproc=itask_cont_from(iii)
9001 write (iout,*) "Received",nn," contacts from processor",iproc,
9002 & " of CONT_FROM_COMM group"
9005 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9010 ii=zapas_recv(1,i,iii)
9011 c Flag the received contacts to prevent double-counting
9012 jj=-zapas_recv(2,i,iii)
9013 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9015 nnn=num_cont_hb(ii)+1
9018 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9019 ees0p(nnn,ii)=zapas_recv(4,i,iii)
9020 ees0m(nnn,ii)=zapas_recv(5,i,iii)
9021 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9022 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9023 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9024 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9025 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9026 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9027 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9028 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9029 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9030 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9031 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9032 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9033 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9034 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9035 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9036 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9037 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9038 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9039 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9040 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9041 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9045 write (iout,'(a)') 'Contact function values after receive:'
9047 write (iout,'(2i3,50(1x,i3,f5.2))')
9048 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9049 & j=1,num_cont_hb(i))
9056 write (iout,'(a)') 'Contact function values:'
9058 write (iout,'(2i3,50(1x,i3,f5.2))')
9059 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9060 & j=1,num_cont_hb(i))
9065 C Remove the loop below after debugging !!!
9072 C Calculate the local-electrostatic correlation terms
9073 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9075 num_conti=num_cont_hb(i)
9076 num_conti1=num_cont_hb(i+1)
9083 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9084 c & ' jj=',jj,' kk=',kk
9086 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9087 & .or. j.lt.0 .and. j1.gt.0) .and.
9088 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9089 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9090 C The system gains extra energy.
9091 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9092 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9093 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9095 else if (j1.eq.j) then
9096 C Contacts I-J and I-(J+1) occur simultaneously.
9097 C The system loses extra energy.
9098 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9103 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9104 c & ' jj=',jj,' kk=',kk
9106 C Contacts I-J and (I+1)-J occur simultaneously.
9107 C The system loses extra energy.
9108 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9115 c------------------------------------------------------------------------------
9116 subroutine add_hb_contact(ii,jj,itask)
9117 implicit real*8 (a-h,o-z)
9118 include "DIMENSIONS"
9119 include "COMMON.IOUNITS"
9122 parameter (max_cont=maxconts)
9123 parameter (max_dim=26)
9124 include "COMMON.CONTACTS"
9125 double precision zapas(max_dim,maxconts,max_fg_procs),
9126 & zapas_recv(max_dim,maxconts,max_fg_procs)
9127 common /przechowalnia/ zapas
9128 integer i,j,ii,jj,iproc,itask(4),nn
9129 c write (iout,*) "itask",itask
9132 if (iproc.gt.0) then
9133 do j=1,num_cont_hb(ii)
9135 c write (iout,*) "i",ii," j",jj," jjc",jjc
9137 ncont_sent(iproc)=ncont_sent(iproc)+1
9138 nn=ncont_sent(iproc)
9139 zapas(1,nn,iproc)=ii
9140 zapas(2,nn,iproc)=jjc
9141 zapas(3,nn,iproc)=facont_hb(j,ii)
9142 zapas(4,nn,iproc)=ees0p(j,ii)
9143 zapas(5,nn,iproc)=ees0m(j,ii)
9144 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9145 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9146 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9147 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9148 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9149 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9150 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9151 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9152 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9153 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9154 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9155 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9156 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9157 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9158 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9159 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9160 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9161 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9162 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9163 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9164 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9172 c------------------------------------------------------------------------------
9173 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9175 C This subroutine calculates multi-body contributions to hydrogen-bonding
9176 implicit real*8 (a-h,o-z)
9177 include 'DIMENSIONS'
9178 include 'COMMON.IOUNITS'
9181 parameter (max_cont=maxconts)
9182 parameter (max_dim=70)
9183 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9184 double precision zapas(max_dim,maxconts,max_fg_procs),
9185 & zapas_recv(max_dim,maxconts,max_fg_procs)
9186 common /przechowalnia/ zapas
9187 integer status(MPI_STATUS_SIZE),req(maxconts*2),
9188 & status_array(MPI_STATUS_SIZE,maxconts*2)
9190 include 'COMMON.SETUP'
9191 include 'COMMON.FFIELD'
9192 include 'COMMON.DERIV'
9193 include 'COMMON.LOCAL'
9194 include 'COMMON.INTERACT'
9195 include 'COMMON.CONTACTS'
9196 include 'COMMON.CHAIN'
9197 include 'COMMON.CONTROL'
9198 include 'COMMON.SHIELD'
9199 double precision gx(3),gx1(3)
9200 integer num_cont_hb_old(maxres)
9202 double precision eello4,eello5,eelo6,eello_turn6
9203 external eello4,eello5,eello6,eello_turn6
9204 C Set lprn=.true. for debugging
9209 num_cont_hb_old(i)=num_cont_hb(i)
9213 if (nfgtasks.le.1) goto 30
9215 write (iout,'(a)') 'Contact function values before RECEIVE:'
9217 write (iout,'(2i3,50(1x,i2,f5.2))')
9218 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9219 & j=1,num_cont_hb(i))
9222 do i=1,ntask_cont_from
9225 do i=1,ntask_cont_to
9228 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9230 C Make the list of contacts to send to send to other procesors
9231 do i=iturn3_start,iturn3_end
9232 c write (iout,*) "make contact list turn3",i," num_cont",
9234 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9236 do i=iturn4_start,iturn4_end
9237 c write (iout,*) "make contact list turn4",i," num_cont",
9239 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9243 c write (iout,*) "make contact list longrange",i,ii," num_cont",
9245 do j=1,num_cont_hb(i)
9248 iproc=iint_sent_local(k,jjc,ii)
9249 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9250 if (iproc.ne.0) then
9251 ncont_sent(iproc)=ncont_sent(iproc)+1
9252 nn=ncont_sent(iproc)
9254 zapas(2,nn,iproc)=jjc
9255 zapas(3,nn,iproc)=d_cont(j,i)
9259 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9264 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9272 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9283 & "Numbers of contacts to be sent to other processors",
9284 & (ncont_sent(i),i=1,ntask_cont_to)
9285 write (iout,*) "Contacts sent"
9286 do ii=1,ntask_cont_to
9288 iproc=itask_cont_to(ii)
9289 write (iout,*) nn," contacts to processor",iproc,
9290 & " of CONT_TO_COMM group"
9292 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9300 CorrelID1=nfgtasks+fg_rank+1
9302 C Receive the numbers of needed contacts from other processors
9303 do ii=1,ntask_cont_from
9304 iproc=itask_cont_from(ii)
9306 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9307 & FG_COMM,req(ireq),IERR)
9309 c write (iout,*) "IRECV ended"
9311 C Send the number of contacts needed by other processors
9312 do ii=1,ntask_cont_to
9313 iproc=itask_cont_to(ii)
9315 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9316 & FG_COMM,req(ireq),IERR)
9318 c write (iout,*) "ISEND ended"
9319 c write (iout,*) "number of requests (nn)",ireq
9322 & call MPI_Waitall(ireq,req,status_array,ierr)
9324 c & "Numbers of contacts to be received from other processors",
9325 c & (ncont_recv(i),i=1,ntask_cont_from)
9329 do ii=1,ntask_cont_from
9330 iproc=itask_cont_from(ii)
9332 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9333 c & " of CONT_TO_COMM group"
9337 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9338 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9339 c write (iout,*) "ireq,req",ireq,req(ireq)
9342 C Send the contacts to processors that need them
9343 do ii=1,ntask_cont_to
9344 iproc=itask_cont_to(ii)
9346 c write (iout,*) nn," contacts to processor",iproc,
9347 c & " of CONT_TO_COMM group"
9350 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9351 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9352 c write (iout,*) "ireq,req",ireq,req(ireq)
9354 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9358 c write (iout,*) "number of requests (contacts)",ireq
9359 c write (iout,*) "req",(req(i),i=1,4)
9362 & call MPI_Waitall(ireq,req,status_array,ierr)
9363 do iii=1,ntask_cont_from
9364 iproc=itask_cont_from(iii)
9367 write (iout,*) "Received",nn," contacts from processor",iproc,
9368 & " of CONT_FROM_COMM group"
9371 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9376 ii=zapas_recv(1,i,iii)
9377 c Flag the received contacts to prevent double-counting
9378 jj=-zapas_recv(2,i,iii)
9379 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9381 nnn=num_cont_hb(ii)+1
9384 d_cont(nnn,ii)=zapas_recv(3,i,iii)
9388 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9393 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9401 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9409 write (iout,'(a)') 'Contact function values after receive:'
9411 write (iout,'(2i3,50(1x,i3,5f6.3))')
9412 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9413 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9420 write (iout,'(a)') 'Contact function values:'
9422 write (iout,'(2i3,50(1x,i2,5f6.3))')
9423 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9424 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9430 C Remove the loop below after debugging !!!
9437 C Calculate the dipole-dipole interaction energies
9438 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9439 do i=iatel_s,iatel_e+1
9440 num_conti=num_cont_hb(i)
9449 C Calculate the local-electrostatic correlation terms
9450 c write (iout,*) "gradcorr5 in eello5 before loop"
9452 c write (iout,'(i5,3f10.5)')
9453 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9455 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9456 c write (iout,*) "corr loop i",i
9458 num_conti=num_cont_hb(i)
9459 num_conti1=num_cont_hb(i+1)
9466 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9467 c & ' jj=',jj,' kk=',kk
9468 c if (j1.eq.j+1 .or. j1.eq.j-1) then
9469 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9470 & .or. j.lt.0 .and. j1.gt.0) .and.
9471 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9472 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9473 C The system gains extra energy.
9475 sqd1=dsqrt(d_cont(jj,i))
9476 sqd2=dsqrt(d_cont(kk,i1))
9477 sred_geom = sqd1*sqd2
9478 IF (sred_geom.lt.cutoff_corr) THEN
9479 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9481 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9482 cd & ' jj=',jj,' kk=',kk
9483 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9484 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9486 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9487 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9490 cd write (iout,*) 'sred_geom=',sred_geom,
9491 cd & ' ekont=',ekont,' fprim=',fprimcont,
9492 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9493 cd write (iout,*) "g_contij",g_contij
9494 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9495 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9496 call calc_eello(i,jp,i+1,jp1,jj,kk)
9497 if (wcorr4.gt.0.0d0)
9498 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9499 CC & *fac_shield(i)**2*fac_shield(j)**2
9500 if (energy_dec.and.wcorr4.gt.0.0d0)
9501 1 write (iout,'(a6,4i5,0pf7.3)')
9502 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9503 c write (iout,*) "gradcorr5 before eello5"
9505 c write (iout,'(i5,3f10.5)')
9506 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9508 if (wcorr5.gt.0.0d0)
9509 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9510 c write (iout,*) "gradcorr5 after eello5"
9512 c write (iout,'(i5,3f10.5)')
9513 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9515 if (energy_dec.and.wcorr5.gt.0.0d0)
9516 1 write (iout,'(a6,4i5,0pf7.3)')
9517 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9518 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9519 cd write(2,*)'ijkl',i,jp,i+1,jp1
9520 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9521 & .or. wturn6.eq.0.0d0))then
9522 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9523 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9524 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9525 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9526 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9527 cd & 'ecorr6=',ecorr6
9528 cd write (iout,'(4e15.5)') sred_geom,
9529 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9530 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9531 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9532 else if (wturn6.gt.0.0d0
9533 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9534 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9535 eturn6=eturn6+eello_turn6(i,jj,kk)
9536 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9537 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9538 cd write (2,*) 'multibody_eello:eturn6',eturn6
9547 num_cont_hb(i)=num_cont_hb_old(i)
9549 c write (iout,*) "gradcorr5 in eello5"
9551 c write (iout,'(i5,3f10.5)')
9552 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9556 c------------------------------------------------------------------------------
9557 subroutine add_hb_contact_eello(ii,jj,itask)
9558 implicit real*8 (a-h,o-z)
9559 include "DIMENSIONS"
9560 include "COMMON.IOUNITS"
9563 parameter (max_cont=maxconts)
9564 parameter (max_dim=70)
9565 include "COMMON.CONTACTS"
9566 double precision zapas(max_dim,maxconts,max_fg_procs),
9567 & zapas_recv(max_dim,maxconts,max_fg_procs)
9568 common /przechowalnia/ zapas
9569 integer i,j,ii,jj,iproc,itask(4),nn
9570 c write (iout,*) "itask",itask
9573 if (iproc.gt.0) then
9574 do j=1,num_cont_hb(ii)
9576 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9578 ncont_sent(iproc)=ncont_sent(iproc)+1
9579 nn=ncont_sent(iproc)
9580 zapas(1,nn,iproc)=ii
9581 zapas(2,nn,iproc)=jjc
9582 zapas(3,nn,iproc)=d_cont(j,ii)
9586 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9591 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9599 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9611 c------------------------------------------------------------------------------
9612 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9613 implicit real*8 (a-h,o-z)
9614 include 'DIMENSIONS'
9615 include 'COMMON.IOUNITS'
9616 include 'COMMON.DERIV'
9617 include 'COMMON.INTERACT'
9618 include 'COMMON.CONTACTS'
9619 include 'COMMON.SHIELD'
9620 include 'COMMON.CONTROL'
9621 double precision gx(3),gx1(3)
9624 C print *,"wchodze",fac_shield(i),shield_mode
9632 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9634 C & fac_shield(i)**2*fac_shield(j)**2
9635 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9636 C Following 4 lines for diagnostics.
9641 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9642 c & 'Contacts ',i,j,
9643 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9644 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9646 C Calculate the multi-body contribution to energy.
9647 C ecorr=ecorr+ekont*ees
9648 C Calculate multi-body contributions to the gradient.
9649 coeffpees0pij=coeffp*ees0pij
9650 coeffmees0mij=coeffm*ees0mij
9651 coeffpees0pkl=coeffp*ees0pkl
9652 coeffmees0mkl=coeffm*ees0mkl
9654 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9655 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9656 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9657 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9658 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9659 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9660 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9661 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9662 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9663 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9664 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9665 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9666 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9667 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9668 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9669 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9670 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9671 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9672 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9673 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9674 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9675 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9676 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9677 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9678 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9683 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9684 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9685 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9686 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9691 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9692 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9693 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9694 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9697 c write (iout,*) "ehbcorr",ekont*ees
9698 C print *,ekont,ees,i,k
9700 C now gradient over shielding
9702 if (shield_mode.gt.0) then
9705 C print *,i,j,fac_shield(i),fac_shield(j),
9706 C &fac_shield(k),fac_shield(l)
9707 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9708 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9709 do ilist=1,ishield_list(i)
9710 iresshield=shield_list(ilist,i)
9712 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9714 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9716 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9717 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9721 do ilist=1,ishield_list(j)
9722 iresshield=shield_list(ilist,j)
9724 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9726 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9728 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9729 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9734 do ilist=1,ishield_list(k)
9735 iresshield=shield_list(ilist,k)
9737 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9739 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9741 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9742 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9746 do ilist=1,ishield_list(l)
9747 iresshield=shield_list(ilist,l)
9749 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9751 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9753 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9754 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9758 C print *,gshieldx(m,iresshield)
9760 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9761 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9762 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9763 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9764 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9765 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9766 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9767 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9769 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9770 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9771 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9772 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9773 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9774 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9775 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9776 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9784 C---------------------------------------------------------------------------
9785 subroutine dipole(i,j,jj)
9786 implicit real*8 (a-h,o-z)
9787 include 'DIMENSIONS'
9788 include 'COMMON.IOUNITS'
9789 include 'COMMON.CHAIN'
9790 include 'COMMON.FFIELD'
9791 include 'COMMON.DERIV'
9792 include 'COMMON.INTERACT'
9793 include 'COMMON.CONTACTS'
9794 include 'COMMON.TORSION'
9795 include 'COMMON.VAR'
9796 include 'COMMON.GEO'
9797 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9799 iti1 = itortyp(itype(i+1))
9800 if (j.lt.nres-1) then
9801 itj1 = itype2loc(itype(j+1))
9806 dipi(iii,1)=Ub2(iii,i)
9807 dipderi(iii)=Ub2der(iii,i)
9808 dipi(iii,2)=b1(iii,i+1)
9809 dipj(iii,1)=Ub2(iii,j)
9810 dipderj(iii)=Ub2der(iii,j)
9811 dipj(iii,2)=b1(iii,j+1)
9815 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9818 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9825 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9829 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9834 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9835 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9837 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9839 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9841 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9846 C---------------------------------------------------------------------------
9847 subroutine calc_eello(i,j,k,l,jj,kk)
9849 C This subroutine computes matrices and vectors needed to calculate
9850 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9852 implicit real*8 (a-h,o-z)
9853 include 'DIMENSIONS'
9854 include 'COMMON.IOUNITS'
9855 include 'COMMON.CHAIN'
9856 include 'COMMON.DERIV'
9857 include 'COMMON.INTERACT'
9858 include 'COMMON.CONTACTS'
9859 include 'COMMON.TORSION'
9860 include 'COMMON.VAR'
9861 include 'COMMON.GEO'
9862 include 'COMMON.FFIELD'
9863 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9864 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9867 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9868 cd & ' jj=',jj,' kk=',kk
9869 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9870 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9871 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9874 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9875 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9878 call transpose2(aa1(1,1),aa1t(1,1))
9879 call transpose2(aa2(1,1),aa2t(1,1))
9882 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9883 & aa1tder(1,1,lll,kkk))
9884 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9885 & aa2tder(1,1,lll,kkk))
9889 C parallel orientation of the two CA-CA-CA frames.
9891 iti=itype2loc(itype(i))
9895 itk1=itype2loc(itype(k+1))
9896 itj=itype2loc(itype(j))
9897 if (l.lt.nres-1) then
9898 itl1=itype2loc(itype(l+1))
9902 C A1 kernel(j+1) A2T
9904 cd write (iout,'(3f10.5,5x,3f10.5)')
9905 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9907 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9908 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9909 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9910 C Following matrices are needed only for 6-th order cumulants
9911 IF (wcorr6.gt.0.0d0) THEN
9912 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9913 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9914 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9915 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9916 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9917 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9918 & ADtEAderx(1,1,1,1,1,1))
9920 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9921 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9922 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9923 & ADtEA1derx(1,1,1,1,1,1))
9925 C End 6-th order cumulants
9928 cd write (2,*) 'In calc_eello6'
9930 cd write (2,*) 'iii=',iii
9932 cd write (2,*) 'kkk=',kkk
9934 cd write (2,'(3(2f10.5),5x)')
9935 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9940 call transpose2(EUgder(1,1,k),auxmat(1,1))
9941 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9942 call transpose2(EUg(1,1,k),auxmat(1,1))
9943 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9944 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9945 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9946 c in theta; to be sriten later.
9948 c call transpose2(gtEE(1,1,k),auxmat(1,1))
9949 c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9950 c call transpose2(EUg(1,1,k),auxmat(1,1))
9951 c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9956 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9957 & EAEAderx(1,1,lll,kkk,iii,1))
9961 C A1T kernel(i+1) A2
9962 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9963 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9964 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9965 C Following matrices are needed only for 6-th order cumulants
9966 IF (wcorr6.gt.0.0d0) THEN
9967 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9968 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9969 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9970 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9971 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9972 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9973 & ADtEAderx(1,1,1,1,1,2))
9974 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9975 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9976 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9977 & ADtEA1derx(1,1,1,1,1,2))
9979 C End 6-th order cumulants
9980 call transpose2(EUgder(1,1,l),auxmat(1,1))
9981 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9982 call transpose2(EUg(1,1,l),auxmat(1,1))
9983 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9984 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9988 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9989 & EAEAderx(1,1,lll,kkk,iii,2))
9994 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9995 C They are needed only when the fifth- or the sixth-order cumulants are
9997 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9998 call transpose2(AEA(1,1,1),auxmat(1,1))
9999 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10000 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10001 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10002 call transpose2(AEAderg(1,1,1),auxmat(1,1))
10003 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10004 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10005 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10006 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10007 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10008 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10009 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10010 call transpose2(AEA(1,1,2),auxmat(1,1))
10011 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10012 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10013 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10014 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10015 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10016 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10017 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10018 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10019 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10020 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10021 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10022 C Calculate the Cartesian derivatives of the vectors.
10026 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10027 call matvec2(auxmat(1,1),b1(1,i),
10028 & AEAb1derx(1,lll,kkk,iii,1,1))
10029 call matvec2(auxmat(1,1),Ub2(1,i),
10030 & AEAb2derx(1,lll,kkk,iii,1,1))
10031 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10032 & AEAb1derx(1,lll,kkk,iii,2,1))
10033 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10034 & AEAb2derx(1,lll,kkk,iii,2,1))
10035 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10036 call matvec2(auxmat(1,1),b1(1,j),
10037 & AEAb1derx(1,lll,kkk,iii,1,2))
10038 call matvec2(auxmat(1,1),Ub2(1,j),
10039 & AEAb2derx(1,lll,kkk,iii,1,2))
10040 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10041 & AEAb1derx(1,lll,kkk,iii,2,2))
10042 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10043 & AEAb2derx(1,lll,kkk,iii,2,2))
10050 C Antiparallel orientation of the two CA-CA-CA frames.
10052 iti=itype2loc(itype(i))
10056 itk1=itype2loc(itype(k+1))
10057 itl=itype2loc(itype(l))
10058 itj=itype2loc(itype(j))
10059 if (j.lt.nres-1) then
10060 itj1=itype2loc(itype(j+1))
10064 C A2 kernel(j-1)T A1T
10065 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10066 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10067 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10068 C Following matrices are needed only for 6-th order cumulants
10069 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10070 & j.eq.i+4 .and. l.eq.i+3)) THEN
10071 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10072 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10073 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10074 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10075 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10076 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10077 & ADtEAderx(1,1,1,1,1,1))
10078 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10079 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10080 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10081 & ADtEA1derx(1,1,1,1,1,1))
10083 C End 6-th order cumulants
10084 call transpose2(EUgder(1,1,k),auxmat(1,1))
10085 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10086 call transpose2(EUg(1,1,k),auxmat(1,1))
10087 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10088 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10092 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10093 & EAEAderx(1,1,lll,kkk,iii,1))
10097 C A2T kernel(i+1)T A1
10098 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10099 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10100 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10101 C Following matrices are needed only for 6-th order cumulants
10102 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10103 & j.eq.i+4 .and. l.eq.i+3)) THEN
10104 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10105 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10106 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10107 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10108 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10109 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10110 & ADtEAderx(1,1,1,1,1,2))
10111 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10112 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10113 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10114 & ADtEA1derx(1,1,1,1,1,2))
10116 C End 6-th order cumulants
10117 call transpose2(EUgder(1,1,j),auxmat(1,1))
10118 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10119 call transpose2(EUg(1,1,j),auxmat(1,1))
10120 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10121 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10125 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10126 & EAEAderx(1,1,lll,kkk,iii,2))
10131 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10132 C They are needed only when the fifth- or the sixth-order cumulants are
10134 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10135 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10136 call transpose2(AEA(1,1,1),auxmat(1,1))
10137 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10138 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10139 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10140 call transpose2(AEAderg(1,1,1),auxmat(1,1))
10141 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10142 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10143 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10144 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10145 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10146 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10147 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10148 call transpose2(AEA(1,1,2),auxmat(1,1))
10149 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10150 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10151 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10152 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10153 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10154 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10155 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10156 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10157 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10158 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10159 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10160 C Calculate the Cartesian derivatives of the vectors.
10164 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10165 call matvec2(auxmat(1,1),b1(1,i),
10166 & AEAb1derx(1,lll,kkk,iii,1,1))
10167 call matvec2(auxmat(1,1),Ub2(1,i),
10168 & AEAb2derx(1,lll,kkk,iii,1,1))
10169 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10170 & AEAb1derx(1,lll,kkk,iii,2,1))
10171 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10172 & AEAb2derx(1,lll,kkk,iii,2,1))
10173 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10174 call matvec2(auxmat(1,1),b1(1,l),
10175 & AEAb1derx(1,lll,kkk,iii,1,2))
10176 call matvec2(auxmat(1,1),Ub2(1,l),
10177 & AEAb2derx(1,lll,kkk,iii,1,2))
10178 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10179 & AEAb1derx(1,lll,kkk,iii,2,2))
10180 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10181 & AEAb2derx(1,lll,kkk,iii,2,2))
10190 C---------------------------------------------------------------------------
10191 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10192 & KK,KKderg,AKA,AKAderg,AKAderx)
10196 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10197 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10198 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10199 integer iii,kkk,lll
10202 common /kutas/ lprn
10203 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10205 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10206 & AKAderg(1,1,iii))
10208 cd if (lprn) write (2,*) 'In kernel'
10210 cd if (lprn) write (2,*) 'kkk=',kkk
10212 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10213 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10215 cd write (2,*) 'lll=',lll
10216 cd write (2,*) 'iii=1'
10218 cd write (2,'(3(2f10.5),5x)')
10219 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10222 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10223 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10225 cd write (2,*) 'lll=',lll
10226 cd write (2,*) 'iii=2'
10228 cd write (2,'(3(2f10.5),5x)')
10229 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10236 C---------------------------------------------------------------------------
10237 double precision function eello4(i,j,k,l,jj,kk)
10238 implicit real*8 (a-h,o-z)
10239 include 'DIMENSIONS'
10240 include 'COMMON.IOUNITS'
10241 include 'COMMON.CHAIN'
10242 include 'COMMON.DERIV'
10243 include 'COMMON.INTERACT'
10244 include 'COMMON.CONTACTS'
10245 include 'COMMON.TORSION'
10246 include 'COMMON.VAR'
10247 include 'COMMON.GEO'
10248 double precision pizda(2,2),ggg1(3),ggg2(3)
10249 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10253 cd print *,'eello4:',i,j,k,l,jj,kk
10254 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
10255 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
10256 cold eij=facont_hb(jj,i)
10257 cold ekl=facont_hb(kk,k)
10259 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10260 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10261 gcorr_loc(k-1)=gcorr_loc(k-1)
10262 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10264 gcorr_loc(l-1)=gcorr_loc(l-1)
10265 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10266 C Al 4/16/16: Derivatives in theta, to be added later.
10268 c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10269 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10272 gcorr_loc(j-1)=gcorr_loc(j-1)
10273 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10275 c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10276 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10282 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10283 & -EAEAderx(2,2,lll,kkk,iii,1)
10284 cd derx(lll,kkk,iii)=0.0d0
10288 cd gcorr_loc(l-1)=0.0d0
10289 cd gcorr_loc(j-1)=0.0d0
10290 cd gcorr_loc(k-1)=0.0d0
10292 cd write (iout,*)'Contacts have occurred for peptide groups',
10293 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
10294 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10295 if (j.lt.nres-1) then
10302 if (l.lt.nres-1) then
10310 cgrad ggg1(ll)=eel4*g_contij(ll,1)
10311 cgrad ggg2(ll)=eel4*g_contij(ll,2)
10312 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10313 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10314 cgrad ghalf=0.5d0*ggg1(ll)
10315 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10316 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10317 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10318 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10319 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10320 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10321 cgrad ghalf=0.5d0*ggg2(ll)
10322 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10323 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10324 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10325 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10326 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10327 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10331 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10336 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10341 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10346 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10350 cd write (2,*) iii,gcorr_loc(iii)
10353 cd write (2,*) 'ekont',ekont
10354 cd write (iout,*) 'eello4',ekont*eel4
10357 C---------------------------------------------------------------------------
10358 double precision function eello5(i,j,k,l,jj,kk)
10359 implicit real*8 (a-h,o-z)
10360 include 'DIMENSIONS'
10361 include 'COMMON.IOUNITS'
10362 include 'COMMON.CHAIN'
10363 include 'COMMON.DERIV'
10364 include 'COMMON.INTERACT'
10365 include 'COMMON.CONTACTS'
10366 include 'COMMON.TORSION'
10367 include 'COMMON.VAR'
10368 include 'COMMON.GEO'
10369 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10370 double precision ggg1(3),ggg2(3)
10371 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10373 C Parallel chains C
10376 C /l\ / \ \ / \ / \ / C
10377 C / \ / \ \ / \ / \ / C
10378 C j| o |l1 | o | o| o | | o |o C
10379 C \ |/k\| |/ \| / |/ \| |/ \| C
10380 C \i/ \ / \ / / \ / \ C
10382 C (I) (II) (III) (IV) C
10384 C eello5_1 eello5_2 eello5_3 eello5_4 C
10386 C Antiparallel chains C
10389 C /j\ / \ \ / \ / \ / C
10390 C / \ / \ \ / \ / \ / C
10391 C j1| o |l | o | o| o | | o |o C
10392 C \ |/k\| |/ \| / |/ \| |/ \| C
10393 C \i/ \ / \ / / \ / \ C
10395 C (I) (II) (III) (IV) C
10397 C eello5_1 eello5_2 eello5_3 eello5_4 C
10399 C o denotes a local interaction, vertical lines an electrostatic interaction. C
10401 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10402 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10407 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
10409 itk=itype2loc(itype(k))
10410 itl=itype2loc(itype(l))
10411 itj=itype2loc(itype(j))
10416 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10417 cd & eel5_3_num,eel5_4_num)
10421 derx(lll,kkk,iii)=0.0d0
10425 cd eij=facont_hb(jj,i)
10426 cd ekl=facont_hb(kk,k)
10428 cd write (iout,*)'Contacts have occurred for peptide groups',
10429 cd & i,j,' fcont:',eij,' eij',' and ',k,l
10431 C Contribution from the graph I.
10432 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10433 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10434 call transpose2(EUg(1,1,k),auxmat(1,1))
10435 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10436 vv(1)=pizda(1,1)-pizda(2,2)
10437 vv(2)=pizda(1,2)+pizda(2,1)
10438 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10439 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10440 C Explicit gradient in virtual-dihedral angles.
10441 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10442 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10443 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10444 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10445 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10446 vv(1)=pizda(1,1)-pizda(2,2)
10447 vv(2)=pizda(1,2)+pizda(2,1)
10448 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10449 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10450 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10451 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10452 vv(1)=pizda(1,1)-pizda(2,2)
10453 vv(2)=pizda(1,2)+pizda(2,1)
10455 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10456 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10457 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10459 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10460 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10461 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10463 C Cartesian gradient
10467 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10469 vv(1)=pizda(1,1)-pizda(2,2)
10470 vv(2)=pizda(1,2)+pizda(2,1)
10471 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10472 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10473 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10479 C Contribution from graph II
10480 call transpose2(EE(1,1,k),auxmat(1,1))
10481 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10482 vv(1)=pizda(1,1)+pizda(2,2)
10483 vv(2)=pizda(2,1)-pizda(1,2)
10484 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10485 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10486 C Explicit gradient in virtual-dihedral angles.
10487 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10488 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10489 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10490 vv(1)=pizda(1,1)+pizda(2,2)
10491 vv(2)=pizda(2,1)-pizda(1,2)
10493 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10494 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10495 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10497 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10498 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10499 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10501 C Cartesian gradient
10505 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10507 vv(1)=pizda(1,1)+pizda(2,2)
10508 vv(2)=pizda(2,1)-pizda(1,2)
10509 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10510 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10511 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10519 C Parallel orientation
10520 C Contribution from graph III
10521 call transpose2(EUg(1,1,l),auxmat(1,1))
10522 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10523 vv(1)=pizda(1,1)-pizda(2,2)
10524 vv(2)=pizda(1,2)+pizda(2,1)
10525 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10526 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10527 C Explicit gradient in virtual-dihedral angles.
10528 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10529 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10530 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10531 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10532 vv(1)=pizda(1,1)-pizda(2,2)
10533 vv(2)=pizda(1,2)+pizda(2,1)
10534 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10535 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10536 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10537 call transpose2(EUgder(1,1,l),auxmat1(1,1))
10538 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10539 vv(1)=pizda(1,1)-pizda(2,2)
10540 vv(2)=pizda(1,2)+pizda(2,1)
10541 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10542 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10543 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10544 C Cartesian gradient
10548 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10550 vv(1)=pizda(1,1)-pizda(2,2)
10551 vv(2)=pizda(1,2)+pizda(2,1)
10552 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10553 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10554 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10559 C Contribution from graph IV
10561 call transpose2(EE(1,1,l),auxmat(1,1))
10562 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10563 vv(1)=pizda(1,1)+pizda(2,2)
10564 vv(2)=pizda(2,1)-pizda(1,2)
10565 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10566 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10567 C Explicit gradient in virtual-dihedral angles.
10568 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10569 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10570 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10571 vv(1)=pizda(1,1)+pizda(2,2)
10572 vv(2)=pizda(2,1)-pizda(1,2)
10573 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10574 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10575 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10576 C Cartesian gradient
10580 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10582 vv(1)=pizda(1,1)+pizda(2,2)
10583 vv(2)=pizda(2,1)-pizda(1,2)
10584 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10585 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10586 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10591 C Antiparallel orientation
10592 C Contribution from graph III
10594 call transpose2(EUg(1,1,j),auxmat(1,1))
10595 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10596 vv(1)=pizda(1,1)-pizda(2,2)
10597 vv(2)=pizda(1,2)+pizda(2,1)
10598 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10599 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10600 C Explicit gradient in virtual-dihedral angles.
10601 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10602 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10603 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10604 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10605 vv(1)=pizda(1,1)-pizda(2,2)
10606 vv(2)=pizda(1,2)+pizda(2,1)
10607 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10608 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10609 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10610 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10611 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10612 vv(1)=pizda(1,1)-pizda(2,2)
10613 vv(2)=pizda(1,2)+pizda(2,1)
10614 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10615 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10616 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10617 C Cartesian gradient
10621 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10623 vv(1)=pizda(1,1)-pizda(2,2)
10624 vv(2)=pizda(1,2)+pizda(2,1)
10625 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10626 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10627 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10632 C Contribution from graph IV
10634 call transpose2(EE(1,1,j),auxmat(1,1))
10635 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10636 vv(1)=pizda(1,1)+pizda(2,2)
10637 vv(2)=pizda(2,1)-pizda(1,2)
10638 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10639 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10640 C Explicit gradient in virtual-dihedral angles.
10641 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10642 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10643 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10644 vv(1)=pizda(1,1)+pizda(2,2)
10645 vv(2)=pizda(2,1)-pizda(1,2)
10646 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10647 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10648 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10649 C Cartesian gradient
10653 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10655 vv(1)=pizda(1,1)+pizda(2,2)
10656 vv(2)=pizda(2,1)-pizda(1,2)
10657 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10658 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10659 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10665 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10666 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10667 cd write (2,*) 'ijkl',i,j,k,l
10668 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10669 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10671 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10672 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10673 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10674 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10675 if (j.lt.nres-1) then
10682 if (l.lt.nres-1) then
10692 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10693 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10694 C summed up outside the subrouine as for the other subroutines
10695 C handling long-range interactions. The old code is commented out
10696 C with "cgrad" to keep track of changes.
10698 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10699 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10700 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10701 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10702 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10703 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10704 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10705 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10706 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10707 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10709 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10710 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10711 cgrad ghalf=0.5d0*ggg1(ll)
10713 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10714 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10715 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10716 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10717 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10718 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10719 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10720 cgrad ghalf=0.5d0*ggg2(ll)
10722 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10723 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10724 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10725 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10726 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10727 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10732 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10733 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10738 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10739 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10745 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10750 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10754 cd write (2,*) iii,g_corr5_loc(iii)
10757 cd write (2,*) 'ekont',ekont
10758 cd write (iout,*) 'eello5',ekont*eel5
10761 c--------------------------------------------------------------------------
10762 double precision function eello6(i,j,k,l,jj,kk)
10763 implicit real*8 (a-h,o-z)
10764 include 'DIMENSIONS'
10765 include 'COMMON.IOUNITS'
10766 include 'COMMON.CHAIN'
10767 include 'COMMON.DERIV'
10768 include 'COMMON.INTERACT'
10769 include 'COMMON.CONTACTS'
10770 include 'COMMON.TORSION'
10771 include 'COMMON.VAR'
10772 include 'COMMON.GEO'
10773 include 'COMMON.FFIELD'
10774 double precision ggg1(3),ggg2(3)
10775 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10780 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10788 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10789 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10793 derx(lll,kkk,iii)=0.0d0
10797 cd eij=facont_hb(jj,i)
10798 cd ekl=facont_hb(kk,k)
10804 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10805 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10806 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10807 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10808 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10809 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10811 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10812 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10813 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10814 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10815 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10816 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10820 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10822 C If turn contributions are considered, they will be handled separately.
10823 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10824 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10825 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10826 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10827 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10828 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10829 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10831 if (j.lt.nres-1) then
10838 if (l.lt.nres-1) then
10846 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10847 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10848 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10849 cgrad ghalf=0.5d0*ggg1(ll)
10851 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10852 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10853 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10854 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10855 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10856 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10857 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10858 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10859 cgrad ghalf=0.5d0*ggg2(ll)
10860 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10862 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10863 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10864 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10865 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10866 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10867 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10872 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10873 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10878 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10879 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10885 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10890 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10894 cd write (2,*) iii,g_corr6_loc(iii)
10897 cd write (2,*) 'ekont',ekont
10898 cd write (iout,*) 'eello6',ekont*eel6
10901 c--------------------------------------------------------------------------
10902 double precision function eello6_graph1(i,j,k,l,imat,swap)
10903 implicit real*8 (a-h,o-z)
10904 include 'DIMENSIONS'
10905 include 'COMMON.IOUNITS'
10906 include 'COMMON.CHAIN'
10907 include 'COMMON.DERIV'
10908 include 'COMMON.INTERACT'
10909 include 'COMMON.CONTACTS'
10910 include 'COMMON.TORSION'
10911 include 'COMMON.VAR'
10912 include 'COMMON.GEO'
10913 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10916 common /kutas/ lprn
10917 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10919 C Parallel Antiparallel C
10925 C \ j|/k\| / \ |/k\|l / C
10926 C \ / \ / \ / \ / C
10930 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10931 itk=itype2loc(itype(k))
10932 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10933 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10934 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10935 call transpose2(EUgC(1,1,k),auxmat(1,1))
10936 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10937 vv1(1)=pizda1(1,1)-pizda1(2,2)
10938 vv1(2)=pizda1(1,2)+pizda1(2,1)
10939 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10940 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10941 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10942 s5=scalar2(vv(1),Dtobr2(1,i))
10943 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10944 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10945 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10946 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10947 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10948 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10949 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10950 & +scalar2(vv(1),Dtobr2der(1,i)))
10951 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10952 vv1(1)=pizda1(1,1)-pizda1(2,2)
10953 vv1(2)=pizda1(1,2)+pizda1(2,1)
10954 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10955 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10957 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10958 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10959 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10960 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10961 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10963 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10964 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10965 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10966 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10967 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10969 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10970 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10971 vv1(1)=pizda1(1,1)-pizda1(2,2)
10972 vv1(2)=pizda1(1,2)+pizda1(2,1)
10973 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10974 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10975 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10976 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10985 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10986 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10987 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10988 call transpose2(EUgC(1,1,k),auxmat(1,1))
10989 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10991 vv1(1)=pizda1(1,1)-pizda1(2,2)
10992 vv1(2)=pizda1(1,2)+pizda1(2,1)
10993 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10994 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10995 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10996 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10997 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10998 s5=scalar2(vv(1),Dtobr2(1,i))
10999 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11005 c----------------------------------------------------------------------------
11006 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11007 implicit real*8 (a-h,o-z)
11008 include 'DIMENSIONS'
11009 include 'COMMON.IOUNITS'
11010 include 'COMMON.CHAIN'
11011 include 'COMMON.DERIV'
11012 include 'COMMON.INTERACT'
11013 include 'COMMON.CONTACTS'
11014 include 'COMMON.TORSION'
11015 include 'COMMON.VAR'
11016 include 'COMMON.GEO'
11018 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11019 & auxvec1(2),auxvec2(2),auxmat1(2,2)
11021 common /kutas/ lprn
11022 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11024 C Parallel Antiparallel C
11030 C \ j|/k\| \ |/k\|l C
11035 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11036 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11037 C AL 7/4/01 s1 would occur in the sixth-order moment,
11038 C but not in a cluster cumulant
11040 s1=dip(1,jj,i)*dip(1,kk,k)
11042 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11043 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11044 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11045 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11046 call transpose2(EUg(1,1,k),auxmat(1,1))
11047 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11048 vv(1)=pizda(1,1)-pizda(2,2)
11049 vv(2)=pizda(1,2)+pizda(2,1)
11050 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11051 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11053 eello6_graph2=-(s1+s2+s3+s4)
11055 eello6_graph2=-(s2+s3+s4)
11057 c eello6_graph2=-s3
11058 C Derivatives in gamma(i-1)
11061 s1=dipderg(1,jj,i)*dip(1,kk,k)
11063 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11064 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11065 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11066 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11068 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11070 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11072 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11074 C Derivatives in gamma(k-1)
11076 s1=dip(1,jj,i)*dipderg(1,kk,k)
11078 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11079 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11080 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11081 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11082 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11083 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11084 vv(1)=pizda(1,1)-pizda(2,2)
11085 vv(2)=pizda(1,2)+pizda(2,1)
11086 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11088 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11090 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11092 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11093 C Derivatives in gamma(j-1) or gamma(l-1)
11096 s1=dipderg(3,jj,i)*dip(1,kk,k)
11098 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11099 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11100 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11101 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11102 vv(1)=pizda(1,1)-pizda(2,2)
11103 vv(2)=pizda(1,2)+pizda(2,1)
11104 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11107 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11109 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11112 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11113 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11115 C Derivatives in gamma(l-1) or gamma(j-1)
11118 s1=dip(1,jj,i)*dipderg(3,kk,k)
11120 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11121 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11122 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11123 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11124 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11125 vv(1)=pizda(1,1)-pizda(2,2)
11126 vv(2)=pizda(1,2)+pizda(2,1)
11127 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11130 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11132 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11135 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11136 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11138 C Cartesian derivatives.
11140 write (2,*) 'In eello6_graph2'
11142 write (2,*) 'iii=',iii
11144 write (2,*) 'kkk=',kkk
11146 write (2,'(3(2f10.5),5x)')
11147 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11157 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11159 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11162 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11164 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11165 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11167 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11168 call transpose2(EUg(1,1,k),auxmat(1,1))
11169 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11171 vv(1)=pizda(1,1)-pizda(2,2)
11172 vv(2)=pizda(1,2)+pizda(2,1)
11173 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11174 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11176 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11178 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11181 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11183 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11190 c----------------------------------------------------------------------------
11191 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11192 implicit real*8 (a-h,o-z)
11193 include 'DIMENSIONS'
11194 include 'COMMON.IOUNITS'
11195 include 'COMMON.CHAIN'
11196 include 'COMMON.DERIV'
11197 include 'COMMON.INTERACT'
11198 include 'COMMON.CONTACTS'
11199 include 'COMMON.TORSION'
11200 include 'COMMON.VAR'
11201 include 'COMMON.GEO'
11202 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11204 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11206 C Parallel Antiparallel C
11211 C /| o |o o| o |\ C
11212 C j|/k\| / |/k\|l / C
11217 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11219 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11220 C energy moment and not to the cluster cumulant.
11221 iti=itortyp(itype(i))
11222 if (j.lt.nres-1) then
11223 itj1=itype2loc(itype(j+1))
11227 itk=itype2loc(itype(k))
11228 itk1=itype2loc(itype(k+1))
11229 if (l.lt.nres-1) then
11230 itl1=itype2loc(itype(l+1))
11235 s1=dip(4,jj,i)*dip(4,kk,k)
11237 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11238 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11239 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11240 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11241 call transpose2(EE(1,1,k),auxmat(1,1))
11242 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11243 vv(1)=pizda(1,1)+pizda(2,2)
11244 vv(2)=pizda(2,1)-pizda(1,2)
11245 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11246 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11247 cd & "sum",-(s2+s3+s4)
11249 eello6_graph3=-(s1+s2+s3+s4)
11251 eello6_graph3=-(s2+s3+s4)
11253 c eello6_graph3=-s4
11254 C Derivatives in gamma(k-1)
11255 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11256 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11257 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11258 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11259 C Derivatives in gamma(l-1)
11260 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11261 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11262 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11263 vv(1)=pizda(1,1)+pizda(2,2)
11264 vv(2)=pizda(2,1)-pizda(1,2)
11265 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11266 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11267 C Cartesian derivatives.
11273 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11275 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11278 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11280 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11281 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11283 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11284 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11286 vv(1)=pizda(1,1)+pizda(2,2)
11287 vv(2)=pizda(2,1)-pizda(1,2)
11288 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11290 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11292 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11295 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11297 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11299 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11305 c----------------------------------------------------------------------------
11306 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11307 implicit real*8 (a-h,o-z)
11308 include 'DIMENSIONS'
11309 include 'COMMON.IOUNITS'
11310 include 'COMMON.CHAIN'
11311 include 'COMMON.DERIV'
11312 include 'COMMON.INTERACT'
11313 include 'COMMON.CONTACTS'
11314 include 'COMMON.TORSION'
11315 include 'COMMON.VAR'
11316 include 'COMMON.GEO'
11317 include 'COMMON.FFIELD'
11318 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11319 & auxvec1(2),auxmat1(2,2)
11321 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11323 C Parallel Antiparallel C
11328 C /| o |o o| o |\ C
11329 C \ j|/k\| \ |/k\|l C
11334 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11336 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11337 C energy moment and not to the cluster cumulant.
11338 cd write (2,*) 'eello_graph4: wturn6',wturn6
11339 iti=itype2loc(itype(i))
11340 itj=itype2loc(itype(j))
11341 if (j.lt.nres-1) then
11342 itj1=itype2loc(itype(j+1))
11346 itk=itype2loc(itype(k))
11347 if (k.lt.nres-1) then
11348 itk1=itype2loc(itype(k+1))
11352 itl=itype2loc(itype(l))
11353 if (l.lt.nres-1) then
11354 itl1=itype2loc(itype(l+1))
11358 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11359 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11360 cd & ' itl',itl,' itl1',itl1
11362 if (imat.eq.1) then
11363 s1=dip(3,jj,i)*dip(3,kk,k)
11365 s1=dip(2,jj,j)*dip(2,kk,l)
11368 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11369 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11371 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11372 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11374 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11375 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11377 call transpose2(EUg(1,1,k),auxmat(1,1))
11378 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11379 vv(1)=pizda(1,1)-pizda(2,2)
11380 vv(2)=pizda(2,1)+pizda(1,2)
11381 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11382 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11384 eello6_graph4=-(s1+s2+s3+s4)
11386 eello6_graph4=-(s2+s3+s4)
11388 C Derivatives in gamma(i-1)
11391 if (imat.eq.1) then
11392 s1=dipderg(2,jj,i)*dip(3,kk,k)
11394 s1=dipderg(4,jj,j)*dip(2,kk,l)
11397 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11399 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11400 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11402 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11403 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11405 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11406 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11407 cd write (2,*) 'turn6 derivatives'
11409 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11411 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11415 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11417 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11421 C Derivatives in gamma(k-1)
11423 if (imat.eq.1) then
11424 s1=dip(3,jj,i)*dipderg(2,kk,k)
11426 s1=dip(2,jj,j)*dipderg(4,kk,l)
11429 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11430 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11432 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11433 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11435 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11436 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11438 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11439 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11440 vv(1)=pizda(1,1)-pizda(2,2)
11441 vv(2)=pizda(2,1)+pizda(1,2)
11442 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11443 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11445 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11447 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11451 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11453 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11456 C Derivatives in gamma(j-1) or gamma(l-1)
11457 if (l.eq.j+1 .and. l.gt.1) then
11458 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11459 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11460 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11461 vv(1)=pizda(1,1)-pizda(2,2)
11462 vv(2)=pizda(2,1)+pizda(1,2)
11463 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11464 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11465 else if (j.gt.1) then
11466 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11467 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11468 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11469 vv(1)=pizda(1,1)-pizda(2,2)
11470 vv(2)=pizda(2,1)+pizda(1,2)
11471 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11472 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11473 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11475 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11478 C Cartesian derivatives.
11484 if (imat.eq.1) then
11485 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11487 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11490 if (imat.eq.1) then
11491 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11493 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11497 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11499 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11501 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11502 & b1(1,j+1),auxvec(1))
11503 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11505 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11506 & b1(1,l+1),auxvec(1))
11507 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11509 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11511 vv(1)=pizda(1,1)-pizda(2,2)
11512 vv(2)=pizda(2,1)+pizda(1,2)
11513 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11515 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11517 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11520 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11523 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11526 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11528 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11530 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11534 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11536 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11539 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11541 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11549 c----------------------------------------------------------------------------
11550 double precision function eello_turn6(i,jj,kk)
11551 implicit real*8 (a-h,o-z)
11552 include 'DIMENSIONS'
11553 include 'COMMON.IOUNITS'
11554 include 'COMMON.CHAIN'
11555 include 'COMMON.DERIV'
11556 include 'COMMON.INTERACT'
11557 include 'COMMON.CONTACTS'
11558 include 'COMMON.TORSION'
11559 include 'COMMON.VAR'
11560 include 'COMMON.GEO'
11561 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11562 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11564 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11565 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11566 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11567 C the respective energy moment and not to the cluster cumulant.
11576 iti=itype2loc(itype(i))
11577 itk=itype2loc(itype(k))
11578 itk1=itype2loc(itype(k+1))
11579 itl=itype2loc(itype(l))
11580 itj=itype2loc(itype(j))
11581 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11582 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11583 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11588 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11590 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11594 derx_turn(lll,kkk,iii)=0.0d0
11601 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11603 cd write (2,*) 'eello6_5',eello6_5
11605 call transpose2(AEA(1,1,1),auxmat(1,1))
11606 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11607 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11608 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11610 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11611 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11612 s2 = scalar2(b1(1,k),vtemp1(1))
11614 call transpose2(AEA(1,1,2),atemp(1,1))
11615 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11616 call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11617 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11619 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11620 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11621 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11623 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11624 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11625 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11626 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11627 ss13 = scalar2(b1(1,k),vtemp4(1))
11628 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11630 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11636 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11637 C Derivatives in gamma(i+2)
11641 call transpose2(AEA(1,1,1),auxmatd(1,1))
11642 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11643 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11644 call transpose2(AEAderg(1,1,2),atempd(1,1))
11645 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11646 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11648 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11649 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11650 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11656 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11657 C Derivatives in gamma(i+3)
11659 call transpose2(AEA(1,1,1),auxmatd(1,1))
11660 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11661 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11662 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11664 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11665 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11666 s2d = scalar2(b1(1,k),vtemp1d(1))
11668 call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11669 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11671 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11673 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11674 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11675 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11683 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11684 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11686 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11687 & -0.5d0*ekont*(s2d+s12d)
11689 C Derivatives in gamma(i+4)
11690 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11691 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11692 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11694 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11695 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11696 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11704 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11706 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11708 C Derivatives in gamma(i+5)
11710 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11711 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11712 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11714 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11715 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11716 s2d = scalar2(b1(1,k),vtemp1d(1))
11718 call transpose2(AEA(1,1,2),atempd(1,1))
11719 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11720 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11722 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11723 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11725 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11726 ss13d = scalar2(b1(1,k),vtemp4d(1))
11727 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11735 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11736 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11738 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11739 & -0.5d0*ekont*(s2d+s12d)
11741 C Cartesian derivatives
11746 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11747 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11748 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11750 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11751 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11753 s2d = scalar2(b1(1,k),vtemp1d(1))
11755 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11756 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11757 s8d = -(atempd(1,1)+atempd(2,2))*
11758 & scalar2(cc(1,1,l),vtemp2(1))
11760 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11762 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11763 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11770 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11771 & - 0.5d0*(s1d+s2d)
11773 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11777 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11778 & - 0.5d0*(s8d+s12d)
11780 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11789 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11790 & achuj_tempd(1,1))
11791 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11792 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11793 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11794 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11795 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11797 ss13d = scalar2(b1(1,k),vtemp4d(1))
11798 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11799 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11803 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11804 cd & 16*eel_turn6_num
11806 if (j.lt.nres-1) then
11813 if (l.lt.nres-1) then
11821 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11822 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11823 cgrad ghalf=0.5d0*ggg1(ll)
11825 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11826 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11827 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11828 & +ekont*derx_turn(ll,2,1)
11829 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11830 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11831 & +ekont*derx_turn(ll,4,1)
11832 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11833 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11834 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11835 cgrad ghalf=0.5d0*ggg2(ll)
11837 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11838 & +ekont*derx_turn(ll,2,2)
11839 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11840 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11841 & +ekont*derx_turn(ll,4,2)
11842 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11843 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11844 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11849 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11854 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11860 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11865 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11869 cd write (2,*) iii,g_corr6_loc(iii)
11871 eello_turn6=ekont*eel_turn6
11872 cd write (2,*) 'ekont',ekont
11873 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11877 C-----------------------------------------------------------------------------
11878 double precision function scalar(u,v)
11879 !DIR$ INLINEALWAYS scalar
11881 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11884 double precision u(3),v(3)
11885 cd double precision sc
11893 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11896 crc-------------------------------------------------
11897 SUBROUTINE MATVEC2(A1,V1,V2)
11898 !DIR$ INLINEALWAYS MATVEC2
11900 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11902 implicit real*8 (a-h,o-z)
11903 include 'DIMENSIONS'
11904 DIMENSION A1(2,2),V1(2),V2(2)
11908 c 3 VI=VI+A1(I,K)*V1(K)
11912 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11913 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11918 C---------------------------------------
11919 SUBROUTINE MATMAT2(A1,A2,A3)
11921 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11923 implicit real*8 (a-h,o-z)
11924 include 'DIMENSIONS'
11925 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11926 c DIMENSION AI3(2,2)
11930 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11936 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11937 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11938 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11939 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11947 c-------------------------------------------------------------------------
11948 double precision function scalar2(u,v)
11949 !DIR$ INLINEALWAYS scalar2
11951 double precision u(2),v(2)
11952 double precision sc
11954 scalar2=u(1)*v(1)+u(2)*v(2)
11958 C-----------------------------------------------------------------------------
11960 subroutine transpose2(a,at)
11961 !DIR$ INLINEALWAYS transpose2
11963 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11966 double precision a(2,2),at(2,2)
11973 c--------------------------------------------------------------------------
11974 subroutine transpose(n,a,at)
11977 double precision a(n,n),at(n,n)
11985 C---------------------------------------------------------------------------
11986 subroutine prodmat3(a1,a2,kk,transp,prod)
11987 !DIR$ INLINEALWAYS prodmat3
11989 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11993 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11995 crc double precision auxmat(2,2),prod_(2,2)
11998 crc call transpose2(kk(1,1),auxmat(1,1))
11999 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12000 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12002 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12003 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12004 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12005 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12006 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12007 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12008 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12009 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12012 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12013 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12015 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12016 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12017 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12018 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12019 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12020 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12021 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12022 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12025 c call transpose2(a2(1,1),a2t(1,1))
12028 crc print *,((prod_(i,j),i=1,2),j=1,2)
12029 crc print *,((prod(i,j),i=1,2),j=1,2)
12033 CCC----------------------------------------------
12034 subroutine Eliptransfer(eliptran)
12035 implicit real*8 (a-h,o-z)
12036 include 'DIMENSIONS'
12037 include 'COMMON.GEO'
12038 include 'COMMON.VAR'
12039 include 'COMMON.LOCAL'
12040 include 'COMMON.CHAIN'
12041 include 'COMMON.DERIV'
12042 include 'COMMON.NAMES'
12043 include 'COMMON.INTERACT'
12044 include 'COMMON.IOUNITS'
12045 include 'COMMON.CALC'
12046 include 'COMMON.CONTROL'
12047 include 'COMMON.SPLITELE'
12048 include 'COMMON.SBRIDGE'
12049 C this is done by Adasko
12050 C print *,"wchodze"
12051 C structure of box:
12053 C--bordliptop-- buffore starts
12054 C--bufliptop--- here true lipid starts
12056 C--buflipbot--- lipid ends buffore starts
12057 C--bordlipbot--buffore ends
12059 do i=ilip_start,ilip_end
12061 if (itype(i).eq.ntyp1) cycle
12063 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12064 if (positi.le.0.0) positi=positi+boxzsize
12066 C first for peptide groups
12067 c for each residue check if it is in lipid or lipid water border area
12068 if ((positi.gt.bordlipbot)
12069 &.and.(positi.lt.bordliptop)) then
12070 C the energy transfer exist
12071 if (positi.lt.buflipbot) then
12072 C what fraction I am in
12074 & ((positi-bordlipbot)/lipbufthick)
12075 C lipbufthick is thickenes of lipid buffore
12076 sslip=sscalelip(fracinbuf)
12077 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12078 eliptran=eliptran+sslip*pepliptran
12079 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12080 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12081 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12083 C print *,"doing sccale for lower part"
12084 C print *,i,sslip,fracinbuf,ssgradlip
12085 elseif (positi.gt.bufliptop) then
12086 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12087 sslip=sscalelip(fracinbuf)
12088 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12089 eliptran=eliptran+sslip*pepliptran
12090 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12091 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12092 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12093 C print *, "doing sscalefor top part"
12094 C print *,i,sslip,fracinbuf,ssgradlip
12096 eliptran=eliptran+pepliptran
12097 C print *,"I am in true lipid"
12100 C eliptran=elpitran+0.0 ! I am in water
12103 C print *, "nic nie bylo w lipidzie?"
12104 C now multiply all by the peptide group transfer factor
12105 C eliptran=eliptran*pepliptran
12106 C now the same for side chains
12108 do i=ilip_start,ilip_end
12109 if (itype(i).eq.ntyp1) cycle
12110 positi=(mod(c(3,i+nres),boxzsize))
12111 if (positi.le.0) positi=positi+boxzsize
12112 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12113 c for each residue check if it is in lipid or lipid water border area
12114 C respos=mod(c(3,i+nres),boxzsize)
12115 C print *,positi,bordlipbot,buflipbot
12116 if ((positi.gt.bordlipbot)
12117 & .and.(positi.lt.bordliptop)) then
12118 C the energy transfer exist
12119 if (positi.lt.buflipbot) then
12121 & ((positi-bordlipbot)/lipbufthick)
12122 C lipbufthick is thickenes of lipid buffore
12123 sslip=sscalelip(fracinbuf)
12124 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12125 eliptran=eliptran+sslip*liptranene(itype(i))
12126 gliptranx(3,i)=gliptranx(3,i)
12127 &+ssgradlip*liptranene(itype(i))
12128 gliptranc(3,i-1)= gliptranc(3,i-1)
12129 &+ssgradlip*liptranene(itype(i))
12130 C print *,"doing sccale for lower part"
12131 elseif (positi.gt.bufliptop) then
12133 &((bordliptop-positi)/lipbufthick)
12134 sslip=sscalelip(fracinbuf)
12135 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12136 eliptran=eliptran+sslip*liptranene(itype(i))
12137 gliptranx(3,i)=gliptranx(3,i)
12138 &+ssgradlip*liptranene(itype(i))
12139 gliptranc(3,i-1)= gliptranc(3,i-1)
12140 &+ssgradlip*liptranene(itype(i))
12141 C print *, "doing sscalefor top part",sslip,fracinbuf
12143 eliptran=eliptran+liptranene(itype(i))
12144 C print *,"I am in true lipid"
12146 endif ! if in lipid or buffor
12148 C eliptran=elpitran+0.0 ! I am in water
12152 C---------------------------------------------------------
12153 C AFM soubroutine for constant force
12154 subroutine AFMforce(Eafmforce)
12155 implicit real*8 (a-h,o-z)
12156 include 'DIMENSIONS'
12157 include 'COMMON.GEO'
12158 include 'COMMON.VAR'
12159 include 'COMMON.LOCAL'
12160 include 'COMMON.CHAIN'
12161 include 'COMMON.DERIV'
12162 include 'COMMON.NAMES'
12163 include 'COMMON.INTERACT'
12164 include 'COMMON.IOUNITS'
12165 include 'COMMON.CALC'
12166 include 'COMMON.CONTROL'
12167 include 'COMMON.SPLITELE'
12168 include 'COMMON.SBRIDGE'
12173 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12174 dist=dist+diffafm(i)**2
12177 Eafmforce=-forceAFMconst*(dist-distafminit)
12179 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12180 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12182 C print *,'AFM',Eafmforce
12185 C---------------------------------------------------------
12186 C AFM subroutine with pseudoconstant velocity
12187 subroutine AFMvel(Eafmforce)
12188 implicit real*8 (a-h,o-z)
12189 include 'DIMENSIONS'
12190 include 'COMMON.GEO'
12191 include 'COMMON.VAR'
12192 include 'COMMON.LOCAL'
12193 include 'COMMON.CHAIN'
12194 include 'COMMON.DERIV'
12195 include 'COMMON.NAMES'
12196 include 'COMMON.INTERACT'
12197 include 'COMMON.IOUNITS'
12198 include 'COMMON.CALC'
12199 include 'COMMON.CONTROL'
12200 include 'COMMON.SPLITELE'
12201 include 'COMMON.SBRIDGE'
12203 C Only for check grad COMMENT if not used for checkgrad
12205 C--------------------------------------------------------
12206 C print *,"wchodze"
12210 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12211 dist=dist+diffafm(i)**2
12214 Eafmforce=0.5d0*forceAFMconst
12215 & *(distafminit+totTafm*velAFMconst-dist)**2
12216 C Eafmforce=-forceAFMconst*(dist-distafminit)
12218 gradafm(i,afmend-1)=-forceAFMconst*
12219 &(distafminit+totTafm*velAFMconst-dist)
12221 gradafm(i,afmbeg-1)=forceAFMconst*
12222 &(distafminit+totTafm*velAFMconst-dist)
12225 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12228 C-----------------------------------------------------------
12229 C first for shielding is setting of function of side-chains
12230 subroutine set_shield_fac
12231 implicit real*8 (a-h,o-z)
12232 include 'DIMENSIONS'
12233 include 'COMMON.CHAIN'
12234 include 'COMMON.DERIV'
12235 include 'COMMON.IOUNITS'
12236 include 'COMMON.SHIELD'
12237 include 'COMMON.INTERACT'
12238 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12239 double precision div77_81/0.974996043d0/,
12240 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12242 C the vector between center of side_chain and peptide group
12243 double precision pep_side(3),long,side_calf(3),
12244 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12245 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12246 C the line belowe needs to be changed for FGPROC>1
12248 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12250 Cif there two consequtive dummy atoms there is no peptide group between them
12251 C the line below has to be changed for FGPROC>1
12254 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12258 C first lets set vector conecting the ithe side-chain with kth side-chain
12259 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12260 C pep_side(j)=2.0d0
12261 C and vector conecting the side-chain with its proper calfa
12262 side_calf(j)=c(j,k+nres)-c(j,k)
12263 C side_calf(j)=2.0d0
12264 pept_group(j)=c(j,i)-c(j,i+1)
12265 C lets have their lenght
12266 dist_pep_side=pep_side(j)**2+dist_pep_side
12267 dist_side_calf=dist_side_calf+side_calf(j)**2
12268 dist_pept_group=dist_pept_group+pept_group(j)**2
12270 dist_pep_side=dsqrt(dist_pep_side)
12271 dist_pept_group=dsqrt(dist_pept_group)
12272 dist_side_calf=dsqrt(dist_side_calf)
12274 pep_side_norm(j)=pep_side(j)/dist_pep_side
12275 side_calf_norm(j)=dist_side_calf
12277 C now sscale fraction
12278 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12279 C print *,buff_shield,"buff"
12281 if (sh_frac_dist.le.0.0) cycle
12282 C If we reach here it means that this side chain reaches the shielding sphere
12283 C Lets add him to the list for gradient
12284 ishield_list(i)=ishield_list(i)+1
12285 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12286 C this list is essential otherwise problem would be O3
12287 shield_list(ishield_list(i),i)=k
12288 C Lets have the sscale value
12289 if (sh_frac_dist.gt.1.0) then
12290 scale_fac_dist=1.0d0
12292 sh_frac_dist_grad(j)=0.0d0
12295 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12296 & *(2.0*sh_frac_dist-3.0d0)
12297 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12298 & /dist_pep_side/buff_shield*0.5
12299 C remember for the final gradient multiply sh_frac_dist_grad(j)
12300 C for side_chain by factor -2 !
12302 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12303 C print *,"jestem",scale_fac_dist,fac_help_scale,
12304 C & sh_frac_dist_grad(j)
12307 C if ((i.eq.3).and.(k.eq.2)) then
12308 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12312 C this is what is now we have the distance scaling now volume...
12313 short=short_r_sidechain(itype(k))
12314 long=long_r_sidechain(itype(k))
12315 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12318 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12319 C costhet_fac=0.0d0
12321 costhet_grad(j)=costhet_fac*pep_side(j)
12323 C remember for the final gradient multiply costhet_grad(j)
12324 C for side_chain by factor -2 !
12325 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12326 C pep_side0pept_group is vector multiplication
12327 pep_side0pept_group=0.0
12329 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12331 cosalfa=(pep_side0pept_group/
12332 & (dist_pep_side*dist_side_calf))
12333 fac_alfa_sin=1.0-cosalfa**2
12334 fac_alfa_sin=dsqrt(fac_alfa_sin)
12335 rkprim=fac_alfa_sin*(long-short)+short
12337 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12338 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12341 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12342 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12343 &*(long-short)/fac_alfa_sin*cosalfa/
12344 &((dist_pep_side*dist_side_calf))*
12345 &((side_calf(j))-cosalfa*
12346 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12348 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12349 &*(long-short)/fac_alfa_sin*cosalfa
12350 &/((dist_pep_side*dist_side_calf))*
12352 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12355 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12358 C now the gradient...
12359 C grad_shield is gradient of Calfa for peptide groups
12360 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12362 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12363 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12365 grad_shield(j,i)=grad_shield(j,i)
12366 C gradient po skalowaniu
12367 & +(sh_frac_dist_grad(j)
12368 C gradient po costhet
12369 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12370 &-scale_fac_dist*(cosphi_grad_long(j))
12371 &/(1.0-cosphi) )*div77_81
12373 C grad_shield_side is Cbeta sidechain gradient
12374 grad_shield_side(j,ishield_list(i),i)=
12375 & (sh_frac_dist_grad(j)*(-2.0d0)
12376 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12377 & +scale_fac_dist*(cosphi_grad_long(j))
12378 & *2.0d0/(1.0-cosphi))
12379 & *div77_81*VofOverlap
12381 grad_shield_loc(j,ishield_list(i),i)=
12382 & scale_fac_dist*cosphi_grad_loc(j)
12383 & *2.0d0/(1.0-cosphi)
12384 & *div77_81*VofOverlap
12386 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12388 fac_shield(i)=VolumeTotal*div77_81+div4_81
12389 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12393 C--------------------------------------------------------------------------
12394 double precision function tschebyshev(m,n,x,y)
12396 include "DIMENSIONS"
12398 double precision x(n),y,yy(0:maxvar),aux
12399 c Tschebyshev polynomial. Note that the first term is omitted
12400 c m=0: the constant term is included
12401 c m=1: the constant term is not included
12405 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12414 C--------------------------------------------------------------------------
12415 double precision function gradtschebyshev(m,n,x,y)
12417 include "DIMENSIONS"
12419 double precision x(n+1),y,yy(0:maxvar),aux
12420 c Tschebyshev polynomial. Note that the first term is omitted
12421 c m=0: the constant term is included
12422 c m=1: the constant term is not included
12426 yy(i)=2*y*yy(i-1)-yy(i-2)
12430 aux=aux+x(i+1)*yy(i)*(i+1)
12431 C print *, x(i+1),yy(i),i
12433 gradtschebyshev=aux
12436 C------------------------------------------------------------------------
12437 C first for shielding is setting of function of side-chains
12438 subroutine set_shield_fac2
12439 implicit real*8 (a-h,o-z)
12440 include 'DIMENSIONS'
12441 include 'COMMON.CHAIN'
12442 include 'COMMON.DERIV'
12443 include 'COMMON.IOUNITS'
12444 include 'COMMON.SHIELD'
12445 include 'COMMON.INTERACT'
12446 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12447 double precision div77_81/0.974996043d0/,
12448 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12450 C the vector between center of side_chain and peptide group
12451 double precision pep_side(3),long,side_calf(3),
12452 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12453 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12454 C the line belowe needs to be changed for FGPROC>1
12456 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12458 Cif there two consequtive dummy atoms there is no peptide group between them
12459 C the line below has to be changed for FGPROC>1
12462 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12466 C first lets set vector conecting the ithe side-chain with kth side-chain
12467 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12468 C pep_side(j)=2.0d0
12469 C and vector conecting the side-chain with its proper calfa
12470 side_calf(j)=c(j,k+nres)-c(j,k)
12471 C side_calf(j)=2.0d0
12472 pept_group(j)=c(j,i)-c(j,i+1)
12473 C lets have their lenght
12474 dist_pep_side=pep_side(j)**2+dist_pep_side
12475 dist_side_calf=dist_side_calf+side_calf(j)**2
12476 dist_pept_group=dist_pept_group+pept_group(j)**2
12478 dist_pep_side=dsqrt(dist_pep_side)
12479 dist_pept_group=dsqrt(dist_pept_group)
12480 dist_side_calf=dsqrt(dist_side_calf)
12482 pep_side_norm(j)=pep_side(j)/dist_pep_side
12483 side_calf_norm(j)=dist_side_calf
12485 C now sscale fraction
12486 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12487 C print *,buff_shield,"buff"
12489 if (sh_frac_dist.le.0.0) cycle
12490 C If we reach here it means that this side chain reaches the shielding sphere
12491 C Lets add him to the list for gradient
12492 ishield_list(i)=ishield_list(i)+1
12493 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12494 C this list is essential otherwise problem would be O3
12495 shield_list(ishield_list(i),i)=k
12496 C Lets have the sscale value
12497 if (sh_frac_dist.gt.1.0) then
12498 scale_fac_dist=1.0d0
12500 sh_frac_dist_grad(j)=0.0d0
12503 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12504 & *(2.0d0*sh_frac_dist-3.0d0)
12505 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12506 & /dist_pep_side/buff_shield*0.5d0
12507 C remember for the final gradient multiply sh_frac_dist_grad(j)
12508 C for side_chain by factor -2 !
12510 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12511 C sh_frac_dist_grad(j)=0.0d0
12512 C scale_fac_dist=1.0d0
12513 C print *,"jestem",scale_fac_dist,fac_help_scale,
12514 C & sh_frac_dist_grad(j)
12517 C this is what is now we have the distance scaling now volume...
12518 short=short_r_sidechain(itype(k))
12519 long=long_r_sidechain(itype(k))
12520 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12521 sinthet=short/dist_pep_side*costhet
12525 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12526 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12527 C & -short/dist_pep_side**2/costhet)
12528 C costhet_fac=0.0d0
12530 costhet_grad(j)=costhet_fac*pep_side(j)
12532 C remember for the final gradient multiply costhet_grad(j)
12533 C for side_chain by factor -2 !
12534 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12535 C pep_side0pept_group is vector multiplication
12536 pep_side0pept_group=0.0d0
12538 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12540 cosalfa=(pep_side0pept_group/
12541 & (dist_pep_side*dist_side_calf))
12542 fac_alfa_sin=1.0d0-cosalfa**2
12543 fac_alfa_sin=dsqrt(fac_alfa_sin)
12544 rkprim=fac_alfa_sin*(long-short)+short
12548 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12550 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12551 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12552 & dist_pep_side**2)
12555 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12556 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12557 &*(long-short)/fac_alfa_sin*cosalfa/
12558 &((dist_pep_side*dist_side_calf))*
12559 &((side_calf(j))-cosalfa*
12560 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12561 C cosphi_grad_long(j)=0.0d0
12562 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12563 &*(long-short)/fac_alfa_sin*cosalfa
12564 &/((dist_pep_side*dist_side_calf))*
12566 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12567 C cosphi_grad_loc(j)=0.0d0
12569 C print *,sinphi,sinthet
12570 c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12571 c & VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12572 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12575 C now the gradient...
12577 grad_shield(j,i)=grad_shield(j,i)
12578 C gradient po skalowaniu
12579 & +(sh_frac_dist_grad(j)*VofOverlap
12580 C gradient po costhet
12581 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12582 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12583 & sinphi/sinthet*costhet*costhet_grad(j)
12584 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12586 C grad_shield_side is Cbeta sidechain gradient
12587 grad_shield_side(j,ishield_list(i),i)=
12588 & (sh_frac_dist_grad(j)*(-2.0d0)
12590 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12591 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12592 & sinphi/sinthet*costhet*costhet_grad(j)
12593 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12596 grad_shield_loc(j,ishield_list(i),i)=
12597 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12598 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12599 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12603 c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12605 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12607 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12608 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12609 c & " wshield",wshield
12610 c write(2,*) "TU",rpp(1,1),short,long,buff_shield
12614 C-----------------------------------------------------------------------
12615 C-----------------------------------------------------------
12616 C This subroutine is to mimic the histone like structure but as well can be
12617 C utilizet to nanostructures (infinit) small modification has to be used to
12618 C make it finite (z gradient at the ends has to be changes as well as the x,y
12619 C gradient has to be modified at the ends
12620 C The energy function is Kihara potential
12621 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12622 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12623 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12624 C simple Kihara potential
12625 subroutine calctube(Etube)
12626 implicit real*8 (a-h,o-z)
12627 include 'DIMENSIONS'
12628 include 'COMMON.GEO'
12629 include 'COMMON.VAR'
12630 include 'COMMON.LOCAL'
12631 include 'COMMON.CHAIN'
12632 include 'COMMON.DERIV'
12633 include 'COMMON.NAMES'
12634 include 'COMMON.INTERACT'
12635 include 'COMMON.IOUNITS'
12636 include 'COMMON.CALC'
12637 include 'COMMON.CONTROL'
12638 include 'COMMON.SPLITELE'
12639 include 'COMMON.SBRIDGE'
12640 double precision tub_r,vectube(3),enetube(maxres*2)
12645 C first we calculate the distance from tube center
12646 C first sugare-phosphate group for NARES this would be peptide group
12649 C lets ommit dummy atoms for now
12650 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12651 C now calculate distance from center of tube and direction vectors
12652 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12653 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12654 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12655 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12656 vectube(1)=vectube(1)-tubecenter(1)
12657 vectube(2)=vectube(2)-tubecenter(2)
12659 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12660 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12662 C as the tube is infinity we do not calculate the Z-vector use of Z
12665 C now calculte the distance
12666 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12667 C now normalize vector
12668 vectube(1)=vectube(1)/tub_r
12669 vectube(2)=vectube(2)/tub_r
12670 C calculte rdiffrence between r and r0
12673 rdiff6=rdiff**6.0d0
12674 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12675 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12676 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12677 C print *,rdiff,rdiff6,pep_aa_tube
12678 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12679 C now we calculate gradient
12680 fac=(-12.0d0*pep_aa_tube/rdiff6+
12681 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12682 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12685 C now direction of gg_tube vector
12687 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12688 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12691 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12693 C Lets not jump over memory as we use many times iti
12695 C lets ommit dummy atoms for now
12697 C in UNRES uncomment the line below as GLY has no side-chain...
12700 vectube(1)=c(1,i+nres)
12701 vectube(1)=mod(vectube(1),boxxsize)
12702 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12703 vectube(2)=c(2,i+nres)
12704 vectube(2)=mod(vectube(2),boxxsize)
12705 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12707 vectube(1)=vectube(1)-tubecenter(1)
12708 vectube(2)=vectube(2)-tubecenter(2)
12710 C as the tube is infinity we do not calculate the Z-vector use of Z
12713 C now calculte the distance
12714 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12715 C now normalize vector
12716 vectube(1)=vectube(1)/tub_r
12717 vectube(2)=vectube(2)/tub_r
12718 C calculte rdiffrence between r and r0
12721 rdiff6=rdiff**6.0d0
12722 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12723 sc_aa_tube=sc_aa_tube_par(iti)
12724 sc_bb_tube=sc_bb_tube_par(iti)
12725 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12726 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12727 C now we calculate gradient
12728 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12729 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12730 C now direction of gg_tube vector
12732 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12733 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12737 Etube=Etube+enetube(i)
12739 C print *,"ETUBE", etube
12742 C TO DO 1) add to total energy
12743 C 2) add to gradient summation
12744 C 3) add reading parameters (AND of course oppening of PARAM file)
12745 C 4) add reading the center of tube
12747 C 6) add to zerograd
12749 C-----------------------------------------------------------------------
12750 C-----------------------------------------------------------
12751 C This subroutine is to mimic the histone like structure but as well can be
12752 C utilizet to nanostructures (infinit) small modification has to be used to
12753 C make it finite (z gradient at the ends has to be changes as well as the x,y
12754 C gradient has to be modified at the ends
12755 C The energy function is Kihara potential
12756 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12757 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12758 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12759 C simple Kihara potential
12760 subroutine calctube2(Etube)
12761 implicit real*8 (a-h,o-z)
12762 include 'DIMENSIONS'
12763 include 'COMMON.GEO'
12764 include 'COMMON.VAR'
12765 include 'COMMON.LOCAL'
12766 include 'COMMON.CHAIN'
12767 include 'COMMON.DERIV'
12768 include 'COMMON.NAMES'
12769 include 'COMMON.INTERACT'
12770 include 'COMMON.IOUNITS'
12771 include 'COMMON.CALC'
12772 include 'COMMON.CONTROL'
12773 include 'COMMON.SPLITELE'
12774 include 'COMMON.SBRIDGE'
12775 double precision tub_r,vectube(3),enetube(maxres*2)
12780 C first we calculate the distance from tube center
12781 C first sugare-phosphate group for NARES this would be peptide group
12784 C lets ommit dummy atoms for now
12785 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12786 C now calculate distance from center of tube and direction vectors
12787 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12788 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12789 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12790 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12791 vectube(1)=vectube(1)-tubecenter(1)
12792 vectube(2)=vectube(2)-tubecenter(2)
12794 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12795 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12797 C as the tube is infinity we do not calculate the Z-vector use of Z
12800 C now calculte the distance
12801 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12802 C now normalize vector
12803 vectube(1)=vectube(1)/tub_r
12804 vectube(2)=vectube(2)/tub_r
12805 C calculte rdiffrence between r and r0
12808 rdiff6=rdiff**6.0d0
12809 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12810 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12811 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12812 C print *,rdiff,rdiff6,pep_aa_tube
12813 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12814 C now we calculate gradient
12815 fac=(-12.0d0*pep_aa_tube/rdiff6+
12816 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12817 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12820 C now direction of gg_tube vector
12822 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12823 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12826 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12828 C Lets not jump over memory as we use many times iti
12830 C lets ommit dummy atoms for now
12832 C in UNRES uncomment the line below as GLY has no side-chain...
12835 vectube(1)=c(1,i+nres)
12836 vectube(1)=mod(vectube(1),boxxsize)
12837 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12838 vectube(2)=c(2,i+nres)
12839 vectube(2)=mod(vectube(2),boxxsize)
12840 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12842 vectube(1)=vectube(1)-tubecenter(1)
12843 vectube(2)=vectube(2)-tubecenter(2)
12844 C THIS FRAGMENT MAKES TUBE FINITE
12845 positi=(mod(c(3,i+nres),boxzsize))
12846 if (positi.le.0) positi=positi+boxzsize
12847 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12848 c for each residue check if it is in lipid or lipid water border area
12849 C respos=mod(c(3,i+nres),boxzsize)
12850 print *,positi,bordtubebot,buftubebot,bordtubetop
12851 if ((positi.gt.bordtubebot)
12852 & .and.(positi.lt.bordtubetop)) then
12853 C the energy transfer exist
12854 if (positi.lt.buftubebot) then
12856 & ((positi-bordtubebot)/tubebufthick)
12857 C lipbufthick is thickenes of lipid buffore
12858 sstube=sscalelip(fracinbuf)
12859 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12860 print *,ssgradtube, sstube,tubetranene(itype(i))
12861 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12862 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12863 &+ssgradtube*tubetranene(itype(i))
12864 gg_tube(3,i-1)= gg_tube(3,i-1)
12865 &+ssgradtube*tubetranene(itype(i))
12866 C print *,"doing sccale for lower part"
12867 elseif (positi.gt.buftubetop) then
12869 &((bordtubetop-positi)/tubebufthick)
12870 sstube=sscalelip(fracinbuf)
12871 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12872 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12873 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12874 C &+ssgradtube*tubetranene(itype(i))
12875 C gg_tube(3,i-1)= gg_tube(3,i-1)
12876 C &+ssgradtube*tubetranene(itype(i))
12877 C print *, "doing sscalefor top part",sslip,fracinbuf
12881 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12882 C print *,"I am in true lipid"
12888 endif ! if in lipid or buffor
12889 CEND OF FINITE FRAGMENT
12890 C as the tube is infinity we do not calculate the Z-vector use of Z
12893 C now calculte the distance
12894 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12895 C now normalize vector
12896 vectube(1)=vectube(1)/tub_r
12897 vectube(2)=vectube(2)/tub_r
12898 C calculte rdiffrence between r and r0
12901 rdiff6=rdiff**6.0d0
12902 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12903 sc_aa_tube=sc_aa_tube_par(iti)
12904 sc_bb_tube=sc_bb_tube_par(iti)
12905 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12906 & *sstube+enetube(i+nres)
12907 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12908 C now we calculate gradient
12909 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12910 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12911 C now direction of gg_tube vector
12913 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12914 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12916 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12917 &+ssgradtube*enetube(i+nres)/sstube
12918 gg_tube(3,i-1)= gg_tube(3,i-1)
12919 &+ssgradtube*enetube(i+nres)/sstube
12923 Etube=Etube+enetube(i)
12925 C print *,"ETUBE", etube
12928 C TO DO 1) add to total energy
12929 C 2) add to gradient summation
12930 C 3) add reading parameters (AND of course oppening of PARAM file)
12931 C 4) add reading the center of tube
12933 C 6) add to zerograd
12934 c----------------------------------------------------------------------------
12935 subroutine e_saxs(Esaxs_constr)
12937 include 'DIMENSIONS'
12940 include "COMMON.SETUP"
12943 include 'COMMON.SBRIDGE'
12944 include 'COMMON.CHAIN'
12945 include 'COMMON.GEO'
12946 include 'COMMON.DERIV'
12947 include 'COMMON.LOCAL'
12948 include 'COMMON.INTERACT'
12949 include 'COMMON.VAR'
12950 include 'COMMON.IOUNITS'
12951 c include 'COMMON.MD'
12954 include 'COMMON.LANGEVIN.lang0.5diag'
12956 include 'COMMON.LANGEVIN.lang0'
12959 include 'COMMON.LANGEVIN'
12961 include 'COMMON.CONTROL'
12962 include 'COMMON.SAXS'
12963 include 'COMMON.NAMES'
12964 include 'COMMON.TIME1'
12965 include 'COMMON.FFIELD'
12967 double precision Esaxs_constr
12968 integer i,iint,j,k,l
12969 double precision PgradC(maxSAXS,3,maxres),
12970 & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12972 double precision PgradC_(maxSAXS,3,maxres),
12973 & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12975 double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12976 & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12977 & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12978 & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12979 double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12980 double precision dist,mygauss,mygaussder
12982 integer llicz,lllicz
12983 double precision time01
12984 c SAXS restraint penalty function
12986 write(iout,*) "------- SAXS penalty function start -------"
12987 write (iout,*) "nsaxs",nsaxs
12988 write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12989 write (iout,*) "Psaxs"
12991 write (iout,'(i5,e15.5)') i, Psaxs(i)
12997 Esaxs_constr = 0.0d0
13002 PgradC(k,l,j)=0.0d0
13003 PgradX(k,l,j)=0.0d0
13008 do i=iatsc_s,iatsc_e
13009 if (itype(i).eq.ntyp1) cycle
13010 do iint=1,nint_gr(i)
13011 do j=istart(i,iint),iend(i,iint)
13012 if (itype(j).eq.ntyp1) cycle
13015 dijCASC=dist(i,j+nres)
13016 dijSCCA=dist(i+nres,j)
13017 dijSCSC=dist(i+nres,j+nres)
13018 sigma2CACA=2.0d0/(pstok**2)
13019 sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13020 sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13021 sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13024 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13025 if (itype(j).ne.10) then
13026 expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13030 if (itype(i).ne.10) then
13031 expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13035 if (itype(i).ne.10 .and. itype(j).ne.10) then
13036 expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13040 Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13042 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13044 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13045 CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13046 SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13047 SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13050 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13051 PgradC(k,l,i) = PgradC(k,l,i)-aux
13052 PgradC(k,l,j) = PgradC(k,l,j)+aux
13054 if (itype(j).ne.10) then
13055 aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13056 PgradC(k,l,i) = PgradC(k,l,i)-aux
13057 PgradC(k,l,j) = PgradC(k,l,j)+aux
13058 PgradX(k,l,j) = PgradX(k,l,j)+aux
13061 if (itype(i).ne.10) then
13062 aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13063 PgradX(k,l,i) = PgradX(k,l,i)-aux
13064 PgradC(k,l,i) = PgradC(k,l,i)-aux
13065 PgradC(k,l,j) = PgradC(k,l,j)+aux
13068 if (itype(i).ne.10 .and. itype(j).ne.10) then
13069 aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13070 PgradC(k,l,i) = PgradC(k,l,i)-aux
13071 PgradC(k,l,j) = PgradC(k,l,j)+aux
13072 PgradX(k,l,i) = PgradX(k,l,i)-aux
13073 PgradX(k,l,j) = PgradX(k,l,j)+aux
13079 sigma2CACA=scal_rad**2*0.25d0/
13080 & (restok(itype(j))**2+restok(itype(i))**2)
13081 c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13082 c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13084 sigmaCACA=dsqrt(sigma2CACA)
13085 threesig=3.0d0/sigmaCACA
13089 if (dabs(dijCACA-dk).ge.threesig) cycle
13092 aux = sigmaCACA*(dijCACA-dk)
13093 expCACA = mygauss(aux)
13094 c if (expcaca.eq.0.0d0) cycle
13095 Pcalc(k) = Pcalc(k)+expCACA
13096 CACAgrad = -sigmaCACA*mygaussder(aux)
13097 c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13099 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13100 PgradC(k,l,i) = PgradC(k,l,i)-aux
13101 PgradC(k,l,j) = PgradC(k,l,j)+aux
13104 c write (iout,*) "i",i," j",j," llicz",llicz
13106 IF (saxs_cutoff.eq.0) THEN
13109 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13110 Pcalc(k) = Pcalc(k)+expCACA
13111 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13113 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13114 PgradC(k,l,i) = PgradC(k,l,i)-aux
13115 PgradC(k,l,j) = PgradC(k,l,j)+aux
13119 rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13122 c write (2,*) "ijk",i,j,k
13123 sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13124 if (sss2.eq.0.0d0) cycle
13125 ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13126 if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13127 & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13128 & 1.0d0/dsqrt(sigma2CACA),rrr,dk,
13130 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13131 Pcalc(k) = Pcalc(k)+expCACA
13133 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13135 CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13136 & ssgrad2*expCACA/sss2
13139 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13140 PgradC(k,l,i) = PgradC(k,l,i)+aux
13141 PgradC(k,l,j) = PgradC(k,l,j)-aux
13151 c time_SAXS=time_SAXS+MPI_Wtime()-time01
13153 c write (iout,*) "lllicz",lllicz
13155 c time01=MPI_Wtime()
13158 if (nfgtasks.gt.1) then
13159 call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13160 & MPI_SUM,FG_COMM,IERR)
13161 c if (fg_rank.eq.king) then
13163 Pcalc(k) = Pcalc_(k)
13166 c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13167 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13168 c if (fg_rank.eq.king) then
13172 c PgradC(k,l,i) = PgradC_(k,l,i)
13178 c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13179 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13180 c if (fg_rank.eq.king) then
13184 c PgradX(k,l,i) = PgradX_(k,l,i)
13194 Cnorm = Cnorm + Pcalc(k)
13197 if (fg_rank.eq.king) then
13199 Esaxs_constr = dlog(Cnorm)-wsaxs0
13201 if (Pcalc(k).gt.0.0d0)
13202 & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13204 write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13208 write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13223 & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13224 auxC1 = auxC1+PgradC(k,l,i)
13226 auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13227 auxX1 = auxX1+PgradX(k,l,i)
13230 gsaxsC(l,i) = auxC - auxC1/Cnorm
13232 gsaxsX(l,i) = auxX - auxX1/Cnorm
13234 c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13235 c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
13236 c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13237 c * " gradX",wsaxs*gsaxsX(l,i)
13241 time_SAXS=time_SAXS+MPI_Wtime()-time01
13244 write (iout,*) "gsaxsc"
13246 write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13254 c----------------------------------------------------------------------------
13255 subroutine e_saxsC(Esaxs_constr)
13257 include 'DIMENSIONS'
13260 include "COMMON.SETUP"
13263 include 'COMMON.SBRIDGE'
13264 include 'COMMON.CHAIN'
13265 include 'COMMON.GEO'
13266 include 'COMMON.DERIV'
13267 include 'COMMON.LOCAL'
13268 include 'COMMON.INTERACT'
13269 include 'COMMON.VAR'
13270 include 'COMMON.IOUNITS'
13271 c include 'COMMON.MD'
13274 include 'COMMON.LANGEVIN.lang0.5diag'
13276 include 'COMMON.LANGEVIN.lang0'
13279 include 'COMMON.LANGEVIN'
13281 include 'COMMON.CONTROL'
13282 include 'COMMON.SAXS'
13283 include 'COMMON.NAMES'
13284 include 'COMMON.TIME1'
13285 include 'COMMON.FFIELD'
13287 double precision Esaxs_constr
13288 integer i,iint,j,k,l
13289 double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13291 double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13293 double precision dk,dijCASPH,dijSCSPH,
13294 & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13295 & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13297 c SAXS restraint penalty function
13299 write(iout,*) "------- SAXS penalty function start -------"
13300 write (iout,*) "nsaxs",nsaxs
13303 print *,MyRank,"C",i,(C(j,i),j=1,3)
13306 print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13309 Esaxs_constr = 0.0d0
13311 do j=isaxs_start,isaxs_end
13320 if (itype(i).eq.ntyp1) cycle
13324 dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13326 if (itype(i).ne.10) then
13328 dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13331 sigma2CA=2.0d0/pstok**2
13332 sigma2SC=4.0d0/restok(itype(i))**2
13333 expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13334 expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13335 Pcalc = Pcalc+expCASPH+expSCSPH
13337 write(*,*) "processor i j Pcalc",
13338 & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13340 CASPHgrad = sigma2CA*expCASPH
13341 SCSPHgrad = sigma2SC*expSCSPH
13343 aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13344 PgradX(l,i) = PgradX(l,i) + aux
13345 PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13350 gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13351 gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13354 logPtot = logPtot - dlog(Pcalc)
13355 c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13356 c & " logPtot",logPtot
13359 if (nfgtasks.gt.1) then
13360 c write (iout,*) "logPtot before reduction",logPtot
13361 call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13362 & MPI_SUM,king,FG_COMM,IERR)
13364 c write (iout,*) "logPtot after reduction",logPtot
13365 call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13366 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13367 if (fg_rank.eq.king) then
13370 gsaxsC(l,i) = gsaxsC_(l,i)
13374 call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13375 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13376 if (fg_rank.eq.king) then
13379 gsaxsX(l,i) = gsaxsX_(l,i)
13385 Esaxs_constr = logPtot
13388 c----------------------------------------------------------------------------
13389 double precision function sscale2(r,r_cut,r0,rlamb)
13391 double precision r,gamm,r_cut,r0,rlamb,rr
13393 c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13394 c write (2,*) "rr",rr
13395 if(rr.lt.r_cut-rlamb) then
13397 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13398 gamm=(rr-(r_cut-rlamb))/rlamb
13399 sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13405 C-----------------------------------------------------------------------
13406 double precision function sscalgrad2(r,r_cut,r0,rlamb)
13408 double precision r,gamm,r_cut,r0,rlamb,rr
13410 if(rr.lt.r_cut-rlamb) then
13412 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13413 gamm=(rr-(r_cut-rlamb))/rlamb
13415 sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13417 sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb