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'
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,gsccorr_norm,gscloc_norm,gvdwx_norm,
649 &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
650 &gsclocx_norm,gradcorr6_max,gsccorr_max,gsccorrx_max
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 gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1135 if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_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,gsccorc_max,
1162 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1163 & gsccorx_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 kfac /2.4d0/
1202 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1203 double precision facT,facT2,facT3,facT4,facT5
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'
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,uconst,
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 include 'DIMENSIONS'
1416 double precision accur
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
1432 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2
1433 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1435 do i=iatsc_s,iatsc_e
1436 itypi=iabs(itype(i))
1437 if (itypi.eq.ntyp1) cycle
1438 itypi1=iabs(itype(i+1))
1445 C Calculate SC interaction energy.
1447 do iint=1,nint_gr(i)
1448 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1449 cd & 'iend=',iend(i,iint)
1450 do j=istart(i,iint),iend(i,iint)
1451 itypj=iabs(itype(j))
1452 if (itypj.eq.ntyp1) cycle
1456 C Change 12/1/95 to calculate four-body interactions
1457 rij=xj*xj+yj*yj+zj*zj
1459 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1460 eps0ij=eps(itypi,itypj)
1462 C have you changed here?
1466 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1467 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1468 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1469 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1470 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1471 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1474 C Calculate the components of the gradient in DC and X
1476 fac=-rrij*(e1+evdwij)
1481 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1482 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1483 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1484 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1488 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1492 C 12/1/95, revised on 5/20/97
1494 C Calculate the contact function. The ith column of the array JCONT will
1495 C contain the numbers of atoms that make contacts with the atom I (of numbers
1496 C greater than I). The arrays FACONT and GACONT will contain the values of
1497 C the contact function and its derivative.
1499 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1500 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1501 C Uncomment next line, if the correlation interactions are contact function only
1502 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1504 sigij=sigma(itypi,itypj)
1505 r0ij=rs0(itypi,itypj)
1507 C Check whether the SC's are not too far to make a contact.
1510 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1511 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1513 if (fcont.gt.0.0D0) then
1514 C If the SC-SC distance if close to sigma, apply spline.
1515 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1516 cAdam & fcont1,fprimcont1)
1517 cAdam fcont1=1.0d0-fcont1
1518 cAdam if (fcont1.gt.0.0d0) then
1519 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1520 cAdam fcont=fcont*fcont1
1522 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1524 cga gg(k)=gg(k)*eps0ij
1526 cga eps0ij=-evdwij*eps0ij
1527 C Uncomment for AL's type of SC correlation interactions.
1528 cadam eps0ij=-evdwij
1529 num_conti=num_conti+1
1530 jcont(num_conti,i)=j
1531 facont(num_conti,i)=fcont*eps0ij
1532 fprimcont=eps0ij*fprimcont/rij
1534 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1535 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1536 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1537 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1538 gacont(1,num_conti,i)=-fprimcont*xj
1539 gacont(2,num_conti,i)=-fprimcont*yj
1540 gacont(3,num_conti,i)=-fprimcont*zj
1541 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1542 cd write (iout,'(2i3,3f10.5)')
1543 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1549 num_cont(i)=num_conti
1553 gvdwc(j,i)=expon*gvdwc(j,i)
1554 gvdwx(j,i)=expon*gvdwx(j,i)
1557 C******************************************************************************
1561 C To save time, the factor of EXPON has been extracted from ALL components
1562 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1565 C******************************************************************************
1568 C-----------------------------------------------------------------------------
1569 subroutine eljk(evdw)
1571 C This subroutine calculates the interaction energy of nonbonded side chains
1572 C assuming the LJK potential of interaction.
1575 include 'DIMENSIONS'
1576 include 'COMMON.GEO'
1577 include 'COMMON.VAR'
1578 include 'COMMON.LOCAL'
1579 include 'COMMON.CHAIN'
1580 include 'COMMON.DERIV'
1581 include 'COMMON.INTERACT'
1582 include 'COMMON.IOUNITS'
1583 include 'COMMON.NAMES'
1586 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1588 do i=iatsc_s,iatsc_e
1589 itypi=iabs(itype(i))
1590 if (itypi.eq.ntyp1) cycle
1591 itypi1=iabs(itype(i+1))
1596 C Calculate SC interaction energy.
1598 do iint=1,nint_gr(i)
1599 do j=istart(i,iint),iend(i,iint)
1600 itypj=iabs(itype(j))
1601 if (itypj.eq.ntyp1) cycle
1605 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1606 fac_augm=rrij**expon
1607 e_augm=augm(itypi,itypj)*fac_augm
1608 r_inv_ij=dsqrt(rrij)
1610 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1611 fac=r_shift_inv**expon
1612 C have you changed here?
1616 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1617 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1618 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1619 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1620 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1621 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1622 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1625 C Calculate the components of the gradient in DC and X
1627 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1632 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1633 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1634 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1635 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1639 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1647 gvdwc(j,i)=expon*gvdwc(j,i)
1648 gvdwx(j,i)=expon*gvdwx(j,i)
1653 C-----------------------------------------------------------------------------
1654 subroutine ebp(evdw)
1656 C This subroutine calculates the interaction energy of nonbonded side chains
1657 C assuming the Berne-Pechukas potential of interaction.
1660 include 'DIMENSIONS'
1661 include 'COMMON.GEO'
1662 include 'COMMON.VAR'
1663 include 'COMMON.LOCAL'
1664 include 'COMMON.CHAIN'
1665 include 'COMMON.DERIV'
1666 include 'COMMON.NAMES'
1667 include 'COMMON.INTERACT'
1668 include 'COMMON.IOUNITS'
1669 include 'COMMON.CALC'
1671 common /srutu/ icall
1672 c double precision rrsave(maxdim)
1675 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1677 c if (icall.eq.0) then
1683 do i=iatsc_s,iatsc_e
1684 itypi=iabs(itype(i))
1685 if (itypi.eq.ntyp1) cycle
1686 itypi1=iabs(itype(i+1))
1690 dxi=dc_norm(1,nres+i)
1691 dyi=dc_norm(2,nres+i)
1692 dzi=dc_norm(3,nres+i)
1693 c dsci_inv=dsc_inv(itypi)
1694 dsci_inv=vbld_inv(i+nres)
1696 C Calculate SC interaction energy.
1698 do iint=1,nint_gr(i)
1699 do j=istart(i,iint),iend(i,iint)
1701 itypj=iabs(itype(j))
1702 if (itypj.eq.ntyp1) cycle
1703 c dscj_inv=dsc_inv(itypj)
1704 dscj_inv=vbld_inv(j+nres)
1705 chi1=chi(itypi,itypj)
1706 chi2=chi(itypj,itypi)
1713 alf12=0.5D0*(alf1+alf2)
1714 C For diagnostics only!!!
1727 dxj=dc_norm(1,nres+j)
1728 dyj=dc_norm(2,nres+j)
1729 dzj=dc_norm(3,nres+j)
1730 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1731 cd if (icall.eq.0) then
1737 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1739 C Calculate whole angle-dependent part of epsilon and contributions
1740 C to its derivatives
1741 C have you changed here?
1742 fac=(rrij*sigsq)**expon2
1745 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1746 eps2der=evdwij*eps3rt
1747 eps3der=evdwij*eps2rt
1748 evdwij=evdwij*eps2rt*eps3rt
1751 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1753 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1754 cd & restyp(itypi),i,restyp(itypj),j,
1755 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1756 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1757 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1760 C Calculate gradient components.
1761 e1=e1*eps1*eps2rt**2*eps3rt**2
1762 fac=-expon*(e1+evdwij)
1765 C Calculate radial part of the gradient
1769 C Calculate the angular part of the gradient and sum add the contributions
1770 C to the appropriate components of the Cartesian gradient.
1778 C-----------------------------------------------------------------------------
1779 subroutine egb(evdw)
1781 C This subroutine calculates the interaction energy of nonbonded side chains
1782 C assuming the Gay-Berne potential of interaction.
1785 include 'DIMENSIONS'
1786 include 'COMMON.GEO'
1787 include 'COMMON.VAR'
1788 include 'COMMON.LOCAL'
1789 include 'COMMON.CHAIN'
1790 include 'COMMON.DERIV'
1791 include 'COMMON.NAMES'
1792 include 'COMMON.INTERACT'
1793 include 'COMMON.IOUNITS'
1794 include 'COMMON.CALC'
1795 include 'COMMON.CONTROL'
1796 include 'COMMON.SPLITELE'
1797 include 'COMMON.SBRIDGE'
1799 integer xshift,yshift,zshift
1802 ccccc energy_dec=.false.
1803 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1806 c if (icall.eq.0) lprn=.false.
1808 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1809 C we have the original box)
1813 do i=iatsc_s,iatsc_e
1814 itypi=iabs(itype(i))
1815 if (itypi.eq.ntyp1) cycle
1816 itypi1=iabs(itype(i+1))
1820 C Return atom into box, boxxsize is size of box in x dimension
1822 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1823 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1824 C Condition for being inside the proper box
1825 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1826 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
1830 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1831 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1832 C Condition for being inside the proper box
1833 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1834 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
1838 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1839 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1840 C Condition for being inside the proper box
1841 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1842 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
1846 if (xi.lt.0) xi=xi+boxxsize
1848 if (yi.lt.0) yi=yi+boxysize
1850 if (zi.lt.0) zi=zi+boxzsize
1851 C define scaling factor for lipids
1853 C if (positi.le.0) positi=positi+boxzsize
1855 C first for peptide groups
1856 c for each residue check if it is in lipid or lipid water border area
1857 if ((zi.gt.bordlipbot)
1858 &.and.(zi.lt.bordliptop)) then
1859 C the energy transfer exist
1860 if (zi.lt.buflipbot) then
1861 C what fraction I am in
1863 & ((zi-bordlipbot)/lipbufthick)
1864 C lipbufthick is thickenes of lipid buffore
1865 sslipi=sscalelip(fracinbuf)
1866 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1867 elseif (zi.gt.bufliptop) then
1868 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1869 sslipi=sscalelip(fracinbuf)
1870 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1880 C xi=xi+xshift*boxxsize
1881 C yi=yi+yshift*boxysize
1882 C zi=zi+zshift*boxzsize
1884 dxi=dc_norm(1,nres+i)
1885 dyi=dc_norm(2,nres+i)
1886 dzi=dc_norm(3,nres+i)
1887 c dsci_inv=dsc_inv(itypi)
1888 dsci_inv=vbld_inv(i+nres)
1889 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1890 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1892 C Calculate SC interaction energy.
1894 do iint=1,nint_gr(i)
1895 do j=istart(i,iint),iend(i,iint)
1896 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1898 c write(iout,*) "PRZED ZWYKLE", evdwij
1899 call dyn_ssbond_ene(i,j,evdwij)
1900 c write(iout,*) "PO ZWYKLE", evdwij
1903 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1904 & 'evdw',i,j,evdwij,' ss'
1905 C triple bond artifac removal
1906 do k=j+1,iend(i,iint)
1907 C search over all next residues
1908 if (dyn_ss_mask(k)) then
1909 C check if they are cysteins
1910 C write(iout,*) 'k=',k
1912 c write(iout,*) "PRZED TRI", evdwij
1913 evdwij_przed_tri=evdwij
1914 call triple_ssbond_ene(i,j,k,evdwij)
1915 c if(evdwij_przed_tri.ne.evdwij) then
1916 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1919 c write(iout,*) "PO TRI", evdwij
1920 C call the energy function that removes the artifical triple disulfide
1921 C bond the soubroutine is located in ssMD.F
1923 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1924 & 'evdw',i,j,evdwij,'tss'
1925 endif!dyn_ss_mask(k)
1929 itypj=iabs(itype(j))
1930 if (itypj.eq.ntyp1) cycle
1931 c dscj_inv=dsc_inv(itypj)
1932 dscj_inv=vbld_inv(j+nres)
1933 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1934 c & 1.0d0/vbld(j+nres)
1935 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1936 sig0ij=sigma(itypi,itypj)
1937 chi1=chi(itypi,itypj)
1938 chi2=chi(itypj,itypi)
1945 alf12=0.5D0*(alf1+alf2)
1946 C For diagnostics only!!!
1959 C Return atom J into box the original box
1961 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1962 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1963 C Condition for being inside the proper box
1964 c if ((xj.gt.((0.5d0)*boxxsize)).or.
1965 c & (xj.lt.((-0.5d0)*boxxsize))) then
1969 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1970 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1971 C Condition for being inside the proper box
1972 c if ((yj.gt.((0.5d0)*boxysize)).or.
1973 c & (yj.lt.((-0.5d0)*boxysize))) then
1977 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1978 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1979 C Condition for being inside the proper box
1980 c if ((zj.gt.((0.5d0)*boxzsize)).or.
1981 c & (zj.lt.((-0.5d0)*boxzsize))) then
1985 if (xj.lt.0) xj=xj+boxxsize
1987 if (yj.lt.0) yj=yj+boxysize
1989 if (zj.lt.0) zj=zj+boxzsize
1990 if ((zj.gt.bordlipbot)
1991 &.and.(zj.lt.bordliptop)) then
1992 C the energy transfer exist
1993 if (zj.lt.buflipbot) then
1994 C what fraction I am in
1996 & ((zj-bordlipbot)/lipbufthick)
1997 C lipbufthick is thickenes of lipid buffore
1998 sslipj=sscalelip(fracinbuf)
1999 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2000 elseif (zj.gt.bufliptop) then
2001 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2002 sslipj=sscalelip(fracinbuf)
2003 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2012 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2013 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2014 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2015 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2016 C write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2017 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2018 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2019 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2020 C print *,sslipi,sslipj,bordlipbot,zi,zj
2021 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2029 xj=xj_safe+xshift*boxxsize
2030 yj=yj_safe+yshift*boxysize
2031 zj=zj_safe+zshift*boxzsize
2032 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2033 if(dist_temp.lt.dist_init) then
2043 if (subchap.eq.1) then
2052 dxj=dc_norm(1,nres+j)
2053 dyj=dc_norm(2,nres+j)
2054 dzj=dc_norm(3,nres+j)
2058 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2059 c write (iout,*) "j",j," dc_norm",
2060 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2061 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2063 sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
2064 sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
2066 c write (iout,'(a7,4f8.3)')
2067 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2068 if (sss.gt.0.0d0) then
2069 C Calculate angle-dependent terms of energy and contributions to their
2073 sig=sig0ij*dsqrt(sigsq)
2074 rij_shift=1.0D0/rij-sig+sig0ij
2075 c for diagnostics; uncomment
2076 c rij_shift=1.2*sig0ij
2077 C I hate to put IF's in the loops, but here don't have another choice!!!!
2078 if (rij_shift.le.0.0D0) then
2080 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2081 cd & restyp(itypi),i,restyp(itypj),j,
2082 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2086 c---------------------------------------------------------------
2087 rij_shift=1.0D0/rij_shift
2088 fac=rij_shift**expon
2089 C here to start with
2094 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2095 eps2der=evdwij*eps3rt
2096 eps3der=evdwij*eps2rt
2097 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2098 C &((sslipi+sslipj)/2.0d0+
2099 C &(2.0d0-sslipi-sslipj)/2.0d0)
2100 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2101 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2102 evdwij=evdwij*eps2rt*eps3rt
2103 evdw=evdw+evdwij*sss
2105 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2107 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2108 & restyp(itypi),i,restyp(itypj),j,
2109 & epsi,sigm,chi1,chi2,chip1,chip2,
2110 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2111 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2115 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2118 C Calculate gradient components.
2119 e1=e1*eps1*eps2rt**2*eps3rt**2
2120 fac=-expon*(e1+evdwij)*rij_shift
2123 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
2124 c & evdwij,fac,sigma(itypi,itypj),expon
2125 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2127 C Calculate the radial part of the gradient
2128 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2129 &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2130 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2131 &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2132 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2133 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2139 C Calculate angular part of the gradient.
2149 c write (iout,*) "Number of loop steps in EGB:",ind
2150 cccc energy_dec=.false.
2153 C-----------------------------------------------------------------------------
2154 subroutine egbv(evdw)
2156 C This subroutine calculates the interaction energy of nonbonded side chains
2157 C assuming the Gay-Berne-Vorobjev potential of interaction.
2160 include 'DIMENSIONS'
2161 include 'COMMON.GEO'
2162 include 'COMMON.VAR'
2163 include 'COMMON.LOCAL'
2164 include 'COMMON.CHAIN'
2165 include 'COMMON.DERIV'
2166 include 'COMMON.NAMES'
2167 include 'COMMON.INTERACT'
2168 include 'COMMON.IOUNITS'
2169 include 'COMMON.CALC'
2170 integer xshift,yshift,zshift
2172 common /srutu/ icall
2175 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2178 c if (icall.eq.0) lprn=.true.
2180 do i=iatsc_s,iatsc_e
2181 itypi=iabs(itype(i))
2182 if (itypi.eq.ntyp1) cycle
2183 itypi1=iabs(itype(i+1))
2188 if (xi.lt.0) xi=xi+boxxsize
2190 if (yi.lt.0) yi=yi+boxysize
2192 if (zi.lt.0) zi=zi+boxzsize
2193 C define scaling factor for lipids
2195 C if (positi.le.0) positi=positi+boxzsize
2197 C first for peptide groups
2198 c for each residue check if it is in lipid or lipid water border area
2199 if ((zi.gt.bordlipbot)
2200 &.and.(zi.lt.bordliptop)) then
2201 C the energy transfer exist
2202 if (zi.lt.buflipbot) then
2203 C what fraction I am in
2205 & ((zi-bordlipbot)/lipbufthick)
2206 C lipbufthick is thickenes of lipid buffore
2207 sslipi=sscalelip(fracinbuf)
2208 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2209 elseif (zi.gt.bufliptop) then
2210 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2211 sslipi=sscalelip(fracinbuf)
2212 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2222 dxi=dc_norm(1,nres+i)
2223 dyi=dc_norm(2,nres+i)
2224 dzi=dc_norm(3,nres+i)
2225 c dsci_inv=dsc_inv(itypi)
2226 dsci_inv=vbld_inv(i+nres)
2228 C Calculate SC interaction energy.
2230 do iint=1,nint_gr(i)
2231 do j=istart(i,iint),iend(i,iint)
2233 itypj=iabs(itype(j))
2234 if (itypj.eq.ntyp1) cycle
2235 c dscj_inv=dsc_inv(itypj)
2236 dscj_inv=vbld_inv(j+nres)
2237 sig0ij=sigma(itypi,itypj)
2238 r0ij=r0(itypi,itypj)
2239 chi1=chi(itypi,itypj)
2240 chi2=chi(itypj,itypi)
2247 alf12=0.5D0*(alf1+alf2)
2248 C For diagnostics only!!!
2262 if (xj.lt.0) xj=xj+boxxsize
2264 if (yj.lt.0) yj=yj+boxysize
2266 if (zj.lt.0) zj=zj+boxzsize
2267 if ((zj.gt.bordlipbot)
2268 &.and.(zj.lt.bordliptop)) then
2269 C the energy transfer exist
2270 if (zj.lt.buflipbot) then
2271 C what fraction I am in
2273 & ((zj-bordlipbot)/lipbufthick)
2274 C lipbufthick is thickenes of lipid buffore
2275 sslipj=sscalelip(fracinbuf)
2276 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2277 elseif (zj.gt.bufliptop) then
2278 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2279 sslipj=sscalelip(fracinbuf)
2280 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2289 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2290 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2291 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2292 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2293 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2294 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2295 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2296 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2304 xj=xj_safe+xshift*boxxsize
2305 yj=yj_safe+yshift*boxysize
2306 zj=zj_safe+zshift*boxzsize
2307 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2308 if(dist_temp.lt.dist_init) then
2318 if (subchap.eq.1) then
2327 dxj=dc_norm(1,nres+j)
2328 dyj=dc_norm(2,nres+j)
2329 dzj=dc_norm(3,nres+j)
2330 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2332 C Calculate angle-dependent terms of energy and contributions to their
2336 sig=sig0ij*dsqrt(sigsq)
2337 rij_shift=1.0D0/rij-sig+r0ij
2338 C I hate to put IF's in the loops, but here don't have another choice!!!!
2339 if (rij_shift.le.0.0D0) then
2344 c---------------------------------------------------------------
2345 rij_shift=1.0D0/rij_shift
2346 fac=rij_shift**expon
2349 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2350 eps2der=evdwij*eps3rt
2351 eps3der=evdwij*eps2rt
2352 fac_augm=rrij**expon
2353 e_augm=augm(itypi,itypj)*fac_augm
2354 evdwij=evdwij*eps2rt*eps3rt
2355 evdw=evdw+evdwij+e_augm
2357 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2359 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2360 & restyp(itypi),i,restyp(itypj),j,
2361 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2362 & chi1,chi2,chip1,chip2,
2363 & eps1,eps2rt**2,eps3rt**2,
2364 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2367 C Calculate gradient components.
2368 e1=e1*eps1*eps2rt**2*eps3rt**2
2369 fac=-expon*(e1+evdwij)*rij_shift
2371 fac=rij*fac-2*expon*rrij*e_augm
2372 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2373 C Calculate the radial part of the gradient
2377 C Calculate angular part of the gradient.
2383 C-----------------------------------------------------------------------------
2384 subroutine sc_angular
2385 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2386 C om12. Called by ebp, egb, and egbv.
2388 include 'COMMON.CALC'
2389 include 'COMMON.IOUNITS'
2393 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2394 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2395 om12=dxi*dxj+dyi*dyj+dzi*dzj
2397 C Calculate eps1(om12) and its derivative in om12
2398 faceps1=1.0D0-om12*chiom12
2399 faceps1_inv=1.0D0/faceps1
2400 eps1=dsqrt(faceps1_inv)
2401 C Following variable is eps1*deps1/dom12
2402 eps1_om12=faceps1_inv*chiom12
2407 c write (iout,*) "om12",om12," eps1",eps1
2408 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2413 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2414 sigsq=1.0D0-facsig*faceps1_inv
2415 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2416 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2417 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2423 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2424 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2426 C Calculate eps2 and its derivatives in om1, om2, and om12.
2429 chipom12=chip12*om12
2430 facp=1.0D0-om12*chipom12
2432 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2433 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2434 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2435 C Following variable is the square root of eps2
2436 eps2rt=1.0D0-facp1*facp_inv
2437 C Following three variables are the derivatives of the square root of eps
2438 C in om1, om2, and om12.
2439 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2440 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2441 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2442 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2443 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2444 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2445 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2446 c & " eps2rt_om12",eps2rt_om12
2447 C Calculate whole angle-dependent part of epsilon and contributions
2448 C to its derivatives
2451 C----------------------------------------------------------------------------
2454 include 'DIMENSIONS'
2455 include 'COMMON.CHAIN'
2456 include 'COMMON.DERIV'
2457 include 'COMMON.CALC'
2458 include 'COMMON.IOUNITS'
2459 double precision dcosom1(3),dcosom2(3)
2460 cc print *,'sss=',sss
2461 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2462 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2463 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2464 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2468 c eom12=evdwij*eps1_om12
2470 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2471 c & " sigder",sigder
2472 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2473 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2475 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2476 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2479 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2481 c write (iout,*) "gg",(gg(k),k=1,3)
2483 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2484 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2485 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2486 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2487 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2488 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2489 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2490 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2491 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2492 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2495 C Calculate the components of the gradient in DC and X
2499 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2503 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2504 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2508 C-----------------------------------------------------------------------
2509 subroutine e_softsphere(evdw)
2511 C This subroutine calculates the interaction energy of nonbonded side chains
2512 C assuming the LJ potential of interaction.
2515 include 'DIMENSIONS'
2516 parameter (accur=1.0d-10)
2517 include 'COMMON.GEO'
2518 include 'COMMON.VAR'
2519 include 'COMMON.LOCAL'
2520 include 'COMMON.CHAIN'
2521 include 'COMMON.DERIV'
2522 include 'COMMON.INTERACT'
2523 include 'COMMON.TORSION'
2524 include 'COMMON.SBRIDGE'
2525 include 'COMMON.NAMES'
2526 include 'COMMON.IOUNITS'
2527 include 'COMMON.CONTACTS'
2529 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2531 do i=iatsc_s,iatsc_e
2532 itypi=iabs(itype(i))
2533 if (itypi.eq.ntyp1) cycle
2534 itypi1=iabs(itype(i+1))
2539 C Calculate SC interaction energy.
2541 do iint=1,nint_gr(i)
2542 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2543 cd & 'iend=',iend(i,iint)
2544 do j=istart(i,iint),iend(i,iint)
2545 itypj=iabs(itype(j))
2546 if (itypj.eq.ntyp1) cycle
2550 rij=xj*xj+yj*yj+zj*zj
2551 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2552 r0ij=r0(itypi,itypj)
2554 c print *,i,j,r0ij,dsqrt(rij)
2555 if (rij.lt.r0ijsq) then
2556 evdwij=0.25d0*(rij-r0ijsq)**2
2564 C Calculate the components of the gradient in DC and X
2570 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2571 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2572 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2573 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2577 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2585 C--------------------------------------------------------------------------
2586 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2589 C Soft-sphere potential of p-p interaction
2592 include 'DIMENSIONS'
2593 include 'COMMON.CONTROL'
2594 include 'COMMON.IOUNITS'
2595 include 'COMMON.GEO'
2596 include 'COMMON.VAR'
2597 include 'COMMON.LOCAL'
2598 include 'COMMON.CHAIN'
2599 include 'COMMON.DERIV'
2600 include 'COMMON.INTERACT'
2601 include 'COMMON.CONTACTS'
2602 include 'COMMON.TORSION'
2603 include 'COMMON.VECTORS'
2604 include 'COMMON.FFIELD'
2606 integer xshift,yshift,zshift
2607 C write(iout,*) 'In EELEC_soft_sphere'
2614 do i=iatel_s,iatel_e
2615 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2619 xmedi=c(1,i)+0.5d0*dxi
2620 ymedi=c(2,i)+0.5d0*dyi
2621 zmedi=c(3,i)+0.5d0*dzi
2622 xmedi=mod(xmedi,boxxsize)
2623 if (xmedi.lt.0) xmedi=xmedi+boxxsize
2624 ymedi=mod(ymedi,boxysize)
2625 if (ymedi.lt.0) ymedi=ymedi+boxysize
2626 zmedi=mod(zmedi,boxzsize)
2627 if (zmedi.lt.0) zmedi=zmedi+boxzsize
2629 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2630 do j=ielstart(i),ielend(i)
2631 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2635 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2636 r0ij=rpp(iteli,itelj)
2645 if (xj.lt.0) xj=xj+boxxsize
2647 if (yj.lt.0) yj=yj+boxysize
2649 if (zj.lt.0) zj=zj+boxzsize
2650 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2658 xj=xj_safe+xshift*boxxsize
2659 yj=yj_safe+yshift*boxysize
2660 zj=zj_safe+zshift*boxzsize
2661 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2662 if(dist_temp.lt.dist_init) then
2672 if (isubchap.eq.1) then
2681 rij=xj*xj+yj*yj+zj*zj
2682 sss=sscale(sqrt(rij))
2683 sssgrad=sscagrad(sqrt(rij))
2684 if (rij.lt.r0ijsq) then
2685 evdw1ij=0.25d0*(rij-r0ijsq)**2
2691 evdw1=evdw1+evdw1ij*sss
2693 C Calculate contributions to the Cartesian gradient.
2695 ggg(1)=fac*xj*sssgrad
2696 ggg(2)=fac*yj*sssgrad
2697 ggg(3)=fac*zj*sssgrad
2699 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2700 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2703 * Loop over residues i+1 thru j-1.
2707 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2712 cgrad do i=nnt,nct-1
2714 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2716 cgrad do j=i+1,nct-1
2718 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2724 c------------------------------------------------------------------------------
2725 subroutine vec_and_deriv
2727 include 'DIMENSIONS'
2731 include 'COMMON.IOUNITS'
2732 include 'COMMON.GEO'
2733 include 'COMMON.VAR'
2734 include 'COMMON.LOCAL'
2735 include 'COMMON.CHAIN'
2736 include 'COMMON.VECTORS'
2737 include 'COMMON.SETUP'
2738 include 'COMMON.TIME1'
2739 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2740 C Compute the local reference systems. For reference system (i), the
2741 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2742 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2744 do i=ivec_start,ivec_end
2748 if (i.eq.nres-1) then
2749 C Case of the last full residue
2750 C Compute the Z-axis
2751 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2752 costh=dcos(pi-theta(nres))
2753 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2757 C Compute the derivatives of uz
2759 uzder(2,1,1)=-dc_norm(3,i-1)
2760 uzder(3,1,1)= dc_norm(2,i-1)
2761 uzder(1,2,1)= dc_norm(3,i-1)
2763 uzder(3,2,1)=-dc_norm(1,i-1)
2764 uzder(1,3,1)=-dc_norm(2,i-1)
2765 uzder(2,3,1)= dc_norm(1,i-1)
2768 uzder(2,1,2)= dc_norm(3,i)
2769 uzder(3,1,2)=-dc_norm(2,i)
2770 uzder(1,2,2)=-dc_norm(3,i)
2772 uzder(3,2,2)= dc_norm(1,i)
2773 uzder(1,3,2)= dc_norm(2,i)
2774 uzder(2,3,2)=-dc_norm(1,i)
2776 C Compute the Y-axis
2779 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2781 C Compute the derivatives of uy
2784 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2785 & -dc_norm(k,i)*dc_norm(j,i-1)
2786 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2788 uyder(j,j,1)=uyder(j,j,1)-costh
2789 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2794 uygrad(l,k,j,i)=uyder(l,k,j)
2795 uzgrad(l,k,j,i)=uzder(l,k,j)
2799 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2800 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2801 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2802 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2805 C Compute the Z-axis
2806 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2807 costh=dcos(pi-theta(i+2))
2808 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2812 C Compute the derivatives of uz
2814 uzder(2,1,1)=-dc_norm(3,i+1)
2815 uzder(3,1,1)= dc_norm(2,i+1)
2816 uzder(1,2,1)= dc_norm(3,i+1)
2818 uzder(3,2,1)=-dc_norm(1,i+1)
2819 uzder(1,3,1)=-dc_norm(2,i+1)
2820 uzder(2,3,1)= dc_norm(1,i+1)
2823 uzder(2,1,2)= dc_norm(3,i)
2824 uzder(3,1,2)=-dc_norm(2,i)
2825 uzder(1,2,2)=-dc_norm(3,i)
2827 uzder(3,2,2)= dc_norm(1,i)
2828 uzder(1,3,2)= dc_norm(2,i)
2829 uzder(2,3,2)=-dc_norm(1,i)
2831 C Compute the Y-axis
2834 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2836 C Compute the derivatives of uy
2839 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2840 & -dc_norm(k,i)*dc_norm(j,i+1)
2841 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2843 uyder(j,j,1)=uyder(j,j,1)-costh
2844 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2849 uygrad(l,k,j,i)=uyder(l,k,j)
2850 uzgrad(l,k,j,i)=uzder(l,k,j)
2854 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2855 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2856 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2857 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2861 vbld_inv_temp(1)=vbld_inv(i+1)
2862 if (i.lt.nres-1) then
2863 vbld_inv_temp(2)=vbld_inv(i+2)
2865 vbld_inv_temp(2)=vbld_inv(i)
2870 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2871 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2876 #if defined(PARVEC) && defined(MPI)
2877 if (nfgtasks1.gt.1) then
2879 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2880 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2881 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2882 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2883 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2885 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2886 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2888 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2889 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2890 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2891 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2892 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2893 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2894 time_gather=time_gather+MPI_Wtime()-time00
2898 if (fg_rank.eq.0) then
2899 write (iout,*) "Arrays UY and UZ"
2901 write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2908 C-----------------------------------------------------------------------------
2909 subroutine check_vecgrad
2911 include 'DIMENSIONS'
2912 include 'COMMON.IOUNITS'
2913 include 'COMMON.GEO'
2914 include 'COMMON.VAR'
2915 include 'COMMON.LOCAL'
2916 include 'COMMON.CHAIN'
2917 include 'COMMON.VECTORS'
2918 dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2919 dimension uyt(3,maxres),uzt(3,maxres)
2920 dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2921 double precision delta /1.0d-7/
2924 crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2925 crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2926 crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2927 cd write(iout,'(2i5,2(3f10.5,5x))') i,1,
2928 cd & (dc_norm(if90,i),if90=1,3)
2929 cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2930 cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2931 cd write(iout,'(a)')
2937 uygradt(l,k,j,i)=uygrad(l,k,j,i)
2938 uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2951 cd write (iout,*) 'i=',i
2953 erij(k)=dc_norm(k,i)
2957 dc_norm(k,i)=erij(k)
2959 dc_norm(j,i)=dc_norm(j,i)+delta
2960 c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2962 c dc_norm(k,i)=dc_norm(k,i)/fac
2964 c write (iout,*) (dc_norm(k,i),k=1,3)
2965 c write (iout,*) (erij(k),k=1,3)
2968 uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2969 uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2970 uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2971 uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2973 c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2974 c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2975 c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2978 dc_norm(k,i)=erij(k)
2981 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2982 cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2983 cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2984 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2985 cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2986 cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2987 cd write (iout,'(a)')
2992 C--------------------------------------------------------------------------
2993 subroutine set_matrices
2995 include 'DIMENSIONS'
2998 include "COMMON.SETUP"
3000 integer status(MPI_STATUS_SIZE)
3002 include 'COMMON.IOUNITS'
3003 include 'COMMON.GEO'
3004 include 'COMMON.VAR'
3005 include 'COMMON.LOCAL'
3006 include 'COMMON.CHAIN'
3007 include 'COMMON.DERIV'
3008 include 'COMMON.INTERACT'
3009 include 'COMMON.CONTACTS'
3010 include 'COMMON.TORSION'
3011 include 'COMMON.VECTORS'
3012 include 'COMMON.FFIELD'
3013 double precision auxvec(2),auxmat(2,2)
3015 C Compute the virtual-bond-torsional-angle dependent quantities needed
3016 C to calculate the el-loc multibody terms of various order.
3018 c write(iout,*) 'nphi=',nphi,nres
3019 c write(iout,*) "itype2loc",itype2loc
3021 do i=ivec_start+2,ivec_end+2
3025 if (i.gt. nnt+2 .and. i.lt.nct+2) then
3026 iti = itype2loc(itype(i-2))
3030 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3031 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3032 iti1 = itype2loc(itype(i-1))
3038 cost1=dcos(theta(i-1))
3039 sint1=dsin(theta(i-1))
3041 sint1cub=sint1sq*sint1
3042 sint1cost1=2*sint1*cost1
3043 c write (iout,*) "bnew1",i,iti
3044 c write (iout,*) (bnew1(k,1,iti),k=1,3)
3045 c write (iout,*) (bnew1(k,2,iti),k=1,3)
3046 c write (iout,*) "bnew2",i,iti
3047 c write (iout,*) (bnew2(k,1,iti),k=1,3)
3048 c write (iout,*) (bnew2(k,2,iti),k=1,3)
3050 b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3052 gtb1(k,i-2)=cost1*b1k-sint1sq*
3053 & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3054 b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3056 gtb2(k,i-2)=cost1*b2k-sint1sq*
3057 & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3060 aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3061 cc(1,k,i-2)=sint1sq*aux
3062 gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3063 & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3064 aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3065 dd(1,k,i-2)=sint1sq*aux
3066 gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3067 & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3069 cc(2,1,i-2)=cc(1,2,i-2)
3070 cc(2,2,i-2)=-cc(1,1,i-2)
3071 gtcc(2,1,i-2)=gtcc(1,2,i-2)
3072 gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3073 dd(2,1,i-2)=dd(1,2,i-2)
3074 dd(2,2,i-2)=-dd(1,1,i-2)
3075 gtdd(2,1,i-2)=gtdd(1,2,i-2)
3076 gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3079 aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3080 EE(l,k,i-2)=sint1sq*aux
3081 gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3084 EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3085 EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3086 EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3087 EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3088 gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3089 gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3090 gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3091 c b1tilde(1,i-2)=b1(1,i-2)
3092 c b1tilde(2,i-2)=-b1(2,i-2)
3093 c b2tilde(1,i-2)=b2(1,i-2)
3094 c b2tilde(2,i-2)=-b2(2,i-2)
3096 write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3097 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3098 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3099 write (iout,*) 'theta=', theta(i-1)
3102 if (i.gt. nnt+2 .and. i.lt.nct+2) then
3103 iti = itype2loc(itype(i-2))
3107 c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3108 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3109 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3110 iti1 = itype2loc(itype(i-1))
3120 CC(k,l,i-2)=ccold(k,l,iti)
3121 DD(k,l,i-2)=ddold(k,l,iti)
3122 EE(k,l,i-2)=eeold(k,l,iti)
3127 b1tilde(1,i-2)= b1(1,i-2)
3128 b1tilde(2,i-2)=-b1(2,i-2)
3129 b2tilde(1,i-2)= b2(1,i-2)
3130 b2tilde(2,i-2)=-b2(2,i-2)
3132 Ctilde(1,1,i-2)= CC(1,1,i-2)
3133 Ctilde(1,2,i-2)= CC(1,2,i-2)
3134 Ctilde(2,1,i-2)=-CC(2,1,i-2)
3135 Ctilde(2,2,i-2)=-CC(2,2,i-2)
3137 Dtilde(1,1,i-2)= DD(1,1,i-2)
3138 Dtilde(1,2,i-2)= DD(1,2,i-2)
3139 Dtilde(2,1,i-2)=-DD(2,1,i-2)
3140 Dtilde(2,2,i-2)=-DD(2,2,i-2)
3142 write(iout,*) "i",i," iti",iti
3143 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3144 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3148 do i=ivec_start+2,ivec_end+2
3152 if (i .lt. nres+1) then
3189 if (i .gt. 3 .and. i .lt. nres+1) then
3190 obrot_der(1,i-2)=-sin1
3191 obrot_der(2,i-2)= cos1
3192 Ugder(1,1,i-2)= sin1
3193 Ugder(1,2,i-2)=-cos1
3194 Ugder(2,1,i-2)=-cos1
3195 Ugder(2,2,i-2)=-sin1
3198 obrot2_der(1,i-2)=-dwasin2
3199 obrot2_der(2,i-2)= dwacos2
3200 Ug2der(1,1,i-2)= dwasin2
3201 Ug2der(1,2,i-2)=-dwacos2
3202 Ug2der(2,1,i-2)=-dwacos2
3203 Ug2der(2,2,i-2)=-dwasin2
3205 obrot_der(1,i-2)=0.0d0
3206 obrot_der(2,i-2)=0.0d0
3207 Ugder(1,1,i-2)=0.0d0
3208 Ugder(1,2,i-2)=0.0d0
3209 Ugder(2,1,i-2)=0.0d0
3210 Ugder(2,2,i-2)=0.0d0
3211 obrot2_der(1,i-2)=0.0d0
3212 obrot2_der(2,i-2)=0.0d0
3213 Ug2der(1,1,i-2)=0.0d0
3214 Ug2der(1,2,i-2)=0.0d0
3215 Ug2der(2,1,i-2)=0.0d0
3216 Ug2der(2,2,i-2)=0.0d0
3218 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3219 if (i.gt. nnt+2 .and. i.lt.nct+2) then
3220 iti = itype2loc(itype(i-2))
3224 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3225 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3226 iti1 = itype2loc(itype(i-1))
3230 cd write (iout,*) '*******i',i,' iti1',iti
3231 cd write (iout,*) 'b1',b1(:,iti)
3232 cd write (iout,*) 'b2',b2(:,iti)
3233 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3234 c if (i .gt. iatel_s+2) then
3235 if (i .gt. nnt+2) then
3236 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3238 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3239 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3241 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3242 c & EE(1,2,iti),EE(2,2,i)
3243 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3244 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3245 c write(iout,*) "Macierz EUG",
3246 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3248 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3250 call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3251 call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3252 call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3253 call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3254 call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3265 DtUg2(l,k,i-2)=0.0d0
3269 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3270 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3272 muder(k,i-2)=Ub2der(k,i-2)
3274 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3275 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3276 if (itype(i-1).le.ntyp) then
3277 iti1 = itype2loc(itype(i-1))
3285 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3286 c mu(k,i-2)=b1(k,i-1)
3287 c mu(k,i-2)=Ub2(k,i-2)
3290 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3291 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3292 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3293 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3294 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3295 & ((ee(l,k,i-2),l=1,2),k=1,2)
3297 cd write (iout,*) 'mu1',mu1(:,i-2)
3298 cd write (iout,*) 'mu2',mu2(:,i-2)
3299 cd write (iout,*) 'mu',i-2,mu(:,i-2)
3300 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3302 call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3303 call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3304 call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3305 call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3306 call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3307 C Vectors and matrices dependent on a single virtual-bond dihedral.
3308 call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3309 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3310 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3311 call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3312 call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3313 call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3314 call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3315 call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3316 call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3319 C Matrices dependent on two consecutive virtual-bond dihedrals.
3320 C The order of matrices is from left to right.
3321 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3323 c do i=max0(ivec_start,2),ivec_end
3325 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3326 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3327 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3328 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3329 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3330 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3331 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3332 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3335 #if defined(MPI) && defined(PARMAT)
3337 c if (fg_rank.eq.0) then
3338 write (iout,*) "Arrays UG and UGDER before GATHER"
3340 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3341 & ((ug(l,k,i),l=1,2),k=1,2),
3342 & ((ugder(l,k,i),l=1,2),k=1,2)
3344 write (iout,*) "Arrays UG2 and UG2DER"
3346 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3347 & ((ug2(l,k,i),l=1,2),k=1,2),
3348 & ((ug2der(l,k,i),l=1,2),k=1,2)
3350 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3352 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3353 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3354 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3356 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3358 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3359 & costab(i),sintab(i),costab2(i),sintab2(i)
3361 write (iout,*) "Array MUDER"
3363 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3367 if (nfgtasks.gt.1) then
3369 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3370 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3371 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3373 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3374 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3376 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3377 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3379 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3380 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3382 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3383 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3385 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3386 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3388 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3389 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3391 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3392 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3393 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3394 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3395 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3396 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3397 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3398 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3399 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3400 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3401 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3402 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3403 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3405 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3406 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3408 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3409 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3411 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3412 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3414 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3415 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3417 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3418 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3420 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3421 & ivec_count(fg_rank1),
3422 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3424 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3425 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3427 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3428 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3430 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3431 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3433 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3434 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3436 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3437 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3439 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3440 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3442 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3443 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3445 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3446 & ivec_count(fg_rank1),
3447 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3449 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3450 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3452 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3453 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3455 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3456 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3458 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3459 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3461 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3462 & ivec_count(fg_rank1),
3463 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3465 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3466 & ivec_count(fg_rank1),
3467 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3469 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3470 & ivec_count(fg_rank1),
3471 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3472 & MPI_MAT2,FG_COMM1,IERR)
3473 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3474 & ivec_count(fg_rank1),
3475 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3476 & MPI_MAT2,FG_COMM1,IERR)
3479 c Passes matrix info through the ring
3482 if (irecv.lt.0) irecv=nfgtasks1-1
3485 if (inext.ge.nfgtasks1) inext=0
3487 c write (iout,*) "isend",isend," irecv",irecv
3489 lensend=lentyp(isend)
3490 lenrecv=lentyp(irecv)
3491 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3492 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3493 c & MPI_ROTAT1(lensend),inext,2200+isend,
3494 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3495 c & iprev,2200+irecv,FG_COMM,status,IERR)
3496 c write (iout,*) "Gather ROTAT1"
3498 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3499 c & MPI_ROTAT2(lensend),inext,3300+isend,
3500 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3501 c & iprev,3300+irecv,FG_COMM,status,IERR)
3502 c write (iout,*) "Gather ROTAT2"
3504 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3505 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3506 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3507 & iprev,4400+irecv,FG_COMM,status,IERR)
3508 c write (iout,*) "Gather ROTAT_OLD"
3510 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3511 & MPI_PRECOMP11(lensend),inext,5500+isend,
3512 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3513 & iprev,5500+irecv,FG_COMM,status,IERR)
3514 c write (iout,*) "Gather PRECOMP11"
3516 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3517 & MPI_PRECOMP12(lensend),inext,6600+isend,
3518 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3519 & iprev,6600+irecv,FG_COMM,status,IERR)
3520 c write (iout,*) "Gather PRECOMP12"
3522 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3524 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3525 & MPI_ROTAT2(lensend),inext,7700+isend,
3526 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3527 & iprev,7700+irecv,FG_COMM,status,IERR)
3528 c write (iout,*) "Gather PRECOMP21"
3530 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3531 & MPI_PRECOMP22(lensend),inext,8800+isend,
3532 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3533 & iprev,8800+irecv,FG_COMM,status,IERR)
3534 c write (iout,*) "Gather PRECOMP22"
3536 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3537 & MPI_PRECOMP23(lensend),inext,9900+isend,
3538 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3539 & MPI_PRECOMP23(lenrecv),
3540 & iprev,9900+irecv,FG_COMM,status,IERR)
3541 c write (iout,*) "Gather PRECOMP23"
3546 if (irecv.lt.0) irecv=nfgtasks1-1
3549 time_gather=time_gather+MPI_Wtime()-time00
3552 c if (fg_rank.eq.0) then
3553 write (iout,*) "Arrays UG and UGDER"
3555 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3556 & ((ug(l,k,i),l=1,2),k=1,2),
3557 & ((ugder(l,k,i),l=1,2),k=1,2)
3559 write (iout,*) "Arrays UG2 and UG2DER"
3561 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3562 & ((ug2(l,k,i),l=1,2),k=1,2),
3563 & ((ug2der(l,k,i),l=1,2),k=1,2)
3565 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3567 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3568 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3569 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3571 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3573 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3574 & costab(i),sintab(i),costab2(i),sintab2(i)
3576 write (iout,*) "Array MUDER"
3578 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3584 cd iti = itype2loc(itype(i))
3587 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3588 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3593 C--------------------------------------------------------------------------
3594 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3596 C This subroutine calculates the average interaction energy and its gradient
3597 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3598 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3599 C The potential depends both on the distance of peptide-group centers and on
3600 C the orientation of the CA-CA virtual bonds.
3606 include 'DIMENSIONS'
3607 include 'COMMON.CONTROL'
3608 include 'COMMON.SETUP'
3609 include 'COMMON.IOUNITS'
3610 include 'COMMON.GEO'
3611 include 'COMMON.VAR'
3612 include 'COMMON.LOCAL'
3613 include 'COMMON.CHAIN'
3614 include 'COMMON.DERIV'
3615 include 'COMMON.INTERACT'
3616 include 'COMMON.CONTACTS'
3617 include 'COMMON.TORSION'
3618 include 'COMMON.VECTORS'
3619 include 'COMMON.FFIELD'
3620 include 'COMMON.TIME1'
3621 include 'COMMON.SPLITELE'
3622 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3623 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3624 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3625 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3626 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3627 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3629 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3631 double precision scal_el /1.0d0/
3633 double precision scal_el /0.5d0/
3636 C 13-go grudnia roku pamietnego...
3637 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3638 & 0.0d0,1.0d0,0.0d0,
3639 & 0.0d0,0.0d0,1.0d0/
3640 cd write(iout,*) 'In EELEC'
3642 cd write(iout,*) 'Type',i
3643 cd write(iout,*) 'B1',B1(:,i)
3644 cd write(iout,*) 'B2',B2(:,i)
3645 cd write(iout,*) 'CC',CC(:,:,i)
3646 cd write(iout,*) 'DD',DD(:,:,i)
3647 cd write(iout,*) 'EE',EE(:,:,i)
3649 cd call check_vecgrad
3651 if (icheckgrad.eq.1) then
3653 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3655 dc_norm(k,i)=dc(k,i)*fac
3657 c write (iout,*) 'i',i,' fac',fac
3660 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3661 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3662 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3663 c call vec_and_deriv
3669 time_mat=time_mat+MPI_Wtime()-time01
3673 cd write (iout,*) 'i=',i
3675 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3678 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3679 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3692 cd print '(a)','Enter EELEC'
3693 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3695 gel_loc_loc(i)=0.0d0
3700 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3702 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3704 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3705 do i=iturn3_start,iturn3_end
3707 C write(iout,*) "tu jest i",i
3708 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3709 C changes suggested by Ana to avoid out of bounds
3710 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3711 c & .or.((i+4).gt.nres)
3712 c & .or.((i-1).le.0)
3713 C end of changes by Ana
3714 & .or. itype(i+2).eq.ntyp1
3715 & .or. itype(i+3).eq.ntyp1) cycle
3716 C Adam: Instructions below will switch off existing interactions
3718 c if(itype(i-1).eq.ntyp1)cycle
3720 c if(i.LT.nres-3)then
3721 c if (itype(i+4).eq.ntyp1) cycle
3726 dx_normi=dc_norm(1,i)
3727 dy_normi=dc_norm(2,i)
3728 dz_normi=dc_norm(3,i)
3729 xmedi=c(1,i)+0.5d0*dxi
3730 ymedi=c(2,i)+0.5d0*dyi
3731 zmedi=c(3,i)+0.5d0*dzi
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 call eelecij(i,i+2,ees,evdw1,eel_loc)
3740 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3741 num_cont_hb(i)=num_conti
3743 do i=iturn4_start,iturn4_end
3745 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3746 C changes suggested by Ana to avoid out of bounds
3747 c & .or.((i+5).gt.nres)
3748 c & .or.((i-1).le.0)
3749 C end of changes suggested by Ana
3750 & .or. itype(i+3).eq.ntyp1
3751 & .or. itype(i+4).eq.ntyp1
3752 c & .or. itype(i+5).eq.ntyp1
3753 c & .or. itype(i).eq.ntyp1
3754 c & .or. itype(i-1).eq.ntyp1
3759 dx_normi=dc_norm(1,i)
3760 dy_normi=dc_norm(2,i)
3761 dz_normi=dc_norm(3,i)
3762 xmedi=c(1,i)+0.5d0*dxi
3763 ymedi=c(2,i)+0.5d0*dyi
3764 zmedi=c(3,i)+0.5d0*dzi
3765 C Return atom into box, boxxsize is size of box in x dimension
3767 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3768 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3769 C Condition for being inside the proper box
3770 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3771 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3775 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3776 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3777 C Condition for being inside the proper box
3778 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3779 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3783 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3784 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3785 C Condition for being inside the proper box
3786 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3787 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3790 xmedi=mod(xmedi,boxxsize)
3791 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3792 ymedi=mod(ymedi,boxysize)
3793 if (ymedi.lt.0) ymedi=ymedi+boxysize
3794 zmedi=mod(zmedi,boxzsize)
3795 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3797 num_conti=num_cont_hb(i)
3798 c write(iout,*) "JESTEM W PETLI"
3799 call eelecij(i,i+3,ees,evdw1,eel_loc)
3800 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3801 & call eturn4(i,eello_turn4)
3802 num_cont_hb(i)=num_conti
3804 C Loop over all neighbouring boxes
3809 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3812 do i=iatel_s,iatel_e
3815 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3816 C changes suggested by Ana to avoid out of bounds
3817 c & .or.((i+2).gt.nres)
3818 c & .or.((i-1).le.0)
3819 C end of changes by Ana
3820 c & .or. itype(i+2).eq.ntyp1
3821 c & .or. itype(i-1).eq.ntyp1
3826 dx_normi=dc_norm(1,i)
3827 dy_normi=dc_norm(2,i)
3828 dz_normi=dc_norm(3,i)
3829 xmedi=c(1,i)+0.5d0*dxi
3830 ymedi=c(2,i)+0.5d0*dyi
3831 zmedi=c(3,i)+0.5d0*dzi
3832 xmedi=mod(xmedi,boxxsize)
3833 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3834 ymedi=mod(ymedi,boxysize)
3835 if (ymedi.lt.0) ymedi=ymedi+boxysize
3836 zmedi=mod(zmedi,boxzsize)
3837 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3838 C xmedi=xmedi+xshift*boxxsize
3839 C ymedi=ymedi+yshift*boxysize
3840 C zmedi=zmedi+zshift*boxzsize
3842 C Return tom into box, boxxsize is size of box in x dimension
3844 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3845 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3846 C Condition for being inside the proper box
3847 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3848 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3852 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3853 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3854 C Condition for being inside the proper box
3855 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3856 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3860 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3861 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3862 cC Condition for being inside the proper box
3863 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3864 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3868 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3869 num_conti=num_cont_hb(i)
3871 do j=ielstart(i),ielend(i)
3873 C write (iout,*) i,j
3875 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3876 C changes suggested by Ana to avoid out of bounds
3877 c & .or.((j+2).gt.nres)
3878 c & .or.((j-1).le.0)
3879 C end of changes by Ana
3880 c & .or.itype(j+2).eq.ntyp1
3881 c & .or.itype(j-1).eq.ntyp1
3883 call eelecij(i,j,ees,evdw1,eel_loc)
3885 num_cont_hb(i)=num_conti
3891 c write (iout,*) "Number of loop steps in EELEC:",ind
3893 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3894 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3896 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3897 ccc eel_loc=eel_loc+eello_turn3
3898 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3901 C-------------------------------------------------------------------------------
3902 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3904 include 'DIMENSIONS'
3908 include 'COMMON.CONTROL'
3909 include 'COMMON.IOUNITS'
3910 include 'COMMON.GEO'
3911 include 'COMMON.VAR'
3912 include 'COMMON.LOCAL'
3913 include 'COMMON.CHAIN'
3914 include 'COMMON.DERIV'
3915 include 'COMMON.INTERACT'
3916 include 'COMMON.CONTACTS'
3917 include 'COMMON.TORSION'
3918 include 'COMMON.VECTORS'
3919 include 'COMMON.FFIELD'
3920 include 'COMMON.TIME1'
3921 include 'COMMON.SPLITELE'
3922 include 'COMMON.SHIELD'
3923 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3924 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3925 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3926 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3927 & gmuij2(4),gmuji2(4)
3928 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3929 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3931 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3933 double precision scal_el /1.0d0/
3935 double precision scal_el /0.5d0/
3938 C 13-go grudnia roku pamietnego...
3939 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3940 & 0.0d0,1.0d0,0.0d0,
3941 & 0.0d0,0.0d0,1.0d0/
3942 integer xshift,yshift,zshift
3943 c time00=MPI_Wtime()
3944 cd write (iout,*) "eelecij",i,j
3948 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3949 aaa=app(iteli,itelj)
3950 bbb=bpp(iteli,itelj)
3951 ael6i=ael6(iteli,itelj)
3952 ael3i=ael3(iteli,itelj)
3956 dx_normj=dc_norm(1,j)
3957 dy_normj=dc_norm(2,j)
3958 dz_normj=dc_norm(3,j)
3959 C xj=c(1,j)+0.5D0*dxj-xmedi
3960 C yj=c(2,j)+0.5D0*dyj-ymedi
3961 C zj=c(3,j)+0.5D0*dzj-zmedi
3966 if (xj.lt.0) xj=xj+boxxsize
3968 if (yj.lt.0) yj=yj+boxysize
3970 if (zj.lt.0) zj=zj+boxzsize
3971 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3972 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3980 xj=xj_safe+xshift*boxxsize
3981 yj=yj_safe+yshift*boxysize
3982 zj=zj_safe+zshift*boxzsize
3983 dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3984 if(dist_temp.lt.dist_init) then
3994 if (isubchap.eq.1) then
4003 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
4005 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4006 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4007 C Condition for being inside the proper box
4008 c if ((xj.gt.((0.5d0)*boxxsize)).or.
4009 c & (xj.lt.((-0.5d0)*boxxsize))) then
4013 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4014 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4015 C Condition for being inside the proper box
4016 c if ((yj.gt.((0.5d0)*boxysize)).or.
4017 c & (yj.lt.((-0.5d0)*boxysize))) then
4021 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4022 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4023 C Condition for being inside the proper box
4024 c if ((zj.gt.((0.5d0)*boxzsize)).or.
4025 c & (zj.lt.((-0.5d0)*boxzsize))) then
4028 C endif !endPBC condintion
4032 rij=xj*xj+yj*yj+zj*zj
4034 sss=sscale(sqrt(rij))
4035 sssgrad=sscagrad(sqrt(rij))
4036 c if (sss.gt.0.0d0) then
4042 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4043 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4044 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4045 fac=cosa-3.0D0*cosb*cosg
4047 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4048 if (j.eq.i+2) ev1=scal_el*ev1
4053 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4057 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4058 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4059 if (shield_mode.gt.0) then
4062 el1=el1*fac_shield(i)**2*fac_shield(j)**2
4063 el2=el2*fac_shield(i)**2*fac_shield(j)**2
4072 evdw1=evdw1+evdwij*sss
4073 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4074 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4075 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
4076 cd & xmedi,ymedi,zmedi,xj,yj,zj
4078 if (energy_dec) then
4079 write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
4081 &,iteli,itelj,aaa,evdw1,sss
4082 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4083 &fac_shield(i),fac_shield(j)
4087 C Calculate contributions to the Cartesian gradient.
4090 facvdw=-6*rrmij*(ev1+evdwij)*sss
4091 facel=-3*rrmij*(el1+eesij)
4098 * Radial derivatives. First process both termini of the fragment (i,j)
4103 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4104 & (shield_mode.gt.0)) then
4106 do ilist=1,ishield_list(i)
4107 iresshield=shield_list(ilist,i)
4109 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4111 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4113 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4114 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4115 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4116 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4117 C if (iresshield.gt.i) then
4118 C do ishi=i+1,iresshield-1
4119 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4120 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4124 C do ishi=iresshield,i
4125 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4126 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4132 do ilist=1,ishield_list(j)
4133 iresshield=shield_list(ilist,j)
4135 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4137 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4139 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4140 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4142 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4143 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4144 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4145 C if (iresshield.gt.j) then
4146 C do ishi=j+1,iresshield-1
4147 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4148 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4152 C do ishi=iresshield,j
4153 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4154 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4161 gshieldc(k,i)=gshieldc(k,i)+
4162 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4163 gshieldc(k,j)=gshieldc(k,j)+
4164 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4165 gshieldc(k,i-1)=gshieldc(k,i-1)+
4166 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4167 gshieldc(k,j-1)=gshieldc(k,j-1)+
4168 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4173 c ghalf=0.5D0*ggg(k)
4174 c gelc(k,i)=gelc(k,i)+ghalf
4175 c gelc(k,j)=gelc(k,j)+ghalf
4177 c 9/28/08 AL Gradient compotents will be summed only at the end
4178 C print *,"before", gelc_long(1,i), gelc_long(1,j)
4180 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4181 C & +grad_shield(k,j)*eesij/fac_shield(j)
4182 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4183 C & +grad_shield(k,i)*eesij/fac_shield(i)
4184 C gelc_long(k,i-1)=gelc_long(k,i-1)
4185 C & +grad_shield(k,i)*eesij/fac_shield(i)
4186 C gelc_long(k,j-1)=gelc_long(k,j-1)
4187 C & +grad_shield(k,j)*eesij/fac_shield(j)
4189 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4192 * Loop over residues i+1 thru j-1.
4196 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4199 if (sss.gt.0.0) then
4200 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4201 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4202 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4209 c ghalf=0.5D0*ggg(k)
4210 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4211 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4213 c 9/28/08 AL Gradient compotents will be summed only at the end
4215 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4216 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4219 * Loop over residues i+1 thru j-1.
4223 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4228 facvdw=(ev1+evdwij)*sss
4231 fac=-3*rrmij*(facvdw+facvdw+facel)
4236 * Radial derivatives. First process both termini of the fragment (i,j)
4239 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4241 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4243 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4245 c ghalf=0.5D0*ggg(k)
4246 c gelc(k,i)=gelc(k,i)+ghalf
4247 c gelc(k,j)=gelc(k,j)+ghalf
4249 c 9/28/08 AL Gradient compotents will be summed only at the end
4251 gelc_long(k,j)=gelc(k,j)+ggg(k)
4252 gelc_long(k,i)=gelc(k,i)-ggg(k)
4255 * Loop over residues i+1 thru j-1.
4259 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4262 c 9/28/08 AL Gradient compotents will be summed only at the end
4263 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4264 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4265 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4267 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4268 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4274 ecosa=2.0D0*fac3*fac1+fac4
4277 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4278 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4280 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4281 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4283 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4284 cd & (dcosg(k),k=1,3)
4286 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4287 & fac_shield(i)**2*fac_shield(j)**2
4290 c ghalf=0.5D0*ggg(k)
4291 c gelc(k,i)=gelc(k,i)+ghalf
4292 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4293 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4294 c gelc(k,j)=gelc(k,j)+ghalf
4295 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4296 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4300 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4303 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4306 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4307 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4308 & *fac_shield(i)**2*fac_shield(j)**2
4310 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4311 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4312 & *fac_shield(i)**2*fac_shield(j)**2
4313 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4314 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4316 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4320 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4321 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4322 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4324 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4325 C energy of a peptide unit is assumed in the form of a second-order
4326 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4327 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4328 C are computed for EVERY pair of non-contiguous peptide groups.
4331 if (j.lt.nres-1) then
4343 muij(kkk)=mu(k,i)*mu(l,j)
4344 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4346 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4347 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4348 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4349 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4350 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4351 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4356 write (iout,*) 'EELEC: i',i,' j',j
4357 write (iout,*) 'j',j,' j1',j1,' j2',j2
4358 write(iout,*) 'muij',muij
4360 ury=scalar(uy(1,i),erij)
4361 urz=scalar(uz(1,i),erij)
4362 vry=scalar(uy(1,j),erij)
4363 vrz=scalar(uz(1,j),erij)
4364 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4365 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4366 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4367 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4368 fac=dsqrt(-ael6i)*r3ij
4370 write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4371 write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4372 & "uyvz",scalar(uy(1,i),uz(1,j)),
4373 & "uzvy",scalar(uz(1,i),uy(1,j)),
4374 & "uzvz",scalar(uz(1,i),uz(1,j))
4375 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4376 write (iout,*) "fac",fac
4383 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4386 cd write (iout,'(4i5,4f10.5)')
4387 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4388 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4389 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4390 cd & uy(:,j),uz(:,j)
4391 cd write (iout,'(4f10.5)')
4392 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4393 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4394 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4395 cd write (iout,'(9f10.5/)')
4396 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4397 C Derivatives of the elements of A in virtual-bond vectors
4398 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4400 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4401 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4402 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4403 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4404 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4405 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4406 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4407 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4408 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4409 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4410 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4411 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4413 C Compute radial contributions to the gradient
4431 C Add the contributions coming from er
4434 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4435 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4436 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4437 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4440 C Derivatives in DC(i)
4441 cgrad ghalf1=0.5d0*agg(k,1)
4442 cgrad ghalf2=0.5d0*agg(k,2)
4443 cgrad ghalf3=0.5d0*agg(k,3)
4444 cgrad ghalf4=0.5d0*agg(k,4)
4445 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4446 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4447 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4448 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4449 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4450 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4451 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4452 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4453 C Derivatives in DC(i+1)
4454 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4455 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4456 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4457 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4458 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4459 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4460 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4461 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4462 C Derivatives in DC(j)
4463 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4464 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4465 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4466 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4467 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4468 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4469 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4470 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4471 C Derivatives in DC(j+1) or DC(nres-1)
4472 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4473 & -3.0d0*vryg(k,3)*ury)
4474 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4475 & -3.0d0*vrzg(k,3)*ury)
4476 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4477 & -3.0d0*vryg(k,3)*urz)
4478 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4479 & -3.0d0*vrzg(k,3)*urz)
4480 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4482 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4495 aggi(k,l)=-aggi(k,l)
4496 aggi1(k,l)=-aggi1(k,l)
4497 aggj(k,l)=-aggj(k,l)
4498 aggj1(k,l)=-aggj1(k,l)
4501 if (j.lt.nres-1) then
4507 aggi(k,l)=-aggi(k,l)
4508 aggi1(k,l)=-aggi1(k,l)
4509 aggj(k,l)=-aggj(k,l)
4510 aggj1(k,l)=-aggj1(k,l)
4521 aggi(k,l)=-aggi(k,l)
4522 aggi1(k,l)=-aggi1(k,l)
4523 aggj(k,l)=-aggj(k,l)
4524 aggj1(k,l)=-aggj1(k,l)
4529 IF (wel_loc.gt.0.0d0) THEN
4530 C Contribution to the local-electrostatic energy coming from the i-j pair
4531 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4534 write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4536 write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4537 & " wel_loc",wel_loc
4539 if (shield_mode.eq.0) then
4546 eel_loc_ij=eel_loc_ij
4547 & *fac_shield(i)*fac_shield(j)
4548 c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4549 c & 'eelloc',i,j,eel_loc_ij
4550 C Now derivative over eel_loc
4551 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4552 & (shield_mode.gt.0)) then
4555 do ilist=1,ishield_list(i)
4556 iresshield=shield_list(ilist,i)
4558 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4561 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4563 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4564 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4568 do ilist=1,ishield_list(j)
4569 iresshield=shield_list(ilist,j)
4571 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4574 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4576 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4577 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4584 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4585 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4586 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4587 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4588 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4589 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4590 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4591 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4596 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4597 c & ' eel_loc_ij',eel_loc_ij
4598 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4599 C Calculate patrial derivative for theta angle
4601 geel_loc_ij=(a22*gmuij1(1)
4605 & *fac_shield(i)*fac_shield(j)
4606 c write(iout,*) "derivative over thatai"
4607 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4609 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4610 & geel_loc_ij*wel_loc
4611 c write(iout,*) "derivative over thatai-1"
4612 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4619 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4620 & geel_loc_ij*wel_loc
4621 & *fac_shield(i)*fac_shield(j)
4623 c Derivative over j residue
4624 geel_loc_ji=a22*gmuji1(1)
4628 c write(iout,*) "derivative over thataj"
4629 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4632 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4633 & geel_loc_ji*wel_loc
4634 & *fac_shield(i)*fac_shield(j)
4641 c write(iout,*) "derivative over thataj-1"
4642 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4644 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4645 & geel_loc_ji*wel_loc
4646 & *fac_shield(i)*fac_shield(j)
4648 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4650 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4651 & 'eelloc',i,j,eel_loc_ij
4652 c if (eel_loc_ij.ne.0)
4653 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4654 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4656 eel_loc=eel_loc+eel_loc_ij
4657 C Partial derivatives in virtual-bond dihedral angles gamma
4659 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4660 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4661 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4662 & *fac_shield(i)*fac_shield(j)
4664 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4665 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4666 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4667 & *fac_shield(i)*fac_shield(j)
4668 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4670 ggg(l)=(agg(l,1)*muij(1)+
4671 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4672 & *fac_shield(i)*fac_shield(j)
4673 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4674 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4675 cgrad ghalf=0.5d0*ggg(l)
4676 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4677 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4681 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4684 C Remaining derivatives of eello
4686 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4687 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4688 & *fac_shield(i)*fac_shield(j)
4690 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4691 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4692 & *fac_shield(i)*fac_shield(j)
4694 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4695 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4696 & *fac_shield(i)*fac_shield(j)
4698 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4699 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4700 & *fac_shield(i)*fac_shield(j)
4704 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4705 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4706 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4707 & .and. num_conti.le.maxconts) then
4708 c write (iout,*) i,j," entered corr"
4710 C Calculate the contact function. The ith column of the array JCONT will
4711 C contain the numbers of atoms that make contacts with the atom I (of numbers
4712 C greater than I). The arrays FACONT and GACONT will contain the values of
4713 C the contact function and its derivative.
4714 c r0ij=1.02D0*rpp(iteli,itelj)
4715 c r0ij=1.11D0*rpp(iteli,itelj)
4716 r0ij=2.20D0*rpp(iteli,itelj)
4717 c r0ij=1.55D0*rpp(iteli,itelj)
4718 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4719 if (fcont.gt.0.0D0) then
4720 num_conti=num_conti+1
4721 if (num_conti.gt.maxconts) then
4722 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4723 & ' will skip next contacts for this conf.'
4725 jcont_hb(num_conti,i)=j
4726 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4727 cd & " jcont_hb",jcont_hb(num_conti,i)
4728 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4729 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4730 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4732 d_cont(num_conti,i)=rij
4733 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4734 C --- Electrostatic-interaction matrix ---
4735 a_chuj(1,1,num_conti,i)=a22
4736 a_chuj(1,2,num_conti,i)=a23
4737 a_chuj(2,1,num_conti,i)=a32
4738 a_chuj(2,2,num_conti,i)=a33
4739 C --- Gradient of rij
4741 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4748 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4749 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4750 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4751 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4752 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4757 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4758 C Calculate contact energies
4760 wij=cosa-3.0D0*cosb*cosg
4763 c fac3=dsqrt(-ael6i)/r0ij**3
4764 fac3=dsqrt(-ael6i)*r3ij
4765 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4766 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4767 if (ees0tmp.gt.0) then
4768 ees0pij=dsqrt(ees0tmp)
4772 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4773 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4774 if (ees0tmp.gt.0) then
4775 ees0mij=dsqrt(ees0tmp)
4780 if (shield_mode.eq.0) then
4784 ees0plist(num_conti,i)=j
4785 C fac_shield(i)=0.4d0
4786 C fac_shield(j)=0.6d0
4788 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4789 & *fac_shield(i)*fac_shield(j)
4790 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4791 & *fac_shield(i)*fac_shield(j)
4792 C Diagnostics. Comment out or remove after debugging!
4793 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4794 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4795 c ees0m(num_conti,i)=0.0D0
4797 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4798 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4799 C Angular derivatives of the contact function
4800 ees0pij1=fac3/ees0pij
4801 ees0mij1=fac3/ees0mij
4802 fac3p=-3.0D0*fac3*rrmij
4803 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4804 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4806 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4807 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4808 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4809 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4810 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4811 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4812 ecosap=ecosa1+ecosa2
4813 ecosbp=ecosb1+ecosb2
4814 ecosgp=ecosg1+ecosg2
4815 ecosam=ecosa1-ecosa2
4816 ecosbm=ecosb1-ecosb2
4817 ecosgm=ecosg1-ecosg2
4826 facont_hb(num_conti,i)=fcont
4827 fprimcont=fprimcont/rij
4828 cd facont_hb(num_conti,i)=1.0D0
4829 C Following line is for diagnostics.
4832 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4833 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4836 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4837 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4839 gggp(1)=gggp(1)+ees0pijp*xj
4840 gggp(2)=gggp(2)+ees0pijp*yj
4841 gggp(3)=gggp(3)+ees0pijp*zj
4842 gggm(1)=gggm(1)+ees0mijp*xj
4843 gggm(2)=gggm(2)+ees0mijp*yj
4844 gggm(3)=gggm(3)+ees0mijp*zj
4845 C Derivatives due to the contact function
4846 gacont_hbr(1,num_conti,i)=fprimcont*xj
4847 gacont_hbr(2,num_conti,i)=fprimcont*yj
4848 gacont_hbr(3,num_conti,i)=fprimcont*zj
4851 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4852 c following the change of gradient-summation algorithm.
4854 cgrad ghalfp=0.5D0*gggp(k)
4855 cgrad ghalfm=0.5D0*gggm(k)
4856 gacontp_hb1(k,num_conti,i)=!ghalfp
4857 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4858 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4859 & *fac_shield(i)*fac_shield(j)
4861 gacontp_hb2(k,num_conti,i)=!ghalfp
4862 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4863 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4864 & *fac_shield(i)*fac_shield(j)
4866 gacontp_hb3(k,num_conti,i)=gggp(k)
4867 & *fac_shield(i)*fac_shield(j)
4869 gacontm_hb1(k,num_conti,i)=!ghalfm
4870 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4871 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4872 & *fac_shield(i)*fac_shield(j)
4874 gacontm_hb2(k,num_conti,i)=!ghalfm
4875 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4876 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4877 & *fac_shield(i)*fac_shield(j)
4879 gacontm_hb3(k,num_conti,i)=gggm(k)
4880 & *fac_shield(i)*fac_shield(j)
4883 C Diagnostics. Comment out or remove after debugging!
4885 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4886 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4887 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4888 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4889 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4890 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4893 endif ! num_conti.le.maxconts
4896 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4899 ghalf=0.5d0*agg(l,k)
4900 aggi(l,k)=aggi(l,k)+ghalf
4901 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4902 aggj(l,k)=aggj(l,k)+ghalf
4905 if (j.eq.nres-1 .and. i.lt.j-2) then
4908 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4913 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4916 C-----------------------------------------------------------------------------
4917 subroutine eturn3(i,eello_turn3)
4918 C Third- and fourth-order contributions from turns
4920 include 'DIMENSIONS'
4921 include 'COMMON.IOUNITS'
4922 include 'COMMON.GEO'
4923 include 'COMMON.VAR'
4924 include 'COMMON.LOCAL'
4925 include 'COMMON.CHAIN'
4926 include 'COMMON.DERIV'
4927 include 'COMMON.INTERACT'
4928 include 'COMMON.CONTACTS'
4929 include 'COMMON.TORSION'
4930 include 'COMMON.VECTORS'
4931 include 'COMMON.FFIELD'
4932 include 'COMMON.CONTROL'
4933 include 'COMMON.SHIELD'
4935 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4936 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4937 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4938 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4939 & auxgmat2(2,2),auxgmatt2(2,2)
4940 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4941 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4942 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4943 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4946 c write (iout,*) "eturn3",i,j,j1,j2
4951 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4953 C Third-order contributions
4960 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4961 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4962 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4963 c auxalary matices for theta gradient
4964 c auxalary matrix for i+1 and constant i+2
4965 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4966 c auxalary matrix for i+2 and constant i+1
4967 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4968 call transpose2(auxmat(1,1),auxmat1(1,1))
4969 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4970 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4971 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4972 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4973 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4974 if (shield_mode.eq.0) then
4981 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4982 & *fac_shield(i)*fac_shield(j)
4983 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4984 & *fac_shield(i)*fac_shield(j)
4985 if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4988 C Derivatives in theta
4989 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4990 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4991 & *fac_shield(i)*fac_shield(j)
4992 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4993 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4994 & *fac_shield(i)*fac_shield(j)
4997 C Derivatives in shield mode
4998 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4999 & (shield_mode.gt.0)) then
5002 do ilist=1,ishield_list(i)
5003 iresshield=shield_list(ilist,i)
5005 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5007 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5009 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5010 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5014 do ilist=1,ishield_list(j)
5015 iresshield=shield_list(ilist,j)
5017 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5019 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5021 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5022 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5029 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5030 & grad_shield(k,i)*eello_t3/fac_shield(i)
5031 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5032 & grad_shield(k,j)*eello_t3/fac_shield(j)
5033 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5034 & grad_shield(k,i)*eello_t3/fac_shield(i)
5035 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5036 & grad_shield(k,j)*eello_t3/fac_shield(j)
5040 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5041 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
5042 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
5043 cd & ' eello_turn3_num',4*eello_turn3_num
5044 C Derivatives in gamma(i)
5045 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5046 call transpose2(auxmat2(1,1),auxmat3(1,1))
5047 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5048 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5049 & *fac_shield(i)*fac_shield(j)
5050 C Derivatives in gamma(i+1)
5051 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5052 call transpose2(auxmat2(1,1),auxmat3(1,1))
5053 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5054 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5055 & +0.5d0*(pizda(1,1)+pizda(2,2))
5056 & *fac_shield(i)*fac_shield(j)
5057 C Cartesian derivatives
5059 c ghalf1=0.5d0*agg(l,1)
5060 c ghalf2=0.5d0*agg(l,2)
5061 c ghalf3=0.5d0*agg(l,3)
5062 c ghalf4=0.5d0*agg(l,4)
5063 a_temp(1,1)=aggi(l,1)!+ghalf1
5064 a_temp(1,2)=aggi(l,2)!+ghalf2
5065 a_temp(2,1)=aggi(l,3)!+ghalf3
5066 a_temp(2,2)=aggi(l,4)!+ghalf4
5067 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5068 gcorr3_turn(l,i)=gcorr3_turn(l,i)
5069 & +0.5d0*(pizda(1,1)+pizda(2,2))
5070 & *fac_shield(i)*fac_shield(j)
5072 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5073 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5074 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5075 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5076 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5077 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5078 & +0.5d0*(pizda(1,1)+pizda(2,2))
5079 & *fac_shield(i)*fac_shield(j)
5080 a_temp(1,1)=aggj(l,1)!+ghalf1
5081 a_temp(1,2)=aggj(l,2)!+ghalf2
5082 a_temp(2,1)=aggj(l,3)!+ghalf3
5083 a_temp(2,2)=aggj(l,4)!+ghalf4
5084 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5085 gcorr3_turn(l,j)=gcorr3_turn(l,j)
5086 & +0.5d0*(pizda(1,1)+pizda(2,2))
5087 & *fac_shield(i)*fac_shield(j)
5088 a_temp(1,1)=aggj1(l,1)
5089 a_temp(1,2)=aggj1(l,2)
5090 a_temp(2,1)=aggj1(l,3)
5091 a_temp(2,2)=aggj1(l,4)
5092 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5093 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5094 & +0.5d0*(pizda(1,1)+pizda(2,2))
5095 & *fac_shield(i)*fac_shield(j)
5099 C-------------------------------------------------------------------------------
5100 subroutine eturn4(i,eello_turn4)
5101 C Third- and fourth-order contributions from turns
5103 include 'DIMENSIONS'
5104 include 'COMMON.IOUNITS'
5105 include 'COMMON.GEO'
5106 include 'COMMON.VAR'
5107 include 'COMMON.LOCAL'
5108 include 'COMMON.CHAIN'
5109 include 'COMMON.DERIV'
5110 include 'COMMON.INTERACT'
5111 include 'COMMON.CONTACTS'
5112 include 'COMMON.TORSION'
5113 include 'COMMON.VECTORS'
5114 include 'COMMON.FFIELD'
5115 include 'COMMON.CONTROL'
5116 include 'COMMON.SHIELD'
5118 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5119 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5120 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5121 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5122 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
5123 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5124 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5125 double precision agg(3,4),aggi(3,4),aggi1(3,4),
5126 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5127 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5128 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5131 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5133 C Fourth-order contributions
5141 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5142 cd call checkint_turn4(i,a_temp,eello_turn4_num)
5143 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5144 c write(iout,*)"WCHODZE W PROGRAM"
5149 iti1=itype2loc(itype(i+1))
5150 iti2=itype2loc(itype(i+2))
5151 iti3=itype2loc(itype(i+3))
5152 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5153 call transpose2(EUg(1,1,i+1),e1t(1,1))
5154 call transpose2(Eug(1,1,i+2),e2t(1,1))
5155 call transpose2(Eug(1,1,i+3),e3t(1,1))
5156 C Ematrix derivative in theta
5157 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5158 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5159 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5160 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5161 c eta1 in derivative theta
5162 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5163 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5164 c auxgvec is derivative of Ub2 so i+3 theta
5165 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5166 c auxalary matrix of E i+1
5167 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5170 s1=scalar2(b1(1,i+2),auxvec(1))
5171 c derivative of theta i+2 with constant i+3
5172 gs23=scalar2(gtb1(1,i+2),auxvec(1))
5173 c derivative of theta i+2 with constant i+2
5174 gs32=scalar2(b1(1,i+2),auxgvec(1))
5175 c derivative of E matix in theta of i+1
5176 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5178 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5179 c ea31 in derivative theta
5180 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5181 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5182 c auxilary matrix auxgvec of Ub2 with constant E matirx
5183 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5184 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5185 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5189 s2=scalar2(b1(1,i+1),auxvec(1))
5190 c derivative of theta i+1 with constant i+3
5191 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5192 c derivative of theta i+2 with constant i+1
5193 gs21=scalar2(b1(1,i+1),auxgvec(1))
5194 c derivative of theta i+3 with constant i+1
5195 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5196 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5198 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5199 c two derivatives over diffetent matrices
5200 c gtae3e2 is derivative over i+3
5201 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5202 c ae3gte2 is derivative over i+2
5203 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5204 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5205 c three possible derivative over theta E matices
5207 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5209 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5211 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5212 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5214 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5215 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5216 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5217 if (shield_mode.eq.0) then
5224 eello_turn4=eello_turn4-(s1+s2+s3)
5225 & *fac_shield(i)*fac_shield(j)
5226 eello_t4=-(s1+s2+s3)
5227 & *fac_shield(i)*fac_shield(j)
5228 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5229 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5230 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5231 C Now derivative over shield:
5232 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5233 & (shield_mode.gt.0)) then
5236 do ilist=1,ishield_list(i)
5237 iresshield=shield_list(ilist,i)
5239 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5241 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5243 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5244 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5248 do ilist=1,ishield_list(j)
5249 iresshield=shield_list(ilist,j)
5251 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5253 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5255 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5256 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5263 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5264 & grad_shield(k,i)*eello_t4/fac_shield(i)
5265 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5266 & grad_shield(k,j)*eello_t4/fac_shield(j)
5267 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5268 & grad_shield(k,i)*eello_t4/fac_shield(i)
5269 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5270 & grad_shield(k,j)*eello_t4/fac_shield(j)
5275 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5276 & -(gs13+gsE13+gsEE1)*wturn4
5277 & *fac_shield(i)*fac_shield(j)
5278 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5279 & -(gs23+gs21+gsEE2)*wturn4
5280 & *fac_shield(i)*fac_shield(j)
5282 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5283 & -(gs32+gsE31+gsEE3)*wturn4
5284 & *fac_shield(i)*fac_shield(j)
5286 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5289 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5290 & 'eturn4',i,j,-(s1+s2+s3)
5291 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5292 c & ' eello_turn4_num',8*eello_turn4_num
5293 C Derivatives in gamma(i)
5294 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5295 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5296 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5297 s1=scalar2(b1(1,i+2),auxvec(1))
5298 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5299 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5300 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5301 & *fac_shield(i)*fac_shield(j)
5302 C Derivatives in gamma(i+1)
5303 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5304 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5305 s2=scalar2(b1(1,i+1),auxvec(1))
5306 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5307 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5308 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5309 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5310 & *fac_shield(i)*fac_shield(j)
5311 C Derivatives in gamma(i+2)
5312 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5313 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5314 s1=scalar2(b1(1,i+2),auxvec(1))
5315 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5316 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5317 s2=scalar2(b1(1,i+1),auxvec(1))
5318 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5319 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5320 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5321 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5322 & *fac_shield(i)*fac_shield(j)
5323 C Cartesian derivatives
5324 C Derivatives of this turn contributions in DC(i+2)
5325 if (j.lt.nres-1) then
5327 a_temp(1,1)=agg(l,1)
5328 a_temp(1,2)=agg(l,2)
5329 a_temp(2,1)=agg(l,3)
5330 a_temp(2,2)=agg(l,4)
5331 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5332 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5333 s1=scalar2(b1(1,i+2),auxvec(1))
5334 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5335 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5336 s2=scalar2(b1(1,i+1),auxvec(1))
5337 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5338 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5339 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5341 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5342 & *fac_shield(i)*fac_shield(j)
5345 C Remaining derivatives of this turn contribution
5347 a_temp(1,1)=aggi(l,1)
5348 a_temp(1,2)=aggi(l,2)
5349 a_temp(2,1)=aggi(l,3)
5350 a_temp(2,2)=aggi(l,4)
5351 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5352 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5353 s1=scalar2(b1(1,i+2),auxvec(1))
5354 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5355 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5356 s2=scalar2(b1(1,i+1),auxvec(1))
5357 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5358 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5359 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5360 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5361 & *fac_shield(i)*fac_shield(j)
5362 a_temp(1,1)=aggi1(l,1)
5363 a_temp(1,2)=aggi1(l,2)
5364 a_temp(2,1)=aggi1(l,3)
5365 a_temp(2,2)=aggi1(l,4)
5366 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5367 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5368 & *fac_shield(i)*fac_shield(j)
5369 a_temp(1,1)=aggi1(l,1)
5370 a_temp(1,2)=aggi1(l,2)
5371 a_temp(2,1)=aggi1(l,3)
5372 a_temp(2,2)=aggi1(l,4)
5373 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5374 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5375 s1=scalar2(b1(1,i+2),auxvec(1))
5376 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5377 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5378 s2=scalar2(b1(1,i+1),auxvec(1))
5379 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5380 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5381 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5382 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5383 & *fac_shield(i)*fac_shield(j)
5384 a_temp(1,1)=aggj(l,1)
5385 a_temp(1,2)=aggj(l,2)
5386 a_temp(2,1)=aggj(l,3)
5387 a_temp(2,2)=aggj(l,4)
5388 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5389 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5390 s1=scalar2(b1(1,i+2),auxvec(1))
5391 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5392 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5393 s2=scalar2(b1(1,i+1),auxvec(1))
5394 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5395 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5396 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5397 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5398 & *fac_shield(i)*fac_shield(j)
5399 a_temp(1,1)=aggj1(l,1)
5400 a_temp(1,2)=aggj1(l,2)
5401 a_temp(2,1)=aggj1(l,3)
5402 a_temp(2,2)=aggj1(l,4)
5403 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5404 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5405 s1=scalar2(b1(1,i+2),auxvec(1))
5406 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5407 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5408 s2=scalar2(b1(1,i+1),auxvec(1))
5409 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5410 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5411 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5412 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5413 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5414 & *fac_shield(i)*fac_shield(j)
5418 C-----------------------------------------------------------------------------
5419 subroutine vecpr(u,v,w)
5421 double precision u(3),v(3),w(3)
5422 w(1)=u(2)*v(3)-u(3)*v(2)
5423 w(2)=-u(1)*v(3)+u(3)*v(1)
5424 w(3)=u(1)*v(2)-u(2)*v(1)
5427 C-----------------------------------------------------------------------------
5428 subroutine unormderiv(u,ugrad,unorm,ungrad)
5429 C This subroutine computes the derivatives of a normalized vector u, given
5430 C the derivatives computed without normalization conditions, ugrad. Returns
5433 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5434 double precision vec(3)
5435 double precision scalar
5437 c write (2,*) 'ugrad',ugrad
5440 vec(i)=scalar(ugrad(1,i),u(1))
5442 c write (2,*) 'vec',vec
5445 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5448 c write (2,*) 'ungrad',ungrad
5451 C-----------------------------------------------------------------------------
5452 subroutine escp_soft_sphere(evdw2,evdw2_14)
5454 C This subroutine calculates the excluded-volume interaction energy between
5455 C peptide-group centers and side chains and its gradient in virtual-bond and
5456 C side-chain vectors.
5459 include 'DIMENSIONS'
5460 include 'COMMON.GEO'
5461 include 'COMMON.VAR'
5462 include 'COMMON.LOCAL'
5463 include 'COMMON.CHAIN'
5464 include 'COMMON.DERIV'
5465 include 'COMMON.INTERACT'
5466 include 'COMMON.FFIELD'
5467 include 'COMMON.IOUNITS'
5468 include 'COMMON.CONTROL'
5470 integer xshift,yshift,zshift
5474 cd print '(a)','Enter ESCP'
5475 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5479 do i=iatscp_s,iatscp_e
5480 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5482 xi=0.5D0*(c(1,i)+c(1,i+1))
5483 yi=0.5D0*(c(2,i)+c(2,i+1))
5484 zi=0.5D0*(c(3,i)+c(3,i+1))
5485 C Return atom into box, boxxsize is size of box in x dimension
5487 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5488 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5489 C Condition for being inside the proper box
5490 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5491 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5495 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5496 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5497 C Condition for being inside the proper box
5498 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5499 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5503 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5504 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5505 cC Condition for being inside the proper box
5506 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5507 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5511 if (xi.lt.0) xi=xi+boxxsize
5513 if (yi.lt.0) yi=yi+boxysize
5515 if (zi.lt.0) zi=zi+boxzsize
5516 C xi=xi+xshift*boxxsize
5517 C yi=yi+yshift*boxysize
5518 C zi=zi+zshift*boxzsize
5519 do iint=1,nscp_gr(i)
5521 do j=iscpstart(i,iint),iscpend(i,iint)
5522 if (itype(j).eq.ntyp1) cycle
5523 itypj=iabs(itype(j))
5524 C Uncomment following three lines for SC-p interactions
5528 C Uncomment following three lines for Ca-p interactions
5533 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5534 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5535 C Condition for being inside the proper box
5536 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5537 c & (xj.lt.((-0.5d0)*boxxsize))) then
5541 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5542 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5543 cC Condition for being inside the proper box
5544 c if ((yj.gt.((0.5d0)*boxysize)).or.
5545 c & (yj.lt.((-0.5d0)*boxysize))) then
5549 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5550 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5551 C Condition for being inside the proper box
5552 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5553 c & (zj.lt.((-0.5d0)*boxzsize))) then
5556 if (xj.lt.0) xj=xj+boxxsize
5558 if (yj.lt.0) yj=yj+boxysize
5560 if (zj.lt.0) zj=zj+boxzsize
5561 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5569 xj=xj_safe+xshift*boxxsize
5570 yj=yj_safe+yshift*boxysize
5571 zj=zj_safe+zshift*boxzsize
5572 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5573 if(dist_temp.lt.dist_init) then
5583 if (subchap.eq.1) then
5596 rij=xj*xj+yj*yj+zj*zj
5600 if (rij.lt.r0ijsq) then
5601 evdwij=0.25d0*(rij-r0ijsq)**2
5609 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5614 cgrad if (j.lt.i) then
5615 cd write (iout,*) 'j<i'
5616 C Uncomment following three lines for SC-p interactions
5618 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5621 cd write (iout,*) 'j>i'
5623 cgrad ggg(k)=-ggg(k)
5624 C Uncomment following line for SC-p interactions
5625 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5629 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5631 cgrad kstart=min0(i+1,j)
5632 cgrad kend=max0(i-1,j-1)
5633 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5634 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5635 cgrad do k=kstart,kend
5637 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5641 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5642 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5653 C-----------------------------------------------------------------------------
5654 subroutine escp(evdw2,evdw2_14)
5656 C This subroutine calculates the excluded-volume interaction energy between
5657 C peptide-group centers and side chains and its gradient in virtual-bond and
5658 C side-chain vectors.
5661 include 'DIMENSIONS'
5662 include 'COMMON.GEO'
5663 include 'COMMON.VAR'
5664 include 'COMMON.LOCAL'
5665 include 'COMMON.CHAIN'
5666 include 'COMMON.DERIV'
5667 include 'COMMON.INTERACT'
5668 include 'COMMON.FFIELD'
5669 include 'COMMON.IOUNITS'
5670 include 'COMMON.CONTROL'
5671 include 'COMMON.SPLITELE'
5672 integer xshift,yshift,zshift
5676 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5677 cd print '(a)','Enter ESCP'
5678 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5682 if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5683 do i=iatscp_s,iatscp_e
5684 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5686 xi=0.5D0*(c(1,i)+c(1,i+1))
5687 yi=0.5D0*(c(2,i)+c(2,i+1))
5688 zi=0.5D0*(c(3,i)+c(3,i+1))
5690 if (xi.lt.0) xi=xi+boxxsize
5692 if (yi.lt.0) yi=yi+boxysize
5694 if (zi.lt.0) zi=zi+boxzsize
5695 c xi=xi+xshift*boxxsize
5696 c yi=yi+yshift*boxysize
5697 c zi=zi+zshift*boxzsize
5698 c print *,xi,yi,zi,'polozenie i'
5699 C Return atom into box, boxxsize is size of box in x dimension
5701 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5702 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5703 C Condition for being inside the proper box
5704 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5705 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5709 c print *,xi,boxxsize,"pierwszy"
5711 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5712 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5713 C Condition for being inside the proper box
5714 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5715 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5719 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5720 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5721 C Condition for being inside the proper box
5722 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5723 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5726 do iint=1,nscp_gr(i)
5728 do j=iscpstart(i,iint),iscpend(i,iint)
5729 itypj=iabs(itype(j))
5730 if (itypj.eq.ntyp1) cycle
5731 C Uncomment following three lines for SC-p interactions
5735 C Uncomment following three lines for Ca-p interactions
5740 if (xj.lt.0) xj=xj+boxxsize
5742 if (yj.lt.0) yj=yj+boxysize
5744 if (zj.lt.0) zj=zj+boxzsize
5746 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5747 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5748 C Condition for being inside the proper box
5749 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5750 c & (xj.lt.((-0.5d0)*boxxsize))) then
5754 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5755 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5756 cC Condition for being inside the proper box
5757 c if ((yj.gt.((0.5d0)*boxysize)).or.
5758 c & (yj.lt.((-0.5d0)*boxysize))) then
5762 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5763 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5764 C Condition for being inside the proper box
5765 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5766 c & (zj.lt.((-0.5d0)*boxzsize))) then
5769 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5770 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5778 xj=xj_safe+xshift*boxxsize
5779 yj=yj_safe+yshift*boxysize
5780 zj=zj_safe+zshift*boxzsize
5781 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5782 if(dist_temp.lt.dist_init) then
5792 if (subchap.eq.1) then
5801 c print *,xj,yj,zj,'polozenie j'
5802 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5804 sss=sscale(1.0d0/(dsqrt(rrij)))
5805 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5806 c if (sss.eq.0) print *,'czasem jest OK'
5807 if (sss.le.0.0d0) cycle
5808 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5810 e1=fac*fac*aad(itypj,iteli)
5811 e2=fac*bad(itypj,iteli)
5812 if (iabs(j-i) .le. 2) then
5815 evdw2_14=evdw2_14+(e1+e2)*sss
5818 evdw2=evdw2+evdwij*sss
5819 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5820 & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5823 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5825 fac=-(evdwij+e1)*rrij*sss
5826 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5830 cgrad if (j.lt.i) then
5831 cd write (iout,*) 'j<i'
5832 C Uncomment following three lines for SC-p interactions
5834 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5837 cd write (iout,*) 'j>i'
5839 cgrad ggg(k)=-ggg(k)
5840 C Uncomment following line for SC-p interactions
5841 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5842 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5846 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5848 cgrad kstart=min0(i+1,j)
5849 cgrad kend=max0(i-1,j-1)
5850 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5851 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5852 cgrad do k=kstart,kend
5854 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5858 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5859 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5861 c endif !endif for sscale cutoff
5871 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5872 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5873 gradx_scp(j,i)=expon*gradx_scp(j,i)
5876 C******************************************************************************
5880 C To save time the factor EXPON has been extracted from ALL components
5881 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5884 C******************************************************************************
5887 C--------------------------------------------------------------------------
5888 subroutine edis(ehpb)
5890 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5893 include 'DIMENSIONS'
5894 include 'COMMON.SBRIDGE'
5895 include 'COMMON.CHAIN'
5896 include 'COMMON.DERIV'
5897 include 'COMMON.VAR'
5898 include 'COMMON.INTERACT'
5899 include 'COMMON.IOUNITS'
5900 include 'COMMON.CONTROL'
5901 dimension ggg(3),ggg_peak(3,1000)
5906 c 8/21/18 AL: added explicit restraints on reference coords
5907 c write (iout,*) "restr_on_coord",restr_on_coord
5908 if (restr_on_coord) then
5912 if (itype(i).eq.ntyp1) cycle
5914 ecoor=ecoor+(c(j,i)-cref(j,i))**2
5915 ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5917 if (itype(i).ne.10) then
5919 ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5920 ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5923 if (energy_dec) write (iout,*)
5924 & "i",i," bfac",bfac(i)," ecoor",ecoor
5925 ehpb=ehpb+0.5d0*bfac(i)*ecoor
5929 C write (iout,*) ,"link_end",link_end,constr_dist
5930 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5931 c write(iout,*)'link_start=',link_start,' link_end=',link_end,
5932 c & " constr_dist",constr_dist," link_start_peak",link_start_peak,
5933 c & " link_end_peak",link_end_peak
5934 if (link_end.eq.0.and.link_end_peak.eq.0) return
5935 do i=link_start_peak,link_end_peak
5937 c print *,"i",i," link_end_peak",link_end_peak," ipeak",
5938 c & ipeak(1,i),ipeak(2,i)
5939 do ip=ipeak(1,i),ipeak(2,i)
5944 C iii and jjj point to the residues for which the distance is assigned.
5945 c if (ii.gt.nres) then
5952 if (ii.gt.nres) then
5957 if (jj.gt.nres) then
5962 aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5963 aux=dexp(-scal_peak*aux)
5964 ehpb_peak=ehpb_peak+aux
5965 fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5966 & forcon_peak(ip))*aux/dd
5968 ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5970 if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5971 & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5972 & forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5974 c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5975 ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5976 do ip=ipeak(1,i),ipeak(2,i)
5979 ggg(j)=ggg_peak(j,iip)/ehpb_peak
5983 C iii and jjj point to the residues for which the distance is assigned.
5984 c if (ii.gt.nres) then
5991 if (ii.gt.nres) then
5996 if (jj.gt.nres) then
6003 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6008 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6012 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6013 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6017 do i=link_start,link_end
6018 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6019 C CA-CA distance used in regularization of structure.
6022 C iii and jjj point to the residues for which the distance is assigned.
6023 if (ii.gt.nres) then
6028 if (jj.gt.nres) then
6033 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6034 c & dhpb(i),dhpb1(i),forcon(i)
6035 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6036 C distance and angle dependent SS bond potential.
6037 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6038 C & iabs(itype(jjj)).eq.1) then
6039 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6040 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6041 if (.not.dyn_ss .and. i.le.nss) then
6042 C 15/02/13 CC dynamic SSbond - additional check
6043 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6044 & iabs(itype(jjj)).eq.1) then
6045 call ssbond_ene(iii,jjj,eij)
6048 cd write (iout,*) "eij",eij
6049 cd & ' waga=',waga,' fac=',fac
6050 ! else if (ii.gt.nres .and. jj.gt.nres) then
6052 C Calculate the distance between the two points and its difference from the
6055 if (irestr_type(i).eq.11) then
6056 ehpb=ehpb+fordepth(i)!**4.0d0
6057 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6058 fac=fordepth(i)!**4.0d0
6059 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6060 if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6061 & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6062 & ehpb,irestr_type(i)
6063 else if (irestr_type(i).eq.10) then
6064 c AL 6//19/2018 cross-link restraints
6065 xdis = 0.5d0*(dd/forcon(i))**2
6066 expdis = dexp(-xdis)
6067 c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6068 aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6069 c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6070 c & " wboltzd",wboltzd
6071 ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6072 c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6073 fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6074 & *expdis/(aux*forcon(i)**2)
6075 if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6076 & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6077 & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6078 else if (irestr_type(i).eq.2) then
6079 c Quartic restraints
6080 ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6081 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6082 & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6083 & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6084 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6086 c Quadratic restraints
6088 C Get the force constant corresponding to this distance.
6090 C Calculate the contribution to energy.
6091 ehpb=ehpb+0.5d0*waga*rdis*rdis
6092 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6093 & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6094 & 0.5d0*waga*rdis*rdis,irestr_type(i)
6096 C Evaluate gradient.
6100 c Calculate Cartesian gradient
6102 ggg(j)=fac*(c(j,jj)-c(j,ii))
6104 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6105 C If this is a SC-SC distance, we need to calculate the contributions to the
6106 C Cartesian gradient in the SC vectors (ghpbx).
6109 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6114 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6118 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6119 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6125 C--------------------------------------------------------------------------
6126 subroutine ssbond_ene(i,j,eij)
6128 C Calculate the distance and angle dependent SS-bond potential energy
6129 C using a free-energy function derived based on RHF/6-31G** ab initio
6130 C calculations of diethyl disulfide.
6132 C A. Liwo and U. Kozlowska, 11/24/03
6135 include 'DIMENSIONS'
6136 include 'COMMON.SBRIDGE'
6137 include 'COMMON.CHAIN'
6138 include 'COMMON.DERIV'
6139 include 'COMMON.LOCAL'
6140 include 'COMMON.INTERACT'
6141 include 'COMMON.VAR'
6142 include 'COMMON.IOUNITS'
6143 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6144 itypi=iabs(itype(i))
6148 dxi=dc_norm(1,nres+i)
6149 dyi=dc_norm(2,nres+i)
6150 dzi=dc_norm(3,nres+i)
6151 c dsci_inv=dsc_inv(itypi)
6152 dsci_inv=vbld_inv(nres+i)
6153 itypj=iabs(itype(j))
6154 c dscj_inv=dsc_inv(itypj)
6155 dscj_inv=vbld_inv(nres+j)
6159 dxj=dc_norm(1,nres+j)
6160 dyj=dc_norm(2,nres+j)
6161 dzj=dc_norm(3,nres+j)
6162 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6167 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6168 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6169 om12=dxi*dxj+dyi*dyj+dzi*dzj
6171 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6172 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6178 deltat12=om2-om1+2.0d0
6180 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6181 & +akct*deltad*deltat12
6182 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6183 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6184 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6185 c & " deltat12",deltat12," eij",eij
6186 ed=2*akcm*deltad+akct*deltat12
6188 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6189 eom1=-2*akth*deltat1-pom1-om2*pom2
6190 eom2= 2*akth*deltat2+pom1-om1*pom2
6193 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6194 ghpbx(k,i)=ghpbx(k,i)-ggk
6195 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6196 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6197 ghpbx(k,j)=ghpbx(k,j)+ggk
6198 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6199 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6200 ghpbc(k,i)=ghpbc(k,i)-ggk
6201 ghpbc(k,j)=ghpbc(k,j)+ggk
6204 C Calculate the components of the gradient in DC and X
6208 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
6213 C--------------------------------------------------------------------------
6214 subroutine ebond(estr)
6216 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6219 include 'DIMENSIONS'
6220 include 'COMMON.LOCAL'
6221 include 'COMMON.GEO'
6222 include 'COMMON.INTERACT'
6223 include 'COMMON.DERIV'
6224 include 'COMMON.VAR'
6225 include 'COMMON.CHAIN'
6226 include 'COMMON.IOUNITS'
6227 include 'COMMON.NAMES'
6228 include 'COMMON.FFIELD'
6229 include 'COMMON.CONTROL'
6230 include 'COMMON.SETUP'
6231 double precision u(3),ud(3)
6234 do i=ibondp_start,ibondp_end
6235 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6236 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6238 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6239 c & *dc(j,i-1)/vbld(i)
6241 c if (energy_dec) write(iout,*)
6242 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6244 C Checking if it involves dummy (NH3+ or COO-) group
6245 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6246 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
6247 diff = vbld(i)-vbldpDUM
6248 if (energy_dec) write(iout,*) "dum_bond",i,diff
6250 C NO vbldp0 is the equlibrium lenght of spring for peptide group
6251 diff = vbld(i)-vbldp0
6253 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6254 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6257 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6259 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6263 estr=0.5d0*AKP*estr+estr1
6265 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6267 do i=ibond_start,ibond_end
6269 if (iti.ne.10 .and. iti.ne.ntyp1) then
6272 diff=vbld(i+nres)-vbldsc0(1,iti)
6273 if (energy_dec) write (iout,*)
6274 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6275 & AKSC(1,iti),AKSC(1,iti)*diff*diff
6276 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6278 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6282 diff=vbld(i+nres)-vbldsc0(j,iti)
6283 ud(j)=aksc(j,iti)*diff
6284 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6298 uprod2=uprod2*u(k)*u(k)
6302 usumsqder=usumsqder+ud(j)*uprod2
6304 estr=estr+uprod/usum
6306 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6314 C--------------------------------------------------------------------------
6315 subroutine ebend(etheta)
6317 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6318 C angles gamma and its derivatives in consecutive thetas and gammas.
6320 implicit real*8 (a-h,o-z)
6321 include 'DIMENSIONS'
6322 include 'COMMON.LOCAL'
6323 include 'COMMON.GEO'
6324 include 'COMMON.INTERACT'
6325 include 'COMMON.DERIV'
6326 include 'COMMON.VAR'
6327 include 'COMMON.CHAIN'
6328 include 'COMMON.IOUNITS'
6329 include 'COMMON.NAMES'
6330 include 'COMMON.FFIELD'
6331 include 'COMMON.CONTROL'
6332 include 'COMMON.TORCNSTR'
6333 common /calcthet/ term1,term2,termm,diffak,ratak,
6334 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6335 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6336 double precision y(2),z(2)
6338 c time11=dexp(-2*time)
6341 c write (*,'(a,i2)') 'EBEND ICG=',icg
6342 do i=ithet_start,ithet_end
6343 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6344 & .or.itype(i).eq.ntyp1) cycle
6345 C Zero the energy function and its derivative at 0 or pi.
6346 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6348 ichir1=isign(1,itype(i-2))
6349 ichir2=isign(1,itype(i))
6350 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6351 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6352 if (itype(i-1).eq.10) then
6353 itype1=isign(10,itype(i-2))
6354 ichir11=isign(1,itype(i-2))
6355 ichir12=isign(1,itype(i-2))
6356 itype2=isign(10,itype(i))
6357 ichir21=isign(1,itype(i))
6358 ichir22=isign(1,itype(i))
6361 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6364 if (phii.ne.phii) phii=150.0
6374 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6377 if (phii1.ne.phii1) phii1=150.0
6389 C Calculate the "mean" value of theta from the part of the distribution
6390 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6391 C In following comments this theta will be referred to as t_c.
6392 thet_pred_mean=0.0d0
6394 athetk=athet(k,it,ichir1,ichir2)
6395 bthetk=bthet(k,it,ichir1,ichir2)
6397 athetk=athet(k,itype1,ichir11,ichir12)
6398 bthetk=bthet(k,itype2,ichir21,ichir22)
6400 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6401 c write(iout,*) 'chuj tu', y(k),z(k)
6403 dthett=thet_pred_mean*ssd
6404 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6405 C Derivatives of the "mean" values in gamma1 and gamma2.
6406 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6407 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6408 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6409 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6411 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6412 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6413 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6414 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6416 if (theta(i).gt.pi-delta) then
6417 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6419 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6420 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6421 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6423 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6425 else if (theta(i).lt.delta) then
6426 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6427 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6428 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6430 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6431 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6434 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6437 etheta=etheta+ethetai
6438 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6439 & 'ebend',i,ethetai,theta(i),itype(i)
6440 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6441 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6442 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6445 C Ufff.... We've done all this!!!
6448 C---------------------------------------------------------------------------
6449 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6451 implicit real*8 (a-h,o-z)
6452 include 'DIMENSIONS'
6453 include 'COMMON.LOCAL'
6454 include 'COMMON.IOUNITS'
6455 common /calcthet/ term1,term2,termm,diffak,ratak,
6456 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6457 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6458 C Calculate the contributions to both Gaussian lobes.
6459 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6460 C The "polynomial part" of the "standard deviation" of this part of
6461 C the distributioni.
6462 ccc write (iout,*) thetai,thet_pred_mean
6465 sig=sig*thet_pred_mean+polthet(j,it)
6467 C Derivative of the "interior part" of the "standard deviation of the"
6468 C gamma-dependent Gaussian lobe in t_c.
6469 sigtc=3*polthet(3,it)
6471 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6474 C Set the parameters of both Gaussian lobes of the distribution.
6475 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6476 fac=sig*sig+sigc0(it)
6479 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6480 sigsqtc=-4.0D0*sigcsq*sigtc
6481 c print *,i,sig,sigtc,sigsqtc
6482 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6483 sigtc=-sigtc/(fac*fac)
6484 C Following variable is sigma(t_c)**(-2)
6485 sigcsq=sigcsq*sigcsq
6487 sig0inv=1.0D0/sig0i**2
6488 delthec=thetai-thet_pred_mean
6489 delthe0=thetai-theta0i
6490 term1=-0.5D0*sigcsq*delthec*delthec
6491 term2=-0.5D0*sig0inv*delthe0*delthe0
6492 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6493 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6494 C NaNs in taking the logarithm. We extract the largest exponent which is added
6495 C to the energy (this being the log of the distribution) at the end of energy
6496 C term evaluation for this virtual-bond angle.
6497 if (term1.gt.term2) then
6499 term2=dexp(term2-termm)
6503 term1=dexp(term1-termm)
6506 C The ratio between the gamma-independent and gamma-dependent lobes of
6507 C the distribution is a Gaussian function of thet_pred_mean too.
6508 diffak=gthet(2,it)-thet_pred_mean
6509 ratak=diffak/gthet(3,it)**2
6510 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6511 C Let's differentiate it in thet_pred_mean NOW.
6513 C Now put together the distribution terms to make complete distribution.
6514 termexp=term1+ak*term2
6515 termpre=sigc+ak*sig0i
6516 C Contribution of the bending energy from this theta is just the -log of
6517 C the sum of the contributions from the two lobes and the pre-exponential
6518 C factor. Simple enough, isn't it?
6519 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6520 C write (iout,*) 'termexp',termexp,termm,termpre,i
6521 C NOW the derivatives!!!
6522 C 6/6/97 Take into account the deformation.
6523 E_theta=(delthec*sigcsq*term1
6524 & +ak*delthe0*sig0inv*term2)/termexp
6525 E_tc=((sigtc+aktc*sig0i)/termpre
6526 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6527 & aktc*term2)/termexp)
6530 c-----------------------------------------------------------------------------
6531 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6532 implicit real*8 (a-h,o-z)
6533 include 'DIMENSIONS'
6534 include 'COMMON.LOCAL'
6535 include 'COMMON.IOUNITS'
6536 common /calcthet/ term1,term2,termm,diffak,ratak,
6537 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6538 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6539 delthec=thetai-thet_pred_mean
6540 delthe0=thetai-theta0i
6541 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6542 t3 = thetai-thet_pred_mean
6546 t14 = t12+t6*sigsqtc
6548 t21 = thetai-theta0i
6554 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6555 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6556 & *(-t12*t9-ak*sig0inv*t27)
6560 C--------------------------------------------------------------------------
6561 subroutine ebend(etheta)
6563 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6564 C angles gamma and its derivatives in consecutive thetas and gammas.
6565 C ab initio-derived potentials from
6566 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6569 include 'DIMENSIONS'
6570 include 'COMMON.LOCAL'
6571 include 'COMMON.GEO'
6572 include 'COMMON.INTERACT'
6573 include 'COMMON.DERIV'
6574 include 'COMMON.VAR'
6575 include 'COMMON.CHAIN'
6576 include 'COMMON.IOUNITS'
6577 include 'COMMON.NAMES'
6578 include 'COMMON.FFIELD'
6579 include 'COMMON.CONTROL'
6580 include 'COMMON.TORCNSTR'
6581 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6582 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6583 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6584 & sinph1ph2(maxdouble,maxdouble)
6585 logical lprn /.false./, lprn1 /.false./
6587 do i=ithet_start,ithet_end
6588 c print *,i,itype(i-1),itype(i),itype(i-2)
6589 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6590 & .or.itype(i).eq.ntyp1) cycle
6591 C print *,i,theta(i)
6592 if (iabs(itype(i+1)).eq.20) iblock=2
6593 if (iabs(itype(i+1)).ne.20) iblock=1
6597 theti2=0.5d0*theta(i)
6598 ityp2=ithetyp((itype(i-1)))
6600 coskt(k)=dcos(k*theti2)
6601 sinkt(k)=dsin(k*theti2)
6604 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6607 if (phii.ne.phii) phii=150.0
6611 ityp1=ithetyp((itype(i-2)))
6612 C propagation of chirality for glycine type
6614 cosph1(k)=dcos(k*phii)
6615 sinph1(k)=dsin(k*phii)
6620 ityp1=ithetyp((itype(i-2)))
6625 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6628 if (phii1.ne.phii1) phii1=150.0
6633 ityp3=ithetyp((itype(i)))
6635 cosph2(k)=dcos(k*phii1)
6636 sinph2(k)=dsin(k*phii1)
6640 ityp3=ithetyp((itype(i)))
6646 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6649 ccl=cosph1(l)*cosph2(k-l)
6650 ssl=sinph1(l)*sinph2(k-l)
6651 scl=sinph1(l)*cosph2(k-l)
6652 csl=cosph1(l)*sinph2(k-l)
6653 cosph1ph2(l,k)=ccl-ssl
6654 cosph1ph2(k,l)=ccl+ssl
6655 sinph1ph2(l,k)=scl+csl
6656 sinph1ph2(k,l)=scl-csl
6660 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6661 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6662 write (iout,*) "coskt and sinkt"
6664 write (iout,*) k,coskt(k),sinkt(k)
6668 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6669 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6672 & write (iout,*) "k",k,"
6673 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6674 & " ethetai",ethetai
6677 write (iout,*) "cosph and sinph"
6679 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6681 write (iout,*) "cosph1ph2 and sinph2ph2"
6684 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6685 & sinph1ph2(l,k),sinph1ph2(k,l)
6688 write(iout,*) "ethetai",ethetai
6693 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6694 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6695 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6696 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6697 ethetai=ethetai+sinkt(m)*aux
6698 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6699 dephii=dephii+k*sinkt(m)*(
6700 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6701 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6702 dephii1=dephii1+k*sinkt(m)*(
6703 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6704 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6706 & write (iout,*) "m",m," k",k," bbthet",
6707 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6708 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6709 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6710 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6711 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6714 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6715 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6716 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6717 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6719 & write(iout,*) "ethetai",ethetai
6720 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6724 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6725 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6726 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6727 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6728 ethetai=ethetai+sinkt(m)*aux
6729 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6730 dephii=dephii+l*sinkt(m)*(
6731 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6732 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6733 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6734 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6735 dephii1=dephii1+(k-l)*sinkt(m)*(
6736 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6737 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6738 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6739 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6741 write (iout,*) "m",m," k",k," l",l," ffthet",
6742 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6743 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6744 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6745 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6746 & " ethetai",ethetai
6747 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6748 & cosph1ph2(k,l)*sinkt(m),
6749 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6758 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6759 & i,theta(i)*rad2deg,phii*rad2deg,
6760 & phii1*rad2deg,ethetai
6762 etheta=etheta+ethetai
6763 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6764 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6765 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6772 c-----------------------------------------------------------------------------
6773 subroutine esc(escloc)
6774 C Calculate the local energy of a side chain and its derivatives in the
6775 C corresponding virtual-bond valence angles THETA and the spherical angles
6777 implicit real*8 (a-h,o-z)
6778 include 'DIMENSIONS'
6779 include 'COMMON.GEO'
6780 include 'COMMON.LOCAL'
6781 include 'COMMON.VAR'
6782 include 'COMMON.INTERACT'
6783 include 'COMMON.DERIV'
6784 include 'COMMON.CHAIN'
6785 include 'COMMON.IOUNITS'
6786 include 'COMMON.NAMES'
6787 include 'COMMON.FFIELD'
6788 include 'COMMON.CONTROL'
6789 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6790 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6791 common /sccalc/ time11,time12,time112,theti,it,nlobit
6794 c write (iout,'(a)') 'ESC'
6795 do i=loc_start,loc_end
6797 if (it.eq.ntyp1) cycle
6798 if (it.eq.10) goto 1
6799 nlobit=nlob(iabs(it))
6800 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6801 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6802 theti=theta(i+1)-pipol
6807 if (x(2).gt.pi-delta) then
6811 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6813 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6814 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6816 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6817 & ddersc0(1),dersc(1))
6818 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6819 & ddersc0(3),dersc(3))
6821 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6823 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6824 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6825 & dersc0(2),esclocbi,dersc02)
6826 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6828 call splinthet(x(2),0.5d0*delta,ss,ssd)
6833 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6835 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6836 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6838 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6840 c write (iout,*) escloci
6841 else if (x(2).lt.delta) then
6845 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6847 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6848 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6850 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6851 & ddersc0(1),dersc(1))
6852 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6853 & ddersc0(3),dersc(3))
6855 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6857 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6858 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6859 & dersc0(2),esclocbi,dersc02)
6860 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6865 call splinthet(x(2),0.5d0*delta,ss,ssd)
6867 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6869 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6870 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6872 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6873 c write (iout,*) escloci
6875 call enesc(x,escloci,dersc,ddummy,.false.)
6878 escloc=escloc+escloci
6879 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6880 & 'escloc',i,escloci
6881 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6883 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6885 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6886 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6891 C---------------------------------------------------------------------------
6892 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6893 implicit real*8 (a-h,o-z)
6894 include 'DIMENSIONS'
6895 include 'COMMON.GEO'
6896 include 'COMMON.LOCAL'
6897 include 'COMMON.IOUNITS'
6898 common /sccalc/ time11,time12,time112,theti,it,nlobit
6899 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6900 double precision contr(maxlob,-1:1)
6902 c write (iout,*) 'it=',it,' nlobit=',nlobit
6906 if (mixed) ddersc(j)=0.0d0
6910 C Because of periodicity of the dependence of the SC energy in omega we have
6911 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6912 C To avoid underflows, first compute & store the exponents.
6920 z(k)=x(k)-censc(k,j,it)
6925 Axk=Axk+gaussc(l,k,j,it)*z(l)
6931 expfac=expfac+Ax(k,j,iii)*z(k)
6939 C As in the case of ebend, we want to avoid underflows in exponentiation and
6940 C subsequent NaNs and INFs in energy calculation.
6941 C Find the largest exponent
6945 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6949 cd print *,'it=',it,' emin=',emin
6951 C Compute the contribution to SC energy and derivatives
6956 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6957 if(adexp.ne.adexp) adexp=1.0
6960 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6962 cd print *,'j=',j,' expfac=',expfac
6963 escloc_i=escloc_i+expfac
6965 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6969 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6970 & +gaussc(k,2,j,it))*expfac
6977 dersc(1)=dersc(1)/cos(theti)**2
6978 ddersc(1)=ddersc(1)/cos(theti)**2
6981 escloci=-(dlog(escloc_i)-emin)
6983 dersc(j)=dersc(j)/escloc_i
6987 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6992 C------------------------------------------------------------------------------
6993 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6994 implicit real*8 (a-h,o-z)
6995 include 'DIMENSIONS'
6996 include 'COMMON.GEO'
6997 include 'COMMON.LOCAL'
6998 include 'COMMON.IOUNITS'
6999 common /sccalc/ time11,time12,time112,theti,it,nlobit
7000 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7001 double precision contr(maxlob)
7012 z(k)=x(k)-censc(k,j,it)
7018 Axk=Axk+gaussc(l,k,j,it)*z(l)
7024 expfac=expfac+Ax(k,j)*z(k)
7029 C As in the case of ebend, we want to avoid underflows in exponentiation and
7030 C subsequent NaNs and INFs in energy calculation.
7031 C Find the largest exponent
7034 if (emin.gt.contr(j)) emin=contr(j)
7038 C Compute the contribution to SC energy and derivatives
7042 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7043 escloc_i=escloc_i+expfac
7045 dersc(k)=dersc(k)+Ax(k,j)*expfac
7047 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7048 & +gaussc(1,2,j,it))*expfac
7052 dersc(1)=dersc(1)/cos(theti)**2
7053 dersc12=dersc12/cos(theti)**2
7054 escloci=-(dlog(escloc_i)-emin)
7056 dersc(j)=dersc(j)/escloc_i
7058 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7062 c----------------------------------------------------------------------------------
7063 subroutine esc(escloc)
7064 C Calculate the local energy of a side chain and its derivatives in the
7065 C corresponding virtual-bond valence angles THETA and the spherical angles
7066 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7067 C added by Urszula Kozlowska. 07/11/2007
7070 include 'DIMENSIONS'
7071 include 'COMMON.GEO'
7072 include 'COMMON.LOCAL'
7073 include 'COMMON.VAR'
7074 include 'COMMON.SCROT'
7075 include 'COMMON.INTERACT'
7076 include 'COMMON.DERIV'
7077 include 'COMMON.CHAIN'
7078 include 'COMMON.IOUNITS'
7079 include 'COMMON.NAMES'
7080 include 'COMMON.FFIELD'
7081 include 'COMMON.CONTROL'
7082 include 'COMMON.VECTORS'
7083 double precision x_prime(3),y_prime(3),z_prime(3)
7084 & , sumene,dsc_i,dp2_i,x(65),
7085 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7086 & de_dxx,de_dyy,de_dzz,de_dt
7087 double precision s1_t,s1_6_t,s2_t,s2_6_t
7089 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7090 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7091 & dt_dCi(3),dt_dCi1(3)
7092 common /sccalc/ time11,time12,time112,theti,it,nlobit
7095 do i=loc_start,loc_end
7096 if (itype(i).eq.ntyp1) cycle
7097 costtab(i+1) =dcos(theta(i+1))
7098 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7099 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7100 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7101 cosfac2=0.5d0/(1.0d0+costtab(i+1))
7102 cosfac=dsqrt(cosfac2)
7103 sinfac2=0.5d0/(1.0d0-costtab(i+1))
7104 sinfac=dsqrt(sinfac2)
7106 if (it.eq.10) goto 1
7108 C Compute the axes of tghe local cartesian coordinates system; store in
7109 c x_prime, y_prime and z_prime
7116 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7117 C & dc_norm(3,i+nres)
7119 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7120 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7123 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7126 c write (2,*) "x_prime",(x_prime(j),j=1,3)
7127 c write (2,*) "y_prime",(y_prime(j),j=1,3)
7128 c write (2,*) "z_prime",(z_prime(j),j=1,3)
7129 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7130 c & " xy",scalar(x_prime(1),y_prime(1)),
7131 c & " xz",scalar(x_prime(1),z_prime(1)),
7132 c & " yy",scalar(y_prime(1),y_prime(1)),
7133 c & " yz",scalar(y_prime(1),z_prime(1)),
7134 c & " zz",scalar(z_prime(1),z_prime(1))
7136 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7137 C to local coordinate system. Store in xx, yy, zz.
7143 xx = xx + x_prime(j)*dc_norm(j,i+nres)
7144 yy = yy + y_prime(j)*dc_norm(j,i+nres)
7145 zz = zz + z_prime(j)*dc_norm(j,i+nres)
7152 C Compute the energy of the ith side cbain
7154 c write (2,*) "xx",xx," yy",yy," zz",zz
7157 x(j) = sc_parmin(j,it)
7160 Cc diagnostics - remove later
7162 yy1 = dsin(alph(2))*dcos(omeg(2))
7163 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7164 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7165 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7167 C," --- ", xx_w,yy_w,zz_w
7170 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7171 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7173 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7174 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7176 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7177 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7178 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7179 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7180 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7182 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7183 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7184 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7185 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7186 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7188 dsc_i = 0.743d0+x(61)
7190 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7191 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7192 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7193 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7194 s1=(1+x(63))/(0.1d0 + dscp1)
7195 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7196 s2=(1+x(65))/(0.1d0 + dscp2)
7197 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7198 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7199 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7200 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7202 c & dscp1,dscp2,sumene
7203 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7204 escloc = escloc + sumene
7205 c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7210 C This section to check the numerical derivatives of the energy of ith side
7211 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7212 C #define DEBUG in the code to turn it on.
7214 write (2,*) "sumene =",sumene
7218 write (2,*) xx,yy,zz
7219 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7220 de_dxx_num=(sumenep-sumene)/aincr
7222 write (2,*) "xx+ sumene from enesc=",sumenep
7225 write (2,*) xx,yy,zz
7226 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7227 de_dyy_num=(sumenep-sumene)/aincr
7229 write (2,*) "yy+ sumene from enesc=",sumenep
7232 write (2,*) xx,yy,zz
7233 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7234 de_dzz_num=(sumenep-sumene)/aincr
7236 write (2,*) "zz+ sumene from enesc=",sumenep
7237 costsave=cost2tab(i+1)
7238 sintsave=sint2tab(i+1)
7239 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7240 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7241 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7242 de_dt_num=(sumenep-sumene)/aincr
7243 write (2,*) " t+ sumene from enesc=",sumenep
7244 cost2tab(i+1)=costsave
7245 sint2tab(i+1)=sintsave
7246 C End of diagnostics section.
7249 C Compute the gradient of esc
7251 c zz=zz*dsign(1.0,dfloat(itype(i)))
7252 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7253 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7254 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7255 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7256 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7257 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7258 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7259 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7260 pom1=(sumene3*sint2tab(i+1)+sumene1)
7261 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7262 pom2=(sumene4*cost2tab(i+1)+sumene2)
7263 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7264 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7265 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7266 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7268 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7269 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7270 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7272 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7273 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7274 & +(pom1+pom2)*pom_dx
7276 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7279 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7280 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7281 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7283 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7284 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7285 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7286 & +x(59)*zz**2 +x(60)*xx*zz
7287 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7288 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7289 & +(pom1-pom2)*pom_dy
7291 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7294 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7295 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7296 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7297 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7298 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7299 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7300 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7301 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7303 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7306 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7307 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7308 & +pom1*pom_dt1+pom2*pom_dt2
7310 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7315 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7316 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7317 cosfac2xx=cosfac2*xx
7318 sinfac2yy=sinfac2*yy
7320 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7322 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7324 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7325 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7326 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7327 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7328 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7329 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7330 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7331 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7332 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7333 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7337 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7338 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7339 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7340 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7343 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7344 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7345 dZZ_XYZ(k)=vbld_inv(i+nres)*
7346 & (z_prime(k)-zz*dC_norm(k,i+nres))
7348 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7349 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7353 dXX_Ctab(k,i)=dXX_Ci(k)
7354 dXX_C1tab(k,i)=dXX_Ci1(k)
7355 dYY_Ctab(k,i)=dYY_Ci(k)
7356 dYY_C1tab(k,i)=dYY_Ci1(k)
7357 dZZ_Ctab(k,i)=dZZ_Ci(k)
7358 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7359 dXX_XYZtab(k,i)=dXX_XYZ(k)
7360 dYY_XYZtab(k,i)=dYY_XYZ(k)
7361 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7365 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7366 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7367 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7368 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7369 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7371 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7372 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7373 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7374 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7375 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7376 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7377 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7378 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7380 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7381 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7383 C to check gradient call subroutine check_grad
7389 c------------------------------------------------------------------------------
7390 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7392 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7393 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7394 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7395 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7397 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7398 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7400 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7401 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7402 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7403 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7404 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7406 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7407 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7408 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7409 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7410 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7412 dsc_i = 0.743d0+x(61)
7414 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7415 & *(xx*cost2+yy*sint2))
7416 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7417 & *(xx*cost2-yy*sint2))
7418 s1=(1+x(63))/(0.1d0 + dscp1)
7419 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7420 s2=(1+x(65))/(0.1d0 + dscp2)
7421 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7422 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7423 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7428 c------------------------------------------------------------------------------
7429 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7431 C This procedure calculates two-body contact function g(rij) and its derivative:
7434 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7437 C where x=(rij-r0ij)/delta
7439 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7442 double precision rij,r0ij,eps0ij,fcont,fprimcont
7443 double precision x,x2,x4,delta
7447 if (x.lt.-1.0D0) then
7450 else if (x.le.1.0D0) then
7453 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7454 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7461 c------------------------------------------------------------------------------
7462 subroutine splinthet(theti,delta,ss,ssder)
7463 implicit real*8 (a-h,o-z)
7464 include 'DIMENSIONS'
7465 include 'COMMON.VAR'
7466 include 'COMMON.GEO'
7469 if (theti.gt.pipol) then
7470 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7472 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7477 c------------------------------------------------------------------------------
7478 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7480 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7481 double precision ksi,ksi2,ksi3,a1,a2,a3
7482 a1=fprim0*delta/(f1-f0)
7488 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7489 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7492 c------------------------------------------------------------------------------
7493 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7495 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7496 double precision ksi,ksi2,ksi3,a1,a2,a3
7501 a2=3*(f1x-f0x)-2*fprim0x*delta
7502 a3=fprim0x*delta-2*(f1x-f0x)
7503 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7506 C-----------------------------------------------------------------------------
7508 C-----------------------------------------------------------------------------
7509 subroutine etor(etors)
7510 implicit real*8 (a-h,o-z)
7511 include 'DIMENSIONS'
7512 include 'COMMON.VAR'
7513 include 'COMMON.GEO'
7514 include 'COMMON.LOCAL'
7515 include 'COMMON.TORSION'
7516 include 'COMMON.INTERACT'
7517 include 'COMMON.DERIV'
7518 include 'COMMON.CHAIN'
7519 include 'COMMON.NAMES'
7520 include 'COMMON.IOUNITS'
7521 include 'COMMON.FFIELD'
7522 include 'COMMON.TORCNSTR'
7523 include 'COMMON.CONTROL'
7525 C Set lprn=.true. for debugging
7529 do i=iphi_start,iphi_end
7531 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7532 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7533 itori=itortyp(itype(i-2))
7534 itori1=itortyp(itype(i-1))
7537 C Proline-Proline pair is a special case...
7538 if (itori.eq.3 .and. itori1.eq.3) then
7539 if (phii.gt.-dwapi3) then
7541 fac=1.0D0/(1.0D0-cosphi)
7542 etorsi=v1(1,3,3)*fac
7543 etorsi=etorsi+etorsi
7544 etors=etors+etorsi-v1(1,3,3)
7545 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7546 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7549 v1ij=v1(j+1,itori,itori1)
7550 v2ij=v2(j+1,itori,itori1)
7553 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7554 if (energy_dec) etors_ii=etors_ii+
7555 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7556 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7560 v1ij=v1(j,itori,itori1)
7561 v2ij=v2(j,itori,itori1)
7564 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7565 if (energy_dec) etors_ii=etors_ii+
7566 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7567 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7570 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7573 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7574 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7575 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7576 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7577 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7581 c------------------------------------------------------------------------------
7582 subroutine etor_d(etors_d)
7586 c----------------------------------------------------------------------------
7587 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7588 subroutine e_modeller(ehomology_constr)
7589 ehomology_constr=0.0d0
7590 write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7593 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7595 c------------------------------------------------------------------------------
7596 subroutine etor_d(etors_d)
7600 c----------------------------------------------------------------------------
7602 subroutine etor(etors)
7604 include 'DIMENSIONS'
7605 include 'COMMON.VAR'
7606 include 'COMMON.GEO'
7607 include 'COMMON.LOCAL'
7608 include 'COMMON.TORSION'
7609 include 'COMMON.INTERACT'
7610 include 'COMMON.DERIV'
7611 include 'COMMON.CHAIN'
7612 include 'COMMON.NAMES'
7613 include 'COMMON.IOUNITS'
7614 include 'COMMON.FFIELD'
7615 include 'COMMON.TORCNSTR'
7616 include 'COMMON.CONTROL'
7618 C Set lprn=.true. for debugging
7622 do i=iphi_start,iphi_end
7623 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7624 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7625 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7626 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7627 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7628 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7629 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7630 C For introducing the NH3+ and COO- group please check the etor_d for reference
7633 if (iabs(itype(i)).eq.20) then
7638 itori=itortyp(itype(i-2))
7639 itori1=itortyp(itype(i-1))
7642 C Regular cosine and sine terms
7643 do j=1,nterm(itori,itori1,iblock)
7644 v1ij=v1(j,itori,itori1,iblock)
7645 v2ij=v2(j,itori,itori1,iblock)
7648 etors=etors+v1ij*cosphi+v2ij*sinphi
7649 if (energy_dec) etors_ii=etors_ii+
7650 & v1ij*cosphi+v2ij*sinphi
7651 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7655 C E = SUM ----------------------------------- - v1
7656 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7658 cosphi=dcos(0.5d0*phii)
7659 sinphi=dsin(0.5d0*phii)
7660 do j=1,nlor(itori,itori1,iblock)
7661 vl1ij=vlor1(j,itori,itori1)
7662 vl2ij=vlor2(j,itori,itori1)
7663 vl3ij=vlor3(j,itori,itori1)
7664 pom=vl2ij*cosphi+vl3ij*sinphi
7665 pom1=1.0d0/(pom*pom+1.0d0)
7666 etors=etors+vl1ij*pom1
7667 if (energy_dec) etors_ii=etors_ii+
7670 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7672 C Subtract the constant term
7673 etors=etors-v0(itori,itori1,iblock)
7674 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7675 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7677 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7678 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7679 & (v1(j,itori,itori1,iblock),j=1,6),
7680 & (v2(j,itori,itori1,iblock),j=1,6)
7681 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7682 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7686 c----------------------------------------------------------------------------
7687 subroutine etor_d(etors_d)
7688 C 6/23/01 Compute double torsional energy
7690 include 'DIMENSIONS'
7691 include 'COMMON.VAR'
7692 include 'COMMON.GEO'
7693 include 'COMMON.LOCAL'
7694 include 'COMMON.TORSION'
7695 include 'COMMON.INTERACT'
7696 include 'COMMON.DERIV'
7697 include 'COMMON.CHAIN'
7698 include 'COMMON.NAMES'
7699 include 'COMMON.IOUNITS'
7700 include 'COMMON.FFIELD'
7701 include 'COMMON.TORCNSTR'
7703 C Set lprn=.true. for debugging
7707 c write(iout,*) "a tu??"
7708 do i=iphid_start,iphid_end
7709 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7710 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7711 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7712 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7713 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7714 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7715 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7716 & (itype(i+1).eq.ntyp1)) cycle
7717 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7718 itori=itortyp(itype(i-2))
7719 itori1=itortyp(itype(i-1))
7720 itori2=itortyp(itype(i))
7726 if (iabs(itype(i+1)).eq.20) iblock=2
7727 C Iblock=2 Proline type
7728 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7729 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7730 C if (itype(i+1).eq.ntyp1) iblock=3
7731 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7732 C IS or IS NOT need for this
7733 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7734 C is (itype(i-3).eq.ntyp1) ntblock=2
7735 C ntblock is N-terminal blocking group
7737 C Regular cosine and sine terms
7738 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7739 C Example of changes for NH3+ blocking group
7740 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7741 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7742 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7743 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7744 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7745 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7746 cosphi1=dcos(j*phii)
7747 sinphi1=dsin(j*phii)
7748 cosphi2=dcos(j*phii1)
7749 sinphi2=dsin(j*phii1)
7750 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7751 & v2cij*cosphi2+v2sij*sinphi2
7752 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7753 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7755 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7757 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7758 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7759 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7760 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7761 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7762 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7763 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7764 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7765 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7766 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7767 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7768 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7769 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7770 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7773 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7774 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7779 C----------------------------------------------------------------------------------
7780 C The rigorous attempt to derive energy function
7781 subroutine etor_kcc(etors)
7783 include 'DIMENSIONS'
7784 include 'COMMON.VAR'
7785 include 'COMMON.GEO'
7786 include 'COMMON.LOCAL'
7787 include 'COMMON.TORSION'
7788 include 'COMMON.INTERACT'
7789 include 'COMMON.DERIV'
7790 include 'COMMON.CHAIN'
7791 include 'COMMON.NAMES'
7792 include 'COMMON.IOUNITS'
7793 include 'COMMON.FFIELD'
7794 include 'COMMON.TORCNSTR'
7795 include 'COMMON.CONTROL'
7796 double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7798 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7799 C Set lprn=.true. for debugging
7802 C print *,"wchodze kcc"
7803 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7805 do i=iphi_start,iphi_end
7806 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7807 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7808 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7809 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7810 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7811 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7812 itori=itortyp(itype(i-2))
7813 itori1=itortyp(itype(i-1))
7818 C to avoid multiple devision by 2
7819 c theti22=0.5d0*theta(i)
7820 C theta 12 is the theta_1 /2
7821 C theta 22 is theta_2 /2
7822 c theti12=0.5d0*theta(i-1)
7823 C and appropriate sinus function
7824 sinthet1=dsin(theta(i-1))
7825 sinthet2=dsin(theta(i))
7826 costhet1=dcos(theta(i-1))
7827 costhet2=dcos(theta(i))
7828 C to speed up lets store its mutliplication
7829 sint1t2=sinthet2*sinthet1
7831 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7832 C +d_n*sin(n*gamma)) *
7833 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7834 C we have two sum 1) Non-Chebyshev which is with n and gamma
7835 nval=nterm_kcc_Tb(itori,itori1)
7841 c1(j)=c1(j-1)*costhet1
7842 c2(j)=c2(j-1)*costhet2
7845 do j=1,nterm_kcc(itori,itori1)
7849 sint1t2n=sint1t2n*sint1t2
7855 sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7856 gradvalct1=gradvalct1+
7857 & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7858 gradvalct2=gradvalct2+
7859 & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7862 gradvalct1=-gradvalct1*sinthet1
7863 gradvalct2=-gradvalct2*sinthet2
7869 sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7870 gradvalst1=gradvalst1+
7871 & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7872 gradvalst2=gradvalst2+
7873 & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7876 gradvalst1=-gradvalst1*sinthet1
7877 gradvalst2=-gradvalst2*sinthet2
7878 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7879 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7880 C glocig is the gradient local i site in gamma
7881 glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7882 C now gradient over theta_1
7883 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7884 & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7885 glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7886 & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7889 C derivative over gamma
7890 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7891 C derivative over theta1
7892 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7893 C now derivative over theta2
7894 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7896 write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7897 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7898 write (iout,*) "c1",(c1(k),k=0,nval),
7899 & " c2",(c2(k),k=0,nval)
7904 c---------------------------------------------------------------------------------------------
7905 subroutine etor_constr(edihcnstr)
7907 include 'DIMENSIONS'
7908 include 'COMMON.VAR'
7909 include 'COMMON.GEO'
7910 include 'COMMON.LOCAL'
7911 include 'COMMON.TORSION'
7912 include 'COMMON.INTERACT'
7913 include 'COMMON.DERIV'
7914 include 'COMMON.CHAIN'
7915 include 'COMMON.NAMES'
7916 include 'COMMON.IOUNITS'
7917 include 'COMMON.FFIELD'
7918 include 'COMMON.TORCNSTR'
7919 include 'COMMON.BOUNDS'
7920 include 'COMMON.CONTROL'
7921 ! 6/20/98 - dihedral angle constraints
7923 c do i=1,ndih_constr
7924 if (raw_psipred) then
7925 do i=idihconstr_start,idihconstr_end
7926 itori=idih_constr(i)
7928 gaudih_i=vpsipred(1,i)
7932 cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7933 dexpcos_i=dexp(-cos_i*cos_i)
7934 gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7935 gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7936 & *cos_i*dexpcos_i/s**2
7938 edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7939 gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7941 & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7942 & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7943 & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7944 & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7945 & -wdihc*dlog(gaudih_i)
7949 do i=idihconstr_start,idihconstr_end
7950 itori=idih_constr(i)
7952 difi=pinorm(phii-phi0(i))
7953 if (difi.gt.drange(i)) then
7955 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7956 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7957 else if (difi.lt.-drange(i)) then
7959 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7960 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7970 c----------------------------------------------------------------------------
7971 c MODELLER restraint function
7972 subroutine e_modeller(ehomology_constr)
7974 include 'DIMENSIONS'
7976 integer nnn, i, j, k, ki, irec, l
7977 integer katy, odleglosci, test7
7978 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7980 real*8 distance(max_template),distancek(max_template),
7981 & min_odl,godl(max_template),dih_diff(max_template)
7984 c FP - 30/10/2014 Temporary specifications for homology restraints
7986 double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7988 double precision, dimension (maxres) :: guscdiff,usc_diff
7989 double precision, dimension (max_template) ::
7990 & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7994 include 'COMMON.SBRIDGE'
7995 include 'COMMON.CHAIN'
7996 include 'COMMON.GEO'
7997 include 'COMMON.DERIV'
7998 include 'COMMON.LOCAL'
7999 include 'COMMON.INTERACT'
8000 include 'COMMON.VAR'
8001 include 'COMMON.IOUNITS'
8003 include 'COMMON.CONTROL'
8004 include 'COMMON.HOMOLOGY'
8005 include 'COMMON.QRESTR'
8007 c From subroutine Econstr_back
8009 include 'COMMON.NAMES'
8010 include 'COMMON.TIME1'
8015 distancek(i)=9999999.9
8021 c Pseudo-energy and gradient from homology restraints (MODELLER-like
8023 C AL 5/2/14 - Introduce list of restraints
8024 c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
8026 write(iout,*) "------- dist restrs start -------"
8028 do ii = link_start_homo,link_end_homo
8032 c write (iout,*) "dij(",i,j,") =",dij
8034 do k=1,constr_homology
8035 c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
8036 if(.not.l_homo(k,ii)) then
8040 distance(k)=odl(k,ii)-dij
8041 c write (iout,*) "distance(",k,") =",distance(k)
8043 c For Gaussian-type Urestr
8045 distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
8046 c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
8047 c write (iout,*) "distancek(",k,") =",distancek(k)
8048 c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8050 c For Lorentzian-type Urestr
8052 if (waga_dist.lt.0.0d0) then
8053 sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8054 distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8055 & (distance(k)**2+sigma_odlir(k,ii)**2))
8059 c min_odl=minval(distancek)
8060 do kk=1,constr_homology
8061 if(l_homo(kk,ii)) then
8062 min_odl=distancek(kk)
8066 do kk=1,constr_homology
8067 if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8068 & min_odl=distancek(kk)
8071 c write (iout,* )"min_odl",min_odl
8073 write (iout,*) "ij dij",i,j,dij
8074 write (iout,*) "distance",(distance(k),k=1,constr_homology)
8075 write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8076 write (iout,* )"min_odl",min_odl
8081 if (waga_dist.ge.0.0d0) then
8087 do k=1,constr_homology
8088 c Nie wiem po co to liczycie jeszcze raz!
8089 c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8090 c & (2*(sigma_odl(i,j,k))**2))
8091 if(.not.l_homo(k,ii)) cycle
8092 if (waga_dist.ge.0.0d0) then
8094 c For Gaussian-type Urestr
8096 godl(k)=dexp(-distancek(k)+min_odl)
8097 odleg2=odleg2+godl(k)
8099 c For Lorentzian-type Urestr
8102 odleg2=odleg2+distancek(k)
8105 ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8106 ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8107 ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8108 ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8111 c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8112 c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8114 write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8115 write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8117 if (waga_dist.ge.0.0d0) then
8119 c For Gaussian-type Urestr
8121 odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8123 c For Lorentzian-type Urestr
8126 odleg=odleg+odleg2/constr_homology
8129 c write (iout,*) "odleg",odleg ! sum of -ln-s
8132 c For Gaussian-type Urestr
8134 if (waga_dist.ge.0.0d0) sum_godl=odleg2
8136 do k=1,constr_homology
8137 c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8138 c & *waga_dist)+min_odl
8139 c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8141 if(.not.l_homo(k,ii)) cycle
8142 if (waga_dist.ge.0.0d0) then
8143 c For Gaussian-type Urestr
8145 sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8147 c For Lorentzian-type Urestr
8150 sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8151 & sigma_odlir(k,ii)**2)**2)
8153 sum_sgodl=sum_sgodl+sgodl
8155 c sgodl2=sgodl2+sgodl
8156 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8157 c write(iout,*) "constr_homology=",constr_homology
8158 c write(iout,*) i, j, k, "TEST K"
8160 if (waga_dist.ge.0.0d0) then
8162 c For Gaussian-type Urestr
8164 grad_odl3=waga_homology(iset)*waga_dist
8165 & *sum_sgodl/(sum_godl*dij)
8167 c For Lorentzian-type Urestr
8170 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8171 c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8172 grad_odl3=-waga_homology(iset)*waga_dist*
8173 & sum_sgodl/(constr_homology*dij)
8176 c grad_odl3=sum_sgodl/(sum_godl*dij)
8179 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8180 c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8181 c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8183 ccc write(iout,*) godl, sgodl, grad_odl3
8185 c grad_odl=grad_odl+grad_odl3
8188 ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8189 ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8190 ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8191 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8192 ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8193 ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8194 ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8195 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8196 c if (i.eq.25.and.j.eq.27) then
8197 c write(iout,*) "jik",jik,"i",i,"j",j
8198 c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8199 c write(iout,*) "grad_odl3",grad_odl3
8200 c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8201 c write(iout,*) "ggodl",ggodl
8202 c write(iout,*) "ghpbc(",jik,i,")",
8203 c & ghpbc(jik,i),"ghpbc(",jik,j,")",
8207 ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8208 ccc & dLOG(odleg2),"-odleg=", -odleg
8210 enddo ! ii-loop for dist
8212 write(iout,*) "------- dist restrs end -------"
8213 c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8214 c & waga_d.eq.1.0d0) call sum_gradient
8216 c Pseudo-energy and gradient from dihedral-angle restraints from
8217 c homology templates
8218 c write (iout,*) "End of distance loop"
8221 c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8223 write(iout,*) "------- dih restrs start -------"
8224 do i=idihconstr_start_homo,idihconstr_end_homo
8225 write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8228 do i=idihconstr_start_homo,idihconstr_end_homo
8230 c betai=beta(i,i+1,i+2,i+3)
8232 c write (iout,*) "betai =",betai
8233 do k=1,constr_homology
8234 dih_diff(k)=pinorm(dih(k,i)-betai)
8235 cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8236 cd & ,sigma_dih(k,i)
8237 c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8238 c & -(6.28318-dih_diff(i,k))
8239 c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8240 c & 6.28318+dih_diff(i,k)
8242 kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8244 kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8246 c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8249 c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8252 c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8253 c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8255 write (iout,*) "i",i," betai",betai," kat2",kat2
8256 write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8258 if (kat2.le.1.0d-14) cycle
8259 kat=kat-dLOG(kat2/constr_homology)
8260 c write (iout,*) "kat",kat ! sum of -ln-s
8262 ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8263 ccc & dLOG(kat2), "-kat=", -kat
8265 c ----------------------------------------------------------------------
8267 c ----------------------------------------------------------------------
8271 do k=1,constr_homology
8273 sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
8275 sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd
8277 c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8278 sum_sgdih=sum_sgdih+sgdih
8280 c grad_dih3=sum_sgdih/sum_gdih
8281 grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8283 c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8284 ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8285 ccc & gloc(nphi+i-3,icg)
8286 gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8288 c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8290 ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8291 ccc & gloc(nphi+i-3,icg)
8293 enddo ! i-loop for dih
8295 write(iout,*) "------- dih restrs end -------"
8298 c Pseudo-energy and gradient for theta angle restraints from
8299 c homology templates
8300 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8304 c For constr_homology reference structures (FP)
8306 c Uconst_back_tot=0.0d0
8309 c Econstr_back legacy
8311 c do i=ithet_start,ithet_end
8314 c do i=loc_start,loc_end
8317 duscdiffx(j,i)=0.0d0
8322 c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8323 c write (iout,*) "waga_theta",waga_theta
8324 if (waga_theta.gt.0.0d0) then
8326 write (iout,*) "usampl",usampl
8327 write(iout,*) "------- theta restrs start -------"
8328 c do i=ithet_start,ithet_end
8329 c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8332 c write (iout,*) "maxres",maxres,"nres",nres
8334 do i=ithet_start,ithet_end
8337 c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8339 c Deviation of theta angles wrt constr_homology ref structures
8341 utheta_i=0.0d0 ! argument of Gaussian for single k
8342 gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8343 c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8344 c over residues in a fragment
8345 c write (iout,*) "theta(",i,")=",theta(i)
8346 do k=1,constr_homology
8348 c dtheta_i=theta(j)-thetaref(j,iref)
8349 c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8350 theta_diff(k)=thetatpl(k,i)-theta(i)
8351 cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8352 cd & ,sigma_theta(k,i)
8355 utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8356 c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8357 gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8358 gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk)
8359 c Gradient for single Gaussian restraint in subr Econstr_back
8360 c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8363 c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8364 c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8367 c Gradient for multiple Gaussian restraint
8368 sum_gtheta=gutheta_i
8370 do k=1,constr_homology
8371 c New generalized expr for multiple Gaussian from Econstr_back
8372 sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8374 c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8375 sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8377 c Final value of gradient using same var as in Econstr_back
8378 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8379 & +sum_sgtheta/sum_gtheta*waga_theta
8380 & *waga_homology(iset)
8381 c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8382 c & *waga_homology(iset)
8383 c dutheta(i)=sum_sgtheta/sum_gtheta
8385 c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8386 Eval=Eval-dLOG(gutheta_i/constr_homology)
8387 c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8388 c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8389 c Uconst_back=Uconst_back+utheta(i)
8390 enddo ! (i-loop for theta)
8392 write(iout,*) "------- theta restrs end -------"
8396 c Deviation of local SC geometry
8398 c Separation of two i-loops (instructed by AL - 11/3/2014)
8400 c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8401 c write (iout,*) "waga_d",waga_d
8404 write(iout,*) "------- SC restrs start -------"
8405 write (iout,*) "Initial duscdiff,duscdiffx"
8406 do i=loc_start,loc_end
8407 write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8408 & (duscdiffx(jik,i),jik=1,3)
8411 do i=loc_start,loc_end
8412 usc_diff_i=0.0d0 ! argument of Gaussian for single k
8413 guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8414 c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8415 c write(iout,*) "xxtab, yytab, zztab"
8416 c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8417 do k=1,constr_homology
8419 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8420 c Original sign inverted for calc of gradients (s. Econstr_back)
8421 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8422 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8423 c write(iout,*) "dxx, dyy, dzz"
8424 cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8426 usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
8427 c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8428 c uscdiffk(k)=usc_diff(i)
8429 guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8430 c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8431 c & " guscdiff2",guscdiff2(k)
8432 guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk)
8433 c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8434 c & xxref(j),yyref(j),zzref(j)
8439 c Generalized expression for multiple Gaussian acc to that for a single
8440 c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8442 c Original implementation
8443 c sum_guscdiff=guscdiff(i)
8445 c sum_sguscdiff=0.0d0
8446 c do k=1,constr_homology
8447 c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8448 c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8449 c sum_sguscdiff=sum_sguscdiff+sguscdiff
8452 c Implementation of new expressions for gradient (Jan. 2015)
8454 c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8455 do k=1,constr_homology
8457 c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8458 c before. Now the drivatives should be correct
8460 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8461 c Original sign inverted for calc of gradients (s. Econstr_back)
8462 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8463 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8465 c New implementation
8467 sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8468 & sigma_d(k,i) ! for the grad wrt r'
8469 c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8472 c New implementation
8473 sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8475 duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8476 & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8477 & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8478 duscdiff(jik,i)=duscdiff(jik,i)+
8479 & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8480 & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8481 duscdiffx(jik,i)=duscdiffx(jik,i)+
8482 & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8483 & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8486 write(iout,*) "jik",jik,"i",i
8487 write(iout,*) "dxx, dyy, dzz"
8488 write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8489 write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8490 c write(iout,*) "sum_sguscdiff",sum_sguscdiff
8491 cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8492 c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8493 c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8494 c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8495 c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8496 c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8497 c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8498 c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8499 c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8500 c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8501 c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8502 c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8508 c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
8509 c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8511 c write (iout,*) i," uscdiff",uscdiff(i)
8513 c Put together deviations from local geometry
8515 c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8516 c & wfrag_back(3,i,iset)*uscdiff(i)
8517 Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8518 c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8519 c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8520 c Uconst_back=Uconst_back+usc_diff(i)
8522 c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8524 c New implment: multiplied by sum_sguscdiff
8527 enddo ! (i-loop for dscdiff)
8532 write(iout,*) "------- SC restrs end -------"
8533 write (iout,*) "------ After SC loop in e_modeller ------"
8534 do i=loc_start,loc_end
8535 write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8536 write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8538 if (waga_theta.eq.1.0d0) then
8539 write (iout,*) "in e_modeller after SC restr end: dutheta"
8540 do i=ithet_start,ithet_end
8541 write (iout,*) i,dutheta(i)
8544 if (waga_d.eq.1.0d0) then
8545 write (iout,*) "e_modeller after SC loop: duscdiff/x"
8547 write (iout,*) i,(duscdiff(j,i),j=1,3)
8548 write (iout,*) i,(duscdiffx(j,i),j=1,3)
8553 c Total energy from homology restraints
8555 write (iout,*) "odleg",odleg," kat",kat
8558 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8560 c ehomology_constr=odleg+kat
8562 c For Lorentzian-type Urestr
8565 if (waga_dist.ge.0.0d0) then
8567 c For Gaussian-type Urestr
8569 ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8570 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8571 c write (iout,*) "ehomology_constr=",ehomology_constr
8574 c For Lorentzian-type Urestr
8576 ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8577 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8578 c write (iout,*) "ehomology_constr=",ehomology_constr
8581 write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8582 & "Eval",waga_theta,eval,
8583 & "Erot",waga_d,Erot
8584 write (iout,*) "ehomology_constr",ehomology_constr
8590 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8591 747 format(a12,i4,i4,i4,f8.3,f8.3)
8592 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8593 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8594 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8595 & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8597 c----------------------------------------------------------------------------
8598 C The rigorous attempt to derive energy function
8599 subroutine ebend_kcc(etheta)
8602 include 'DIMENSIONS'
8603 include 'COMMON.VAR'
8604 include 'COMMON.GEO'
8605 include 'COMMON.LOCAL'
8606 include 'COMMON.TORSION'
8607 include 'COMMON.INTERACT'
8608 include 'COMMON.DERIV'
8609 include 'COMMON.CHAIN'
8610 include 'COMMON.NAMES'
8611 include 'COMMON.IOUNITS'
8612 include 'COMMON.FFIELD'
8613 include 'COMMON.TORCNSTR'
8614 include 'COMMON.CONTROL'
8616 double precision thybt1(maxang_kcc)
8617 C Set lprn=.true. for debugging
8620 C print *,"wchodze kcc"
8621 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8623 do i=ithet_start,ithet_end
8624 c print *,i,itype(i-1),itype(i),itype(i-2)
8625 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8626 & .or.itype(i).eq.ntyp1) cycle
8627 iti=iabs(itortyp(itype(i-1)))
8628 sinthet=dsin(theta(i))
8629 costhet=dcos(theta(i))
8630 do j=1,nbend_kcc_Tb(iti)
8631 thybt1(j)=v1bend_chyb(j,iti)
8633 sumth1thyb=v1bend_chyb(0,iti)+
8634 & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8635 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8637 ihelp=nbend_kcc_Tb(iti)-1
8638 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8639 etheta=etheta+sumth1thyb
8640 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8641 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8645 c-------------------------------------------------------------------------------------
8646 subroutine etheta_constr(ethetacnstr)
8649 include 'DIMENSIONS'
8650 include 'COMMON.VAR'
8651 include 'COMMON.GEO'
8652 include 'COMMON.LOCAL'
8653 include 'COMMON.TORSION'
8654 include 'COMMON.INTERACT'
8655 include 'COMMON.DERIV'
8656 include 'COMMON.CHAIN'
8657 include 'COMMON.NAMES'
8658 include 'COMMON.IOUNITS'
8659 include 'COMMON.FFIELD'
8660 include 'COMMON.TORCNSTR'
8661 include 'COMMON.CONTROL'
8663 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8664 do i=ithetaconstr_start,ithetaconstr_end
8665 itheta=itheta_constr(i)
8666 thetiii=theta(itheta)
8667 difi=pinorm(thetiii-theta_constr0(i))
8668 if (difi.gt.theta_drange(i)) then
8669 difi=difi-theta_drange(i)
8670 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8671 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8672 & +for_thet_constr(i)*difi**3
8673 else if (difi.lt.-drange(i)) then
8675 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8676 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8677 & +for_thet_constr(i)*difi**3
8681 if (energy_dec) then
8682 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8683 & i,itheta,rad2deg*thetiii,
8684 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8685 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8686 & gloc(itheta+nphi-2,icg)
8691 c------------------------------------------------------------------------------
8692 subroutine eback_sc_corr(esccor)
8693 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8694 c conformational states; temporarily implemented as differences
8695 c between UNRES torsional potentials (dependent on three types of
8696 c residues) and the torsional potentials dependent on all 20 types
8697 c of residues computed from AM1 energy surfaces of terminally-blocked
8698 c amino-acid residues.
8700 include 'DIMENSIONS'
8701 include 'COMMON.VAR'
8702 include 'COMMON.GEO'
8703 include 'COMMON.LOCAL'
8704 include 'COMMON.TORSION'
8705 include 'COMMON.SCCOR'
8706 include 'COMMON.INTERACT'
8707 include 'COMMON.DERIV'
8708 include 'COMMON.CHAIN'
8709 include 'COMMON.NAMES'
8710 include 'COMMON.IOUNITS'
8711 include 'COMMON.FFIELD'
8712 include 'COMMON.CONTROL'
8714 C Set lprn=.true. for debugging
8717 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8719 do i=itau_start,itau_end
8720 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8722 isccori=isccortyp(itype(i-2))
8723 isccori1=isccortyp(itype(i-1))
8724 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8726 do intertyp=1,3 !intertyp
8727 cc Added 09 May 2012 (Adasko)
8728 cc Intertyp means interaction type of backbone mainchain correlation:
8729 c 1 = SC...Ca...Ca...Ca
8730 c 2 = Ca...Ca...Ca...SC
8731 c 3 = SC...Ca...Ca...SCi
8733 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8734 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8735 & (itype(i-1).eq.ntyp1)))
8736 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8737 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8738 & .or.(itype(i).eq.ntyp1)))
8739 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8740 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8741 & (itype(i-3).eq.ntyp1)))) cycle
8742 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8743 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8745 do j=1,nterm_sccor(isccori,isccori1)
8746 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8747 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8748 cosphi=dcos(j*tauangle(intertyp,i))
8749 sinphi=dsin(j*tauangle(intertyp,i))
8750 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8751 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8753 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8754 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8756 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8757 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8758 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8759 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8760 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8766 c----------------------------------------------------------------------------
8767 subroutine multibody(ecorr)
8768 C This subroutine calculates multi-body contributions to energy following
8769 C the idea of Skolnick et al. If side chains I and J make a contact and
8770 C at the same time side chains I+1 and J+1 make a contact, an extra
8771 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8773 include 'DIMENSIONS'
8774 include 'COMMON.IOUNITS'
8775 include 'COMMON.DERIV'
8776 include 'COMMON.INTERACT'
8777 include 'COMMON.CONTACTS'
8778 double precision gx(3),gx1(3)
8781 C Set lprn=.true. for debugging
8785 write (iout,'(a)') 'Contact function values:'
8787 write (iout,'(i2,20(1x,i2,f10.5))')
8788 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8803 num_conti=num_cont(i)
8804 num_conti1=num_cont(i1)
8809 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8810 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8811 cd & ' ishift=',ishift
8812 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8813 C The system gains extra energy.
8814 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8815 endif ! j1==j+-ishift
8824 c------------------------------------------------------------------------------
8825 double precision function esccorr(i,j,k,l,jj,kk)
8827 include 'DIMENSIONS'
8828 include 'COMMON.IOUNITS'
8829 include 'COMMON.DERIV'
8830 include 'COMMON.INTERACT'
8831 include 'COMMON.CONTACTS'
8832 include 'COMMON.SHIELD'
8833 double precision gx(3),gx1(3)
8838 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8839 C Calculate the multi-body contribution to energy.
8840 C Calculate multi-body contributions to the gradient.
8841 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8842 cd & k,l,(gacont(m,kk,k),m=1,3)
8844 gx(m) =ekl*gacont(m,jj,i)
8845 gx1(m)=eij*gacont(m,kk,k)
8846 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8847 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8848 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8849 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8853 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8858 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8864 c------------------------------------------------------------------------------
8865 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8866 C This subroutine calculates multi-body contributions to hydrogen-bonding
8868 include 'DIMENSIONS'
8869 include 'COMMON.IOUNITS'
8872 parameter (max_cont=maxconts)
8873 parameter (max_dim=26)
8874 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8875 double precision zapas(max_dim,maxconts,max_fg_procs),
8876 & zapas_recv(max_dim,maxconts,max_fg_procs)
8877 common /przechowalnia/ zapas
8878 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8879 & status_array(MPI_STATUS_SIZE,maxconts*2)
8881 include 'COMMON.SETUP'
8882 include 'COMMON.FFIELD'
8883 include 'COMMON.DERIV'
8884 include 'COMMON.INTERACT'
8885 include 'COMMON.CONTACTS'
8886 include 'COMMON.CONTROL'
8887 include 'COMMON.LOCAL'
8888 double precision gx(3),gx1(3),time00
8891 C Set lprn=.true. for debugging
8896 if (nfgtasks.le.1) goto 30
8898 write (iout,'(a)') 'Contact function values before RECEIVE:'
8900 write (iout,'(2i3,50(1x,i2,f5.2))')
8901 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8902 & j=1,num_cont_hb(i))
8906 do i=1,ntask_cont_from
8909 do i=1,ntask_cont_to
8912 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8914 C Make the list of contacts to send to send to other procesors
8915 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8917 do i=iturn3_start,iturn3_end
8918 c write (iout,*) "make contact list turn3",i," num_cont",
8920 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8922 do i=iturn4_start,iturn4_end
8923 c write (iout,*) "make contact list turn4",i," num_cont",
8925 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8929 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8931 do j=1,num_cont_hb(i)
8934 iproc=iint_sent_local(k,jjc,ii)
8935 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8936 if (iproc.gt.0) then
8937 ncont_sent(iproc)=ncont_sent(iproc)+1
8938 nn=ncont_sent(iproc)
8940 zapas(2,nn,iproc)=jjc
8941 zapas(3,nn,iproc)=facont_hb(j,i)
8942 zapas(4,nn,iproc)=ees0p(j,i)
8943 zapas(5,nn,iproc)=ees0m(j,i)
8944 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8945 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8946 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8947 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8948 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8949 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8950 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8951 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8952 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8953 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8954 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8955 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8956 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8957 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8958 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8959 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8960 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8961 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8962 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8963 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8964 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8971 & "Numbers of contacts to be sent to other processors",
8972 & (ncont_sent(i),i=1,ntask_cont_to)
8973 write (iout,*) "Contacts sent"
8974 do ii=1,ntask_cont_to
8976 iproc=itask_cont_to(ii)
8977 write (iout,*) nn," contacts to processor",iproc,
8978 & " of CONT_TO_COMM group"
8980 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8988 CorrelID1=nfgtasks+fg_rank+1
8990 C Receive the numbers of needed contacts from other processors
8991 do ii=1,ntask_cont_from
8992 iproc=itask_cont_from(ii)
8994 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8995 & FG_COMM,req(ireq),IERR)
8997 c write (iout,*) "IRECV ended"
8999 C Send the number of contacts needed by other processors
9000 do ii=1,ntask_cont_to
9001 iproc=itask_cont_to(ii)
9003 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9004 & FG_COMM,req(ireq),IERR)
9006 c write (iout,*) "ISEND ended"
9007 c write (iout,*) "number of requests (nn)",ireq
9010 & call MPI_Waitall(ireq,req,status_array,ierr)
9012 c & "Numbers of contacts to be received from other processors",
9013 c & (ncont_recv(i),i=1,ntask_cont_from)
9017 do ii=1,ntask_cont_from
9018 iproc=itask_cont_from(ii)
9020 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9021 c & " of CONT_TO_COMM group"
9025 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9026 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9027 c write (iout,*) "ireq,req",ireq,req(ireq)
9030 C Send the contacts to processors that need them
9031 do ii=1,ntask_cont_to
9032 iproc=itask_cont_to(ii)
9034 c write (iout,*) nn," contacts to processor",iproc,
9035 c & " of CONT_TO_COMM group"
9038 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9039 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9040 c write (iout,*) "ireq,req",ireq,req(ireq)
9042 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9046 c write (iout,*) "number of requests (contacts)",ireq
9047 c write (iout,*) "req",(req(i),i=1,4)
9050 & call MPI_Waitall(ireq,req,status_array,ierr)
9051 do iii=1,ntask_cont_from
9052 iproc=itask_cont_from(iii)
9055 write (iout,*) "Received",nn," contacts from processor",iproc,
9056 & " of CONT_FROM_COMM group"
9059 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9064 ii=zapas_recv(1,i,iii)
9065 c Flag the received contacts to prevent double-counting
9066 jj=-zapas_recv(2,i,iii)
9067 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9069 nnn=num_cont_hb(ii)+1
9072 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9073 ees0p(nnn,ii)=zapas_recv(4,i,iii)
9074 ees0m(nnn,ii)=zapas_recv(5,i,iii)
9075 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9076 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9077 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9078 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9079 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9080 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9081 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9082 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9083 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9084 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9085 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9086 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9087 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9088 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9089 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9090 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9091 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9092 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9093 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9094 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9095 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9099 write (iout,'(a)') 'Contact function values after receive:'
9101 write (iout,'(2i3,50(1x,i3,f5.2))')
9102 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9103 & j=1,num_cont_hb(i))
9110 write (iout,'(a)') 'Contact function values:'
9112 write (iout,'(2i3,50(1x,i3,f5.2))')
9113 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9114 & j=1,num_cont_hb(i))
9119 C Remove the loop below after debugging !!!
9126 C Calculate the local-electrostatic correlation terms
9127 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9129 num_conti=num_cont_hb(i)
9130 num_conti1=num_cont_hb(i+1)
9137 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9138 c & ' jj=',jj,' kk=',kk
9140 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9141 & .or. j.lt.0 .and. j1.gt.0) .and.
9142 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9143 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9144 C The system gains extra energy.
9145 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9146 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9147 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9149 else if (j1.eq.j) then
9150 C Contacts I-J and I-(J+1) occur simultaneously.
9151 C The system loses extra energy.
9152 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9157 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9158 c & ' jj=',jj,' kk=',kk
9160 C Contacts I-J and (I+1)-J occur simultaneously.
9161 C The system loses extra energy.
9162 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9169 c------------------------------------------------------------------------------
9170 subroutine add_hb_contact(ii,jj,itask)
9172 include "DIMENSIONS"
9173 include "COMMON.IOUNITS"
9176 parameter (max_cont=maxconts)
9177 parameter (max_dim=26)
9178 include "COMMON.CONTACTS"
9179 double precision zapas(max_dim,maxconts,max_fg_procs),
9180 & zapas_recv(max_dim,maxconts,max_fg_procs)
9181 common /przechowalnia/ zapas
9182 integer i,j,ii,jj,iproc,itask(4),nn
9183 c write (iout,*) "itask",itask
9186 if (iproc.gt.0) then
9187 do j=1,num_cont_hb(ii)
9189 c write (iout,*) "i",ii," j",jj," jjc",jjc
9191 ncont_sent(iproc)=ncont_sent(iproc)+1
9192 nn=ncont_sent(iproc)
9193 zapas(1,nn,iproc)=ii
9194 zapas(2,nn,iproc)=jjc
9195 zapas(3,nn,iproc)=facont_hb(j,ii)
9196 zapas(4,nn,iproc)=ees0p(j,ii)
9197 zapas(5,nn,iproc)=ees0m(j,ii)
9198 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9199 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9200 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9201 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9202 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9203 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9204 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9205 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9206 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9207 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9208 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9209 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9210 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9211 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9212 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9213 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9214 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9215 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9216 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9217 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9218 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9226 c------------------------------------------------------------------------------
9227 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9229 C This subroutine calculates multi-body contributions to hydrogen-bonding
9231 include 'DIMENSIONS'
9232 include 'COMMON.IOUNITS'
9235 parameter (max_cont=maxconts)
9236 parameter (max_dim=70)
9237 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9238 double precision zapas(max_dim,maxconts,max_fg_procs),
9239 & zapas_recv(max_dim,maxconts,max_fg_procs)
9240 common /przechowalnia/ zapas
9241 integer status(MPI_STATUS_SIZE),req(maxconts*2),
9242 & status_array(MPI_STATUS_SIZE,maxconts*2)
9244 include 'COMMON.SETUP'
9245 include 'COMMON.FFIELD'
9246 include 'COMMON.DERIV'
9247 include 'COMMON.LOCAL'
9248 include 'COMMON.INTERACT'
9249 include 'COMMON.CONTACTS'
9250 include 'COMMON.CHAIN'
9251 include 'COMMON.CONTROL'
9252 include 'COMMON.SHIELD'
9253 double precision gx(3),gx1(3)
9254 integer num_cont_hb_old(maxres)
9256 double precision eello4,eello5,eelo6,eello_turn6
9257 external eello4,eello5,eello6,eello_turn6
9258 C Set lprn=.true. for debugging
9263 num_cont_hb_old(i)=num_cont_hb(i)
9267 if (nfgtasks.le.1) goto 30
9269 write (iout,'(a)') 'Contact function values before RECEIVE:'
9271 write (iout,'(2i3,50(1x,i2,f5.2))')
9272 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9273 & j=1,num_cont_hb(i))
9276 do i=1,ntask_cont_from
9279 do i=1,ntask_cont_to
9282 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9284 C Make the list of contacts to send to send to other procesors
9285 do i=iturn3_start,iturn3_end
9286 c write (iout,*) "make contact list turn3",i," num_cont",
9288 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9290 do i=iturn4_start,iturn4_end
9291 c write (iout,*) "make contact list turn4",i," num_cont",
9293 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9297 c write (iout,*) "make contact list longrange",i,ii," num_cont",
9299 do j=1,num_cont_hb(i)
9302 iproc=iint_sent_local(k,jjc,ii)
9303 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9304 if (iproc.ne.0) then
9305 ncont_sent(iproc)=ncont_sent(iproc)+1
9306 nn=ncont_sent(iproc)
9308 zapas(2,nn,iproc)=jjc
9309 zapas(3,nn,iproc)=d_cont(j,i)
9313 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9318 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9326 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9337 & "Numbers of contacts to be sent to other processors",
9338 & (ncont_sent(i),i=1,ntask_cont_to)
9339 write (iout,*) "Contacts sent"
9340 do ii=1,ntask_cont_to
9342 iproc=itask_cont_to(ii)
9343 write (iout,*) nn," contacts to processor",iproc,
9344 & " of CONT_TO_COMM group"
9346 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9354 CorrelID1=nfgtasks+fg_rank+1
9356 C Receive the numbers of needed contacts from other processors
9357 do ii=1,ntask_cont_from
9358 iproc=itask_cont_from(ii)
9360 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9361 & FG_COMM,req(ireq),IERR)
9363 c write (iout,*) "IRECV ended"
9365 C Send the number of contacts needed by other processors
9366 do ii=1,ntask_cont_to
9367 iproc=itask_cont_to(ii)
9369 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9370 & FG_COMM,req(ireq),IERR)
9372 c write (iout,*) "ISEND ended"
9373 c write (iout,*) "number of requests (nn)",ireq
9376 & call MPI_Waitall(ireq,req,status_array,ierr)
9378 c & "Numbers of contacts to be received from other processors",
9379 c & (ncont_recv(i),i=1,ntask_cont_from)
9383 do ii=1,ntask_cont_from
9384 iproc=itask_cont_from(ii)
9386 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9387 c & " of CONT_TO_COMM group"
9391 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9392 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9393 c write (iout,*) "ireq,req",ireq,req(ireq)
9396 C Send the contacts to processors that need them
9397 do ii=1,ntask_cont_to
9398 iproc=itask_cont_to(ii)
9400 c write (iout,*) nn," contacts to processor",iproc,
9401 c & " of CONT_TO_COMM group"
9404 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9405 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9406 c write (iout,*) "ireq,req",ireq,req(ireq)
9408 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9412 c write (iout,*) "number of requests (contacts)",ireq
9413 c write (iout,*) "req",(req(i),i=1,4)
9416 & call MPI_Waitall(ireq,req,status_array,ierr)
9417 do iii=1,ntask_cont_from
9418 iproc=itask_cont_from(iii)
9421 write (iout,*) "Received",nn," contacts from processor",iproc,
9422 & " of CONT_FROM_COMM group"
9425 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9430 ii=zapas_recv(1,i,iii)
9431 c Flag the received contacts to prevent double-counting
9432 jj=-zapas_recv(2,i,iii)
9433 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9435 nnn=num_cont_hb(ii)+1
9438 d_cont(nnn,ii)=zapas_recv(3,i,iii)
9442 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9447 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9455 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9463 write (iout,'(a)') 'Contact function values after receive:'
9465 write (iout,'(2i3,50(1x,i3,5f6.3))')
9466 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9467 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9474 write (iout,'(a)') 'Contact function values:'
9476 write (iout,'(2i3,50(1x,i2,5f6.3))')
9477 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9478 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9484 C Remove the loop below after debugging !!!
9491 C Calculate the dipole-dipole interaction energies
9492 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9493 do i=iatel_s,iatel_e+1
9494 num_conti=num_cont_hb(i)
9503 C Calculate the local-electrostatic correlation terms
9504 c write (iout,*) "gradcorr5 in eello5 before loop"
9506 c write (iout,'(i5,3f10.5)')
9507 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9509 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9510 c write (iout,*) "corr loop i",i
9512 num_conti=num_cont_hb(i)
9513 num_conti1=num_cont_hb(i+1)
9520 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9521 c & ' jj=',jj,' kk=',kk
9522 c if (j1.eq.j+1 .or. j1.eq.j-1) then
9523 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9524 & .or. j.lt.0 .and. j1.gt.0) .and.
9525 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9526 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9527 C The system gains extra energy.
9529 sqd1=dsqrt(d_cont(jj,i))
9530 sqd2=dsqrt(d_cont(kk,i1))
9531 sred_geom = sqd1*sqd2
9532 IF (sred_geom.lt.cutoff_corr) THEN
9533 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9535 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9536 cd & ' jj=',jj,' kk=',kk
9537 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9538 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9540 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9541 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9544 cd write (iout,*) 'sred_geom=',sred_geom,
9545 cd & ' ekont=',ekont,' fprim=',fprimcont,
9546 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9547 cd write (iout,*) "g_contij",g_contij
9548 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9549 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9550 call calc_eello(i,jp,i+1,jp1,jj,kk)
9551 if (wcorr4.gt.0.0d0)
9552 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9553 CC & *fac_shield(i)**2*fac_shield(j)**2
9554 if (energy_dec.and.wcorr4.gt.0.0d0)
9555 1 write (iout,'(a6,4i5,0pf7.3)')
9556 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9557 c write (iout,*) "gradcorr5 before eello5"
9559 c write (iout,'(i5,3f10.5)')
9560 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9562 if (wcorr5.gt.0.0d0)
9563 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9564 c write (iout,*) "gradcorr5 after eello5"
9566 c write (iout,'(i5,3f10.5)')
9567 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9569 if (energy_dec.and.wcorr5.gt.0.0d0)
9570 1 write (iout,'(a6,4i5,0pf7.3)')
9571 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9572 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9573 cd write(2,*)'ijkl',i,jp,i+1,jp1
9574 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9575 & .or. wturn6.eq.0.0d0))then
9576 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9577 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9578 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9579 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9580 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9581 cd & 'ecorr6=',ecorr6
9582 cd write (iout,'(4e15.5)') sred_geom,
9583 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9584 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9585 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9586 else if (wturn6.gt.0.0d0
9587 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9588 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9589 eturn6=eturn6+eello_turn6(i,jj,kk)
9590 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9591 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9592 cd write (2,*) 'multibody_eello:eturn6',eturn6
9601 num_cont_hb(i)=num_cont_hb_old(i)
9603 c write (iout,*) "gradcorr5 in eello5"
9605 c write (iout,'(i5,3f10.5)')
9606 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9610 c------------------------------------------------------------------------------
9611 subroutine add_hb_contact_eello(ii,jj,itask)
9613 include "DIMENSIONS"
9614 include "COMMON.IOUNITS"
9617 parameter (max_cont=maxconts)
9618 parameter (max_dim=70)
9619 include "COMMON.CONTACTS"
9620 double precision zapas(max_dim,maxconts,max_fg_procs),
9621 & zapas_recv(max_dim,maxconts,max_fg_procs)
9622 common /przechowalnia/ zapas
9623 integer i,j,ii,jj,iproc,itask(4),nn
9624 c write (iout,*) "itask",itask
9627 if (iproc.gt.0) then
9628 do j=1,num_cont_hb(ii)
9630 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9632 ncont_sent(iproc)=ncont_sent(iproc)+1
9633 nn=ncont_sent(iproc)
9634 zapas(1,nn,iproc)=ii
9635 zapas(2,nn,iproc)=jjc
9636 zapas(3,nn,iproc)=d_cont(j,ii)
9640 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9645 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9653 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9665 c------------------------------------------------------------------------------
9666 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9668 include 'DIMENSIONS'
9669 include 'COMMON.IOUNITS'
9670 include 'COMMON.DERIV'
9671 include 'COMMON.INTERACT'
9672 include 'COMMON.CONTACTS'
9673 include 'COMMON.SHIELD'
9674 include 'COMMON.CONTROL'
9675 double precision gx(3),gx1(3)
9678 C print *,"wchodze",fac_shield(i),shield_mode
9686 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9688 C & fac_shield(i)**2*fac_shield(j)**2
9689 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9690 C Following 4 lines for diagnostics.
9695 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9696 c & 'Contacts ',i,j,
9697 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9698 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9700 C Calculate the multi-body contribution to energy.
9701 C ecorr=ecorr+ekont*ees
9702 C Calculate multi-body contributions to the gradient.
9703 coeffpees0pij=coeffp*ees0pij
9704 coeffmees0mij=coeffm*ees0mij
9705 coeffpees0pkl=coeffp*ees0pkl
9706 coeffmees0mkl=coeffm*ees0mkl
9708 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9709 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9710 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9711 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9712 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9713 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9714 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9715 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9716 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9717 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9718 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9719 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9720 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9721 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9722 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9723 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9724 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9725 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9726 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9727 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9728 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9729 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9730 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9731 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9732 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9737 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9738 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9739 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9740 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9745 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9746 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9747 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9748 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9751 c write (iout,*) "ehbcorr",ekont*ees
9752 C print *,ekont,ees,i,k
9754 C now gradient over shielding
9756 if (shield_mode.gt.0) then
9759 C print *,i,j,fac_shield(i),fac_shield(j),
9760 C &fac_shield(k),fac_shield(l)
9761 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9762 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9763 do ilist=1,ishield_list(i)
9764 iresshield=shield_list(ilist,i)
9766 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9768 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9770 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9771 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9775 do ilist=1,ishield_list(j)
9776 iresshield=shield_list(ilist,j)
9778 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9780 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9782 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9783 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9788 do ilist=1,ishield_list(k)
9789 iresshield=shield_list(ilist,k)
9791 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9793 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9795 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9796 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9800 do ilist=1,ishield_list(l)
9801 iresshield=shield_list(ilist,l)
9803 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9805 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9807 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9808 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9812 C print *,gshieldx(m,iresshield)
9814 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9815 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9816 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9817 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9818 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9819 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9820 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9821 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9823 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9824 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9825 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9826 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9827 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9828 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9829 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9830 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9838 C---------------------------------------------------------------------------
9839 subroutine dipole(i,j,jj)
9840 implicit real*8 (a-h,o-z)
9841 include 'DIMENSIONS'
9842 include 'COMMON.IOUNITS'
9843 include 'COMMON.CHAIN'
9844 include 'COMMON.FFIELD'
9845 include 'COMMON.DERIV'
9846 include 'COMMON.INTERACT'
9847 include 'COMMON.CONTACTS'
9848 include 'COMMON.TORSION'
9849 include 'COMMON.VAR'
9850 include 'COMMON.GEO'
9851 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9853 iti1 = itortyp(itype(i+1))
9854 if (j.lt.nres-1) then
9855 itj1 = itype2loc(itype(j+1))
9860 dipi(iii,1)=Ub2(iii,i)
9861 dipderi(iii)=Ub2der(iii,i)
9862 dipi(iii,2)=b1(iii,i+1)
9863 dipj(iii,1)=Ub2(iii,j)
9864 dipderj(iii)=Ub2der(iii,j)
9865 dipj(iii,2)=b1(iii,j+1)
9869 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9872 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9879 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9883 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9888 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9889 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9891 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9893 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9895 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9900 C---------------------------------------------------------------------------
9901 subroutine calc_eello(i,j,k,l,jj,kk)
9903 C This subroutine computes matrices and vectors needed to calculate
9904 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9907 include 'DIMENSIONS'
9908 include 'COMMON.IOUNITS'
9909 include 'COMMON.CHAIN'
9910 include 'COMMON.DERIV'
9911 include 'COMMON.INTERACT'
9912 include 'COMMON.CONTACTS'
9913 include 'COMMON.TORSION'
9914 include 'COMMON.VAR'
9915 include 'COMMON.GEO'
9916 include 'COMMON.FFIELD'
9917 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9918 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9921 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9922 cd & ' jj=',jj,' kk=',kk
9923 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9924 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9925 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9928 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9929 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9932 call transpose2(aa1(1,1),aa1t(1,1))
9933 call transpose2(aa2(1,1),aa2t(1,1))
9936 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9937 & aa1tder(1,1,lll,kkk))
9938 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9939 & aa2tder(1,1,lll,kkk))
9943 C parallel orientation of the two CA-CA-CA frames.
9945 iti=itype2loc(itype(i))
9949 itk1=itype2loc(itype(k+1))
9950 itj=itype2loc(itype(j))
9951 if (l.lt.nres-1) then
9952 itl1=itype2loc(itype(l+1))
9956 C A1 kernel(j+1) A2T
9958 cd write (iout,'(3f10.5,5x,3f10.5)')
9959 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9961 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9962 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9963 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9964 C Following matrices are needed only for 6-th order cumulants
9965 IF (wcorr6.gt.0.0d0) THEN
9966 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9967 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9968 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9969 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9970 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9971 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9972 & ADtEAderx(1,1,1,1,1,1))
9974 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9975 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9976 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9977 & ADtEA1derx(1,1,1,1,1,1))
9979 C End 6-th order cumulants
9982 cd write (2,*) 'In calc_eello6'
9984 cd write (2,*) 'iii=',iii
9986 cd write (2,*) 'kkk=',kkk
9988 cd write (2,'(3(2f10.5),5x)')
9989 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9994 call transpose2(EUgder(1,1,k),auxmat(1,1))
9995 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9996 call transpose2(EUg(1,1,k),auxmat(1,1))
9997 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9998 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9999 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
10000 c in theta; to be sriten later.
10002 c call transpose2(gtEE(1,1,k),auxmat(1,1))
10003 c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
10004 c call transpose2(EUg(1,1,k),auxmat(1,1))
10005 c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
10010 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10011 & EAEAderx(1,1,lll,kkk,iii,1))
10015 C A1T kernel(i+1) A2
10016 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10017 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
10018 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10019 C Following matrices are needed only for 6-th order cumulants
10020 IF (wcorr6.gt.0.0d0) THEN
10021 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10022 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
10023 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10024 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10025 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
10026 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10027 & ADtEAderx(1,1,1,1,1,2))
10028 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10029 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
10030 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10031 & ADtEA1derx(1,1,1,1,1,2))
10033 C End 6-th order cumulants
10034 call transpose2(EUgder(1,1,l),auxmat(1,1))
10035 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
10036 call transpose2(EUg(1,1,l),auxmat(1,1))
10037 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10038 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10042 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10043 & EAEAderx(1,1,lll,kkk,iii,2))
10048 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10049 C They are needed only when the fifth- or the sixth-order cumulants are
10051 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10052 call transpose2(AEA(1,1,1),auxmat(1,1))
10053 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10054 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10055 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10056 call transpose2(AEAderg(1,1,1),auxmat(1,1))
10057 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10058 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10059 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10060 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10061 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10062 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10063 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10064 call transpose2(AEA(1,1,2),auxmat(1,1))
10065 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10066 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10067 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10068 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10069 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10070 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10071 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10072 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10073 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10074 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10075 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10076 C Calculate the Cartesian derivatives of the vectors.
10080 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10081 call matvec2(auxmat(1,1),b1(1,i),
10082 & AEAb1derx(1,lll,kkk,iii,1,1))
10083 call matvec2(auxmat(1,1),Ub2(1,i),
10084 & AEAb2derx(1,lll,kkk,iii,1,1))
10085 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10086 & AEAb1derx(1,lll,kkk,iii,2,1))
10087 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10088 & AEAb2derx(1,lll,kkk,iii,2,1))
10089 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10090 call matvec2(auxmat(1,1),b1(1,j),
10091 & AEAb1derx(1,lll,kkk,iii,1,2))
10092 call matvec2(auxmat(1,1),Ub2(1,j),
10093 & AEAb2derx(1,lll,kkk,iii,1,2))
10094 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10095 & AEAb1derx(1,lll,kkk,iii,2,2))
10096 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10097 & AEAb2derx(1,lll,kkk,iii,2,2))
10104 C Antiparallel orientation of the two CA-CA-CA frames.
10106 iti=itype2loc(itype(i))
10110 itk1=itype2loc(itype(k+1))
10111 itl=itype2loc(itype(l))
10112 itj=itype2loc(itype(j))
10113 if (j.lt.nres-1) then
10114 itj1=itype2loc(itype(j+1))
10118 C A2 kernel(j-1)T A1T
10119 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10120 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10121 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10122 C Following matrices are needed only for 6-th order cumulants
10123 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10124 & j.eq.i+4 .and. l.eq.i+3)) THEN
10125 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10126 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10127 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10128 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10129 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10130 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10131 & ADtEAderx(1,1,1,1,1,1))
10132 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10133 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10134 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10135 & ADtEA1derx(1,1,1,1,1,1))
10137 C End 6-th order cumulants
10138 call transpose2(EUgder(1,1,k),auxmat(1,1))
10139 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10140 call transpose2(EUg(1,1,k),auxmat(1,1))
10141 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10142 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10146 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10147 & EAEAderx(1,1,lll,kkk,iii,1))
10151 C A2T kernel(i+1)T A1
10152 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10153 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10154 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10155 C Following matrices are needed only for 6-th order cumulants
10156 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10157 & j.eq.i+4 .and. l.eq.i+3)) THEN
10158 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10159 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10160 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10161 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10162 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10163 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10164 & ADtEAderx(1,1,1,1,1,2))
10165 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10166 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10167 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10168 & ADtEA1derx(1,1,1,1,1,2))
10170 C End 6-th order cumulants
10171 call transpose2(EUgder(1,1,j),auxmat(1,1))
10172 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10173 call transpose2(EUg(1,1,j),auxmat(1,1))
10174 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10175 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10179 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10180 & EAEAderx(1,1,lll,kkk,iii,2))
10185 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10186 C They are needed only when the fifth- or the sixth-order cumulants are
10188 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10189 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10190 call transpose2(AEA(1,1,1),auxmat(1,1))
10191 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10192 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10193 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10194 call transpose2(AEAderg(1,1,1),auxmat(1,1))
10195 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10196 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10197 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10198 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10199 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10200 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10201 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10202 call transpose2(AEA(1,1,2),auxmat(1,1))
10203 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10204 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10205 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10206 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10207 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10208 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10209 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10210 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10211 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10212 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10213 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10214 C Calculate the Cartesian derivatives of the vectors.
10218 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10219 call matvec2(auxmat(1,1),b1(1,i),
10220 & AEAb1derx(1,lll,kkk,iii,1,1))
10221 call matvec2(auxmat(1,1),Ub2(1,i),
10222 & AEAb2derx(1,lll,kkk,iii,1,1))
10223 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10224 & AEAb1derx(1,lll,kkk,iii,2,1))
10225 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10226 & AEAb2derx(1,lll,kkk,iii,2,1))
10227 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10228 call matvec2(auxmat(1,1),b1(1,l),
10229 & AEAb1derx(1,lll,kkk,iii,1,2))
10230 call matvec2(auxmat(1,1),Ub2(1,l),
10231 & AEAb2derx(1,lll,kkk,iii,1,2))
10232 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10233 & AEAb1derx(1,lll,kkk,iii,2,2))
10234 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10235 & AEAb2derx(1,lll,kkk,iii,2,2))
10244 C---------------------------------------------------------------------------
10245 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10246 & KK,KKderg,AKA,AKAderg,AKAderx)
10250 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10251 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10252 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10253 integer iii,kkk,lll
10256 common /kutas/ lprn
10257 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10259 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10260 & AKAderg(1,1,iii))
10262 cd if (lprn) write (2,*) 'In kernel'
10264 cd if (lprn) write (2,*) 'kkk=',kkk
10266 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10267 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10269 cd write (2,*) 'lll=',lll
10270 cd write (2,*) 'iii=1'
10272 cd write (2,'(3(2f10.5),5x)')
10273 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10276 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10277 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10279 cd write (2,*) 'lll=',lll
10280 cd write (2,*) 'iii=2'
10282 cd write (2,'(3(2f10.5),5x)')
10283 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10290 C---------------------------------------------------------------------------
10291 double precision function eello4(i,j,k,l,jj,kk)
10293 include 'DIMENSIONS'
10294 include 'COMMON.IOUNITS'
10295 include 'COMMON.CHAIN'
10296 include 'COMMON.DERIV'
10297 include 'COMMON.INTERACT'
10298 include 'COMMON.CONTACTS'
10299 include 'COMMON.TORSION'
10300 include 'COMMON.VAR'
10301 include 'COMMON.GEO'
10302 double precision pizda(2,2),ggg1(3),ggg2(3)
10303 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10307 cd print *,'eello4:',i,j,k,l,jj,kk
10308 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
10309 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
10310 cold eij=facont_hb(jj,i)
10311 cold ekl=facont_hb(kk,k)
10313 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10314 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10315 gcorr_loc(k-1)=gcorr_loc(k-1)
10316 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10318 gcorr_loc(l-1)=gcorr_loc(l-1)
10319 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10320 C Al 4/16/16: Derivatives in theta, to be added later.
10322 c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10323 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10326 gcorr_loc(j-1)=gcorr_loc(j-1)
10327 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10329 c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10330 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10336 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10337 & -EAEAderx(2,2,lll,kkk,iii,1)
10338 cd derx(lll,kkk,iii)=0.0d0
10342 cd gcorr_loc(l-1)=0.0d0
10343 cd gcorr_loc(j-1)=0.0d0
10344 cd gcorr_loc(k-1)=0.0d0
10346 cd write (iout,*)'Contacts have occurred for peptide groups',
10347 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
10348 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10349 if (j.lt.nres-1) then
10356 if (l.lt.nres-1) then
10364 cgrad ggg1(ll)=eel4*g_contij(ll,1)
10365 cgrad ggg2(ll)=eel4*g_contij(ll,2)
10366 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10367 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10368 cgrad ghalf=0.5d0*ggg1(ll)
10369 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10370 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10371 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10372 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10373 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10374 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10375 cgrad ghalf=0.5d0*ggg2(ll)
10376 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10377 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10378 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10379 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10380 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10381 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10385 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10390 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10395 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10400 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10404 cd write (2,*) iii,gcorr_loc(iii)
10407 cd write (2,*) 'ekont',ekont
10408 cd write (iout,*) 'eello4',ekont*eel4
10411 C---------------------------------------------------------------------------
10412 double precision function eello5(i,j,k,l,jj,kk)
10413 implicit real*8 (a-h,o-z)
10414 include 'DIMENSIONS'
10415 include 'COMMON.IOUNITS'
10416 include 'COMMON.CHAIN'
10417 include 'COMMON.DERIV'
10418 include 'COMMON.INTERACT'
10419 include 'COMMON.CONTACTS'
10420 include 'COMMON.TORSION'
10421 include 'COMMON.VAR'
10422 include 'COMMON.GEO'
10423 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10424 double precision ggg1(3),ggg2(3)
10425 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10427 C Parallel chains C
10430 C /l\ / \ \ / \ / \ / C
10431 C / \ / \ \ / \ / \ / C
10432 C j| o |l1 | o | o| o | | o |o C
10433 C \ |/k\| |/ \| / |/ \| |/ \| C
10434 C \i/ \ / \ / / \ / \ C
10436 C (I) (II) (III) (IV) C
10438 C eello5_1 eello5_2 eello5_3 eello5_4 C
10440 C Antiparallel chains C
10443 C /j\ / \ \ / \ / \ / C
10444 C / \ / \ \ / \ / \ / C
10445 C j1| o |l | o | o| o | | o |o C
10446 C \ |/k\| |/ \| / |/ \| |/ \| C
10447 C \i/ \ / \ / / \ / \ C
10449 C (I) (II) (III) (IV) C
10451 C eello5_1 eello5_2 eello5_3 eello5_4 C
10453 C o denotes a local interaction, vertical lines an electrostatic interaction. C
10455 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10456 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10461 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
10463 itk=itype2loc(itype(k))
10464 itl=itype2loc(itype(l))
10465 itj=itype2loc(itype(j))
10470 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10471 cd & eel5_3_num,eel5_4_num)
10475 derx(lll,kkk,iii)=0.0d0
10479 cd eij=facont_hb(jj,i)
10480 cd ekl=facont_hb(kk,k)
10482 cd write (iout,*)'Contacts have occurred for peptide groups',
10483 cd & i,j,' fcont:',eij,' eij',' and ',k,l
10485 C Contribution from the graph I.
10486 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10487 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10488 call transpose2(EUg(1,1,k),auxmat(1,1))
10489 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10490 vv(1)=pizda(1,1)-pizda(2,2)
10491 vv(2)=pizda(1,2)+pizda(2,1)
10492 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10493 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10494 C Explicit gradient in virtual-dihedral angles.
10495 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10496 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10497 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10498 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10499 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10500 vv(1)=pizda(1,1)-pizda(2,2)
10501 vv(2)=pizda(1,2)+pizda(2,1)
10502 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10503 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10504 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10505 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10506 vv(1)=pizda(1,1)-pizda(2,2)
10507 vv(2)=pizda(1,2)+pizda(2,1)
10509 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10510 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10511 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10513 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10514 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10515 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10517 C Cartesian gradient
10521 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10523 vv(1)=pizda(1,1)-pizda(2,2)
10524 vv(2)=pizda(1,2)+pizda(2,1)
10525 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10526 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10527 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10533 C Contribution from graph II
10534 call transpose2(EE(1,1,k),auxmat(1,1))
10535 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10536 vv(1)=pizda(1,1)+pizda(2,2)
10537 vv(2)=pizda(2,1)-pizda(1,2)
10538 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10539 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10540 C Explicit gradient in virtual-dihedral angles.
10541 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10542 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10543 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10544 vv(1)=pizda(1,1)+pizda(2,2)
10545 vv(2)=pizda(2,1)-pizda(1,2)
10547 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10548 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10549 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10551 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10552 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10553 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10555 C Cartesian gradient
10559 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10561 vv(1)=pizda(1,1)+pizda(2,2)
10562 vv(2)=pizda(2,1)-pizda(1,2)
10563 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10564 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10565 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10573 C Parallel orientation
10574 C Contribution from graph III
10575 call transpose2(EUg(1,1,l),auxmat(1,1))
10576 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10577 vv(1)=pizda(1,1)-pizda(2,2)
10578 vv(2)=pizda(1,2)+pizda(2,1)
10579 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10580 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10581 C Explicit gradient in virtual-dihedral angles.
10582 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10583 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10584 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10585 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10586 vv(1)=pizda(1,1)-pizda(2,2)
10587 vv(2)=pizda(1,2)+pizda(2,1)
10588 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10589 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10590 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10591 call transpose2(EUgder(1,1,l),auxmat1(1,1))
10592 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10593 vv(1)=pizda(1,1)-pizda(2,2)
10594 vv(2)=pizda(1,2)+pizda(2,1)
10595 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10596 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10597 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10598 C Cartesian gradient
10602 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10604 vv(1)=pizda(1,1)-pizda(2,2)
10605 vv(2)=pizda(1,2)+pizda(2,1)
10606 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10607 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10608 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10613 C Contribution from graph IV
10615 call transpose2(EE(1,1,l),auxmat(1,1))
10616 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10617 vv(1)=pizda(1,1)+pizda(2,2)
10618 vv(2)=pizda(2,1)-pizda(1,2)
10619 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10620 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10621 C Explicit gradient in virtual-dihedral angles.
10622 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10623 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10624 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10625 vv(1)=pizda(1,1)+pizda(2,2)
10626 vv(2)=pizda(2,1)-pizda(1,2)
10627 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10628 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10629 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10630 C Cartesian gradient
10634 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10636 vv(1)=pizda(1,1)+pizda(2,2)
10637 vv(2)=pizda(2,1)-pizda(1,2)
10638 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10639 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10640 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10645 C Antiparallel orientation
10646 C Contribution from graph III
10648 call transpose2(EUg(1,1,j),auxmat(1,1))
10649 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10650 vv(1)=pizda(1,1)-pizda(2,2)
10651 vv(2)=pizda(1,2)+pizda(2,1)
10652 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10653 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10654 C Explicit gradient in virtual-dihedral angles.
10655 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10656 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10657 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10658 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10659 vv(1)=pizda(1,1)-pizda(2,2)
10660 vv(2)=pizda(1,2)+pizda(2,1)
10661 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10662 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10663 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10664 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10665 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10666 vv(1)=pizda(1,1)-pizda(2,2)
10667 vv(2)=pizda(1,2)+pizda(2,1)
10668 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10669 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10670 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10671 C Cartesian gradient
10675 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10677 vv(1)=pizda(1,1)-pizda(2,2)
10678 vv(2)=pizda(1,2)+pizda(2,1)
10679 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10680 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10681 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10686 C Contribution from graph IV
10688 call transpose2(EE(1,1,j),auxmat(1,1))
10689 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10690 vv(1)=pizda(1,1)+pizda(2,2)
10691 vv(2)=pizda(2,1)-pizda(1,2)
10692 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10693 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10694 C Explicit gradient in virtual-dihedral angles.
10695 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10696 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10697 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10698 vv(1)=pizda(1,1)+pizda(2,2)
10699 vv(2)=pizda(2,1)-pizda(1,2)
10700 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10701 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10702 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10703 C Cartesian gradient
10707 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10709 vv(1)=pizda(1,1)+pizda(2,2)
10710 vv(2)=pizda(2,1)-pizda(1,2)
10711 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10712 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10713 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10719 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10720 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10721 cd write (2,*) 'ijkl',i,j,k,l
10722 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10723 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10725 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10726 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10727 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10728 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10729 if (j.lt.nres-1) then
10736 if (l.lt.nres-1) then
10746 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10747 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10748 C summed up outside the subrouine as for the other subroutines
10749 C handling long-range interactions. The old code is commented out
10750 C with "cgrad" to keep track of changes.
10752 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10753 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10754 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10755 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10756 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10757 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10758 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10759 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10760 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10761 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10763 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10764 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10765 cgrad ghalf=0.5d0*ggg1(ll)
10767 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10768 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10769 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10770 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10771 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10772 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10773 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10774 cgrad ghalf=0.5d0*ggg2(ll)
10776 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10777 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10778 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10779 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10780 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10781 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10786 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10787 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10792 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10793 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10799 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10804 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10808 cd write (2,*) iii,g_corr5_loc(iii)
10811 cd write (2,*) 'ekont',ekont
10812 cd write (iout,*) 'eello5',ekont*eel5
10815 c--------------------------------------------------------------------------
10816 double precision function eello6(i,j,k,l,jj,kk)
10817 implicit real*8 (a-h,o-z)
10818 include 'DIMENSIONS'
10819 include 'COMMON.IOUNITS'
10820 include 'COMMON.CHAIN'
10821 include 'COMMON.DERIV'
10822 include 'COMMON.INTERACT'
10823 include 'COMMON.CONTACTS'
10824 include 'COMMON.TORSION'
10825 include 'COMMON.VAR'
10826 include 'COMMON.GEO'
10827 include 'COMMON.FFIELD'
10828 double precision ggg1(3),ggg2(3)
10829 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10834 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10842 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10843 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10847 derx(lll,kkk,iii)=0.0d0
10851 cd eij=facont_hb(jj,i)
10852 cd ekl=facont_hb(kk,k)
10858 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10859 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10860 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10861 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10862 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10863 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10865 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10866 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10867 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10868 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10869 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10870 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10874 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10876 C If turn contributions are considered, they will be handled separately.
10877 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10878 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10879 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10880 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10881 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10882 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10883 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10885 if (j.lt.nres-1) then
10892 if (l.lt.nres-1) then
10900 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10901 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10902 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10903 cgrad ghalf=0.5d0*ggg1(ll)
10905 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10906 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10907 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10908 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10909 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10910 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10911 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10912 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10913 cgrad ghalf=0.5d0*ggg2(ll)
10914 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10916 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10917 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10918 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10919 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10920 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10921 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10926 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10927 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10932 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10933 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10939 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10944 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10948 cd write (2,*) iii,g_corr6_loc(iii)
10951 cd write (2,*) 'ekont',ekont
10952 cd write (iout,*) 'eello6',ekont*eel6
10955 c--------------------------------------------------------------------------
10956 double precision function eello6_graph1(i,j,k,l,imat,swap)
10957 implicit real*8 (a-h,o-z)
10958 include 'DIMENSIONS'
10959 include 'COMMON.IOUNITS'
10960 include 'COMMON.CHAIN'
10961 include 'COMMON.DERIV'
10962 include 'COMMON.INTERACT'
10963 include 'COMMON.CONTACTS'
10964 include 'COMMON.TORSION'
10965 include 'COMMON.VAR'
10966 include 'COMMON.GEO'
10967 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10970 common /kutas/ lprn
10971 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10973 C Parallel Antiparallel C
10979 C \ j|/k\| / \ |/k\|l / C
10980 C \ / \ / \ / \ / C
10984 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10985 itk=itype2loc(itype(k))
10986 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10987 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10988 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10989 call transpose2(EUgC(1,1,k),auxmat(1,1))
10990 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(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)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10995 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10996 s5=scalar2(vv(1),Dtobr2(1,i))
10997 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10998 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10999 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
11000 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
11001 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
11002 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
11003 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
11004 & +scalar2(vv(1),Dtobr2der(1,i)))
11005 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
11006 vv1(1)=pizda1(1,1)-pizda1(2,2)
11007 vv1(2)=pizda1(1,2)+pizda1(2,1)
11008 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
11009 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
11011 g_corr6_loc(l-1)=g_corr6_loc(l-1)
11012 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11013 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11014 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11015 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11017 g_corr6_loc(j-1)=g_corr6_loc(j-1)
11018 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11019 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11020 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11021 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11023 call transpose2(EUgCder(1,1,k),auxmat(1,1))
11024 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11025 vv1(1)=pizda1(1,1)-pizda1(2,2)
11026 vv1(2)=pizda1(1,2)+pizda1(2,1)
11027 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
11028 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
11029 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
11030 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
11039 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
11040 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
11041 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
11042 call transpose2(EUgC(1,1,k),auxmat(1,1))
11043 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11045 vv1(1)=pizda1(1,1)-pizda1(2,2)
11046 vv1(2)=pizda1(1,2)+pizda1(2,1)
11047 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11048 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11049 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11050 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11051 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11052 s5=scalar2(vv(1),Dtobr2(1,i))
11053 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11059 c----------------------------------------------------------------------------
11060 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11061 implicit real*8 (a-h,o-z)
11062 include 'DIMENSIONS'
11063 include 'COMMON.IOUNITS'
11064 include 'COMMON.CHAIN'
11065 include 'COMMON.DERIV'
11066 include 'COMMON.INTERACT'
11067 include 'COMMON.CONTACTS'
11068 include 'COMMON.TORSION'
11069 include 'COMMON.VAR'
11070 include 'COMMON.GEO'
11072 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11073 & auxvec1(2),auxvec2(2),auxmat1(2,2)
11075 common /kutas/ lprn
11076 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11078 C Parallel Antiparallel C
11084 C \ j|/k\| \ |/k\|l C
11089 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11090 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11091 C AL 7/4/01 s1 would occur in the sixth-order moment,
11092 C but not in a cluster cumulant
11094 s1=dip(1,jj,i)*dip(1,kk,k)
11096 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11097 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11098 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11099 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11100 call transpose2(EUg(1,1,k),auxmat(1,1))
11101 call matmat2(ADtEA1(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))
11105 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11107 eello6_graph2=-(s1+s2+s3+s4)
11109 eello6_graph2=-(s2+s3+s4)
11111 c eello6_graph2=-s3
11112 C Derivatives in gamma(i-1)
11115 s1=dipderg(1,jj,i)*dip(1,kk,k)
11117 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11118 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11119 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11120 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11122 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11124 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11126 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11128 C Derivatives in gamma(k-1)
11130 s1=dip(1,jj,i)*dipderg(1,kk,k)
11132 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11133 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11134 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11135 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11136 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11137 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11138 vv(1)=pizda(1,1)-pizda(2,2)
11139 vv(2)=pizda(1,2)+pizda(2,1)
11140 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11142 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11144 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11146 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11147 C Derivatives in gamma(j-1) or gamma(l-1)
11150 s1=dipderg(3,jj,i)*dip(1,kk,k)
11152 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11153 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11154 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11155 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11156 vv(1)=pizda(1,1)-pizda(2,2)
11157 vv(2)=pizda(1,2)+pizda(2,1)
11158 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11161 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11163 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11166 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11167 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11169 C Derivatives in gamma(l-1) or gamma(j-1)
11172 s1=dip(1,jj,i)*dipderg(3,kk,k)
11174 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11175 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11176 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11177 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11178 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11179 vv(1)=pizda(1,1)-pizda(2,2)
11180 vv(2)=pizda(1,2)+pizda(2,1)
11181 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11184 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11186 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11189 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11190 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11192 C Cartesian derivatives.
11194 write (2,*) 'In eello6_graph2'
11196 write (2,*) 'iii=',iii
11198 write (2,*) 'kkk=',kkk
11200 write (2,'(3(2f10.5),5x)')
11201 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11211 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11213 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11216 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11217 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11219 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11220 call transpose2(EUg(1,1,k),auxmat(1,1))
11221 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11223 vv(1)=pizda(1,1)-pizda(2,2)
11224 vv(2)=pizda(1,2)+pizda(2,1)
11225 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11226 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11228 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11230 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11233 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11235 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11242 c----------------------------------------------------------------------------
11243 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11244 implicit real*8 (a-h,o-z)
11245 include 'DIMENSIONS'
11246 include 'COMMON.IOUNITS'
11247 include 'COMMON.CHAIN'
11248 include 'COMMON.DERIV'
11249 include 'COMMON.INTERACT'
11250 include 'COMMON.CONTACTS'
11251 include 'COMMON.TORSION'
11252 include 'COMMON.VAR'
11253 include 'COMMON.GEO'
11254 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11256 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11258 C Parallel Antiparallel C
11263 C /| o |o o| o |\ C
11264 C j|/k\| / |/k\|l / C
11269 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11271 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11272 C energy moment and not to the cluster cumulant.
11273 iti=itortyp(itype(i))
11274 if (j.lt.nres-1) then
11275 itj1=itype2loc(itype(j+1))
11279 itk=itype2loc(itype(k))
11280 itk1=itype2loc(itype(k+1))
11281 if (l.lt.nres-1) then
11282 itl1=itype2loc(itype(l+1))
11287 s1=dip(4,jj,i)*dip(4,kk,k)
11289 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11290 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11291 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11292 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11293 call transpose2(EE(1,1,k),auxmat(1,1))
11294 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11295 vv(1)=pizda(1,1)+pizda(2,2)
11296 vv(2)=pizda(2,1)-pizda(1,2)
11297 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11298 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11299 cd & "sum",-(s2+s3+s4)
11301 eello6_graph3=-(s1+s2+s3+s4)
11303 eello6_graph3=-(s2+s3+s4)
11305 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11306 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11308 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11309 call transpose2(EUg(1,1,k),auxmat(1,1))
11310 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11312 vv(1)=pizda(1,1)-pizda(2,2)
11313 vv(2)=pizda(1,2)+pizda(2,1)
11314 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11315 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11317 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11319 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11322 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11324 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11331 c----------------------------------------------------------------------------
11332 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11333 implicit real*8 (a-h,o-z)
11334 include 'DIMENSIONS'
11335 include 'COMMON.IOUNITS'
11336 include 'COMMON.CHAIN'
11337 include 'COMMON.DERIV'
11338 include 'COMMON.INTERACT'
11339 include 'COMMON.CONTACTS'
11340 include 'COMMON.TORSION'
11341 include 'COMMON.VAR'
11342 include 'COMMON.GEO'
11343 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11345 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11347 C Parallel Antiparallel C
11352 C /| o |o o| o |\ C
11353 C j|/k\| / |/k\|l / C
11358 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11360 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11361 C energy moment and not to the cluster cumulant.
11362 iti=itortyp(itype(i))
11363 if (j.lt.nres-1) then
11364 itj1=itype2loc(itype(j+1))
11368 itk=itype2loc(itype(k))
11369 itk1=itype2loc(itype(k+1))
11370 if (l.lt.nres-1) then
11371 itl1=itype2loc(itype(l+1))
11376 s1=dip(4,jj,i)*dip(4,kk,k)
11378 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11379 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11380 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11381 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11382 call transpose2(EE(1,1,k),auxmat(1,1))
11383 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11384 vv(1)=pizda(1,1)+pizda(2,2)
11385 vv(2)=pizda(2,1)-pizda(1,2)
11386 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11387 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11388 cd & "sum",-(s2+s3+s4)
11390 eello6_graph3=-(s1+s2+s3+s4)
11392 cd write (2,*) 'eello_graph4: wturn6',wturn6
11393 iti=itype2loc(itype(i))
11394 itj=itype2loc(itype(j))
11395 if (j.lt.nres-1) then
11396 itj1=itype2loc(itype(j+1))
11400 itk=itype2loc(itype(k))
11401 if (k.lt.nres-1) then
11402 itk1=itype2loc(itype(k+1))
11406 itl=itype2loc(itype(l))
11407 if (l.lt.nres-1) then
11408 itl1=itype2loc(itype(l+1))
11412 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11413 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11414 cd & ' itl',itl,' itl1',itl1
11416 if (imat.eq.1) then
11417 s1=dip(3,jj,i)*dip(3,kk,k)
11419 s1=dip(2,jj,j)*dip(2,kk,l)
11422 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11423 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11425 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11426 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11428 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11429 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11431 call transpose2(EUg(1,1,k),auxmat(1,1))
11432 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11433 vv(1)=pizda(1,1)-pizda(2,2)
11434 vv(2)=pizda(2,1)+pizda(1,2)
11435 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11436 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11438 eello6_graph4=-(s1+s2+s3+s4)
11440 eello6_graph4=-(s2+s3+s4)
11442 C Derivatives in gamma(i-1)
11445 if (imat.eq.1) then
11446 s1=dipderg(2,jj,i)*dip(3,kk,k)
11448 s1=dipderg(4,jj,j)*dip(2,kk,l)
11451 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11453 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11454 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11456 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11457 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11459 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11460 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11461 cd write (2,*) 'turn6 derivatives'
11463 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11465 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11469 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11471 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11475 C Derivatives in gamma(k-1)
11477 if (imat.eq.1) then
11478 s1=dip(3,jj,i)*dipderg(2,kk,k)
11480 s1=dip(2,jj,j)*dipderg(4,kk,l)
11483 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11484 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11486 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11487 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11489 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11490 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11492 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11493 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11494 vv(1)=pizda(1,1)-pizda(2,2)
11495 vv(2)=pizda(2,1)+pizda(1,2)
11496 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11497 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11499 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11501 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11505 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11507 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11510 C Derivatives in gamma(j-1) or gamma(l-1)
11511 if (l.eq.j+1 .and. l.gt.1) then
11512 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11513 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11514 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11515 vv(1)=pizda(1,1)-pizda(2,2)
11516 vv(2)=pizda(2,1)+pizda(1,2)
11517 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11518 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11519 else if (j.gt.1) then
11520 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11521 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11522 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11523 vv(1)=pizda(1,1)-pizda(2,2)
11524 vv(2)=pizda(2,1)+pizda(1,2)
11525 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11526 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11527 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11529 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11532 C Cartesian derivatives.
11538 if (imat.eq.1) then
11539 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11541 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11544 if (imat.eq.1) then
11545 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11547 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11551 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11553 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11555 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11556 & b1(1,j+1),auxvec(1))
11557 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11559 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11560 & b1(1,l+1),auxvec(1))
11561 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11563 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11565 vv(1)=pizda(1,1)-pizda(2,2)
11566 vv(2)=pizda(2,1)+pizda(1,2)
11567 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11569 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11571 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11574 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11577 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11580 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11582 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11584 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11588 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11590 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11593 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11595 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11603 c----------------------------------------------------------------------------
11604 double precision function eello_turn6(i,jj,kk)
11605 implicit real*8 (a-h,o-z)
11606 include 'DIMENSIONS'
11607 include 'COMMON.IOUNITS'
11608 include 'COMMON.CHAIN'
11609 include 'COMMON.DERIV'
11610 include 'COMMON.INTERACT'
11611 include 'COMMON.CONTACTS'
11612 include 'COMMON.TORSION'
11613 include 'COMMON.VAR'
11614 include 'COMMON.GEO'
11615 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11616 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11618 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11619 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11620 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11621 C the respective energy moment and not to the cluster cumulant.
11630 iti=itype2loc(itype(i))
11631 itk=itype2loc(itype(k))
11632 itk1=itype2loc(itype(k+1))
11633 itl=itype2loc(itype(l))
11634 itj=itype2loc(itype(j))
11635 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11636 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11637 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11642 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11644 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11648 derx_turn(lll,kkk,iii)=0.0d0
11655 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11657 cd write (2,*) 'eello6_5',eello6_5
11659 call transpose2(AEA(1,1,1),auxmat(1,1))
11660 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11661 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11662 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11664 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11665 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11666 s2 = scalar2(b1(1,k),vtemp1(1))
11668 call transpose2(AEA(1,1,2),atemp(1,1))
11669 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11670 call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11671 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11673 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11674 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11675 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11677 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11678 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11679 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11680 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11681 ss13 = scalar2(b1(1,k),vtemp4(1))
11682 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11684 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11690 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11691 C Derivatives in gamma(i+2)
11695 call transpose2(AEA(1,1,1),auxmatd(1,1))
11696 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11697 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11698 call transpose2(AEAderg(1,1,2),atempd(1,1))
11699 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11700 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11702 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11703 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11704 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11710 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11711 C Derivatives in gamma(i+3)
11713 call transpose2(AEA(1,1,1),auxmatd(1,1))
11714 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11715 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11716 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11718 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11719 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11720 s2d = scalar2(b1(1,k),vtemp1d(1))
11722 call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11723 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11725 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11727 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11728 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11729 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11737 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11738 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11740 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11741 & -0.5d0*ekont*(s2d+s12d)
11743 C Derivatives in gamma(i+4)
11744 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11745 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11746 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11748 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11749 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11750 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11758 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11760 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11762 C Derivatives in gamma(i+5)
11764 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11765 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11766 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11768 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11769 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11770 s2d = scalar2(b1(1,k),vtemp1d(1))
11772 call transpose2(AEA(1,1,2),atempd(1,1))
11773 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11774 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11776 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11777 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11779 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11780 ss13d = scalar2(b1(1,k),vtemp4d(1))
11781 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11789 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11790 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11792 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11793 & -0.5d0*ekont*(s2d+s12d)
11795 C Cartesian derivatives
11800 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11801 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11802 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11804 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11805 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11807 s2d = scalar2(b1(1,k),vtemp1d(1))
11809 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11810 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11811 s8d = -(atempd(1,1)+atempd(2,2))*
11812 & scalar2(cc(1,1,l),vtemp2(1))
11814 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11816 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11817 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11824 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11825 & - 0.5d0*(s1d+s2d)
11827 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11831 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11832 & - 0.5d0*(s8d+s12d)
11834 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11843 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11844 & achuj_tempd(1,1))
11845 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11846 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11847 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11848 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11849 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11851 ss13d = scalar2(b1(1,k),vtemp4d(1))
11852 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11853 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11857 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11858 cd & 16*eel_turn6_num
11860 if (j.lt.nres-1) then
11867 if (l.lt.nres-1) then
11875 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11876 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11877 cgrad ghalf=0.5d0*ggg1(ll)
11879 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11880 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11881 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11882 & +ekont*derx_turn(ll,2,1)
11883 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11884 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11885 & +ekont*derx_turn(ll,4,1)
11886 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11887 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11888 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11889 cgrad ghalf=0.5d0*ggg2(ll)
11891 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11892 & +ekont*derx_turn(ll,2,2)
11893 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11894 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11895 & +ekont*derx_turn(ll,4,2)
11896 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11897 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11898 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11903 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11908 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11914 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11919 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11923 cd write (2,*) iii,g_corr6_loc(iii)
11925 eello_turn6=ekont*eel_turn6
11926 cd write (2,*) 'ekont',ekont
11927 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11931 C-----------------------------------------------------------------------------
11932 double precision function scalar(u,v)
11933 !DIR$ INLINEALWAYS scalar
11935 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11938 double precision u(3),v(3)
11939 cd double precision sc
11947 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11950 crc-------------------------------------------------
11951 SUBROUTINE MATVEC2(A1,V1,V2)
11952 !DIR$ INLINEALWAYS MATVEC2
11954 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11957 include 'DIMENSIONS'
11958 double precision A1(2,2),V1(2),V2(2)
11959 double precision vaux1,vaux2
11963 c 3 VI=VI+A1(I,K)*V1(K)
11967 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11968 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11973 C---------------------------------------
11974 SUBROUTINE MATMAT2(A1,A2,A3)
11976 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11979 include 'DIMENSIONS'
11980 double precision A1(2,2),A2(2,2),A3(2,2)
11981 double precision ai3_11,ai3_12,ai3_21,ai3_22
11982 c DIMENSION AI3(2,2)
11986 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11992 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11993 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11994 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11995 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
12003 c-------------------------------------------------------------------------
12004 double precision function scalar2(u,v)
12005 !DIR$ INLINEALWAYS scalar2
12007 double precision u(2),v(2)
12008 double precision sc
12010 scalar2=u(1)*v(1)+u(2)*v(2)
12014 C-----------------------------------------------------------------------------
12016 subroutine transpose2(a,at)
12017 !DIR$ INLINEALWAYS transpose2
12019 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
12022 double precision a(2,2),at(2,2)
12029 c--------------------------------------------------------------------------
12030 subroutine transpose(n,a,at)
12033 double precision a(n,n),at(n,n)
12041 C---------------------------------------------------------------------------
12042 subroutine prodmat3(a1,a2,kk,transp,prod)
12043 !DIR$ INLINEALWAYS prodmat3
12045 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12049 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12051 crc double precision auxmat(2,2),prod_(2,2)
12054 crc call transpose2(kk(1,1),auxmat(1,1))
12055 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12056 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12058 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12059 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12060 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12061 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12062 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12063 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12064 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12065 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12068 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12069 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12071 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12072 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12073 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12074 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12075 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12076 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12077 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12078 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12081 c call transpose2(a2(1,1),a2t(1,1))
12084 crc print *,((prod_(i,j),i=1,2),j=1,2)
12085 crc print *,((prod(i,j),i=1,2),j=1,2)
12089 CCC----------------------------------------------
12090 subroutine Eliptransfer(eliptran)
12092 include 'DIMENSIONS'
12093 include 'COMMON.GEO'
12094 include 'COMMON.VAR'
12095 include 'COMMON.LOCAL'
12096 include 'COMMON.CHAIN'
12097 include 'COMMON.DERIV'
12098 include 'COMMON.NAMES'
12099 include 'COMMON.INTERACT'
12100 include 'COMMON.IOUNITS'
12101 include 'COMMON.CALC'
12102 include 'COMMON.CONTROL'
12103 include 'COMMON.SPLITELE'
12104 include 'COMMON.SBRIDGE'
12105 C this is done by Adasko
12106 C print *,"wchodze"
12107 C structure of box:
12109 C--bordliptop-- buffore starts
12110 C--bufliptop--- here true lipid starts
12112 C--buflipbot--- lipid ends buffore starts
12113 C--bordlipbot--buffore ends
12115 do i=ilip_start,ilip_end
12117 if (itype(i).eq.ntyp1) cycle
12119 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12120 if (positi.le.0.0) positi=positi+boxzsize
12122 C first for peptide groups
12123 c for each residue check if it is in lipid or lipid water border area
12124 if ((positi.gt.bordlipbot)
12125 &.and.(positi.lt.bordliptop)) then
12126 C the energy transfer exist
12127 if (positi.lt.buflipbot) then
12128 C what fraction I am in
12130 & ((positi-bordlipbot)/lipbufthick)
12131 C lipbufthick is thickenes of lipid buffore
12132 sslip=sscalelip(fracinbuf)
12133 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12134 eliptran=eliptran+sslip*pepliptran
12135 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12136 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12137 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12139 C print *,"doing sccale for lower part"
12140 C print *,i,sslip,fracinbuf,ssgradlip
12141 elseif (positi.gt.bufliptop) then
12142 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12143 sslip=sscalelip(fracinbuf)
12144 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12145 eliptran=eliptran+sslip*pepliptran
12146 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12147 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12148 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12149 C print *, "doing sscalefor top part"
12150 C print *,i,sslip,fracinbuf,ssgradlip
12152 eliptran=eliptran+pepliptran
12153 C print *,"I am in true lipid"
12156 C eliptran=elpitran+0.0 ! I am in water
12159 C print *, "nic nie bylo w lipidzie?"
12160 C now multiply all by the peptide group transfer factor
12161 C eliptran=eliptran*pepliptran
12162 C now the same for side chains
12164 do i=ilip_start,ilip_end
12165 if (itype(i).eq.ntyp1) cycle
12166 positi=(mod(c(3,i+nres),boxzsize))
12167 if (positi.le.0) positi=positi+boxzsize
12168 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12169 c for each residue check if it is in lipid or lipid water border area
12170 C respos=mod(c(3,i+nres),boxzsize)
12171 C print *,positi,bordlipbot,buflipbot
12172 if ((positi.gt.bordlipbot)
12173 & .and.(positi.lt.bordliptop)) then
12174 C the energy transfer exist
12175 if (positi.lt.buflipbot) then
12177 & ((positi-bordlipbot)/lipbufthick)
12178 C lipbufthick is thickenes of lipid buffore
12179 sslip=sscalelip(fracinbuf)
12180 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12181 eliptran=eliptran+sslip*liptranene(itype(i))
12182 gliptranx(3,i)=gliptranx(3,i)
12183 &+ssgradlip*liptranene(itype(i))
12184 gliptranc(3,i-1)= gliptranc(3,i-1)
12185 &+ssgradlip*liptranene(itype(i))
12186 C print *,"doing sccale for lower part"
12187 elseif (positi.gt.bufliptop) then
12189 &((bordliptop-positi)/lipbufthick)
12190 sslip=sscalelip(fracinbuf)
12191 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12192 eliptran=eliptran+sslip*liptranene(itype(i))
12193 gliptranx(3,i)=gliptranx(3,i)
12194 &+ssgradlip*liptranene(itype(i))
12195 gliptranc(3,i-1)= gliptranc(3,i-1)
12196 &+ssgradlip*liptranene(itype(i))
12197 C print *, "doing sscalefor top part",sslip,fracinbuf
12199 eliptran=eliptran+liptranene(itype(i))
12200 C print *,"I am in true lipid"
12202 endif ! if in lipid or buffor
12204 C eliptran=elpitran+0.0 ! I am in water
12208 C---------------------------------------------------------
12209 C AFM soubroutine for constant force
12210 subroutine AFMforce(Eafmforce)
12212 include 'DIMENSIONS'
12213 include 'COMMON.GEO'
12214 include 'COMMON.VAR'
12215 include 'COMMON.LOCAL'
12216 include 'COMMON.CHAIN'
12217 include 'COMMON.DERIV'
12218 include 'COMMON.NAMES'
12219 include 'COMMON.INTERACT'
12220 include 'COMMON.IOUNITS'
12221 include 'COMMON.CALC'
12222 include 'COMMON.CONTROL'
12223 include 'COMMON.SPLITELE'
12224 include 'COMMON.SBRIDGE'
12229 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12230 dist=dist+diffafm(i)**2
12233 Eafmforce=-forceAFMconst*(dist-distafminit)
12235 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12236 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12238 C print *,'AFM',Eafmforce
12241 C---------------------------------------------------------
12242 C AFM subroutine with pseudoconstant velocity
12243 subroutine AFMvel(Eafmforce)
12245 include 'DIMENSIONS'
12246 include 'COMMON.GEO'
12247 include 'COMMON.VAR'
12248 include 'COMMON.LOCAL'
12249 include 'COMMON.CHAIN'
12250 include 'COMMON.DERIV'
12251 include 'COMMON.NAMES'
12252 include 'COMMON.INTERACT'
12253 include 'COMMON.IOUNITS'
12254 include 'COMMON.CALC'
12255 include 'COMMON.CONTROL'
12256 include 'COMMON.SPLITELE'
12257 include 'COMMON.SBRIDGE'
12259 C Only for check grad COMMENT if not used for checkgrad
12261 C--------------------------------------------------------
12262 C print *,"wchodze"
12266 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12267 dist=dist+diffafm(i)**2
12270 Eafmforce=0.5d0*forceAFMconst
12271 & *(distafminit+totTafm*velAFMconst-dist)**2
12272 C Eafmforce=-forceAFMconst*(dist-distafminit)
12274 gradafm(i,afmend-1)=-forceAFMconst*
12275 &(distafminit+totTafm*velAFMconst-dist)
12277 gradafm(i,afmbeg-1)=forceAFMconst*
12278 &(distafminit+totTafm*velAFMconst-dist)
12281 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12284 C-----------------------------------------------------------
12285 C first for shielding is setting of function of side-chains
12286 subroutine set_shield_fac
12288 include 'DIMENSIONS'
12289 include 'COMMON.CHAIN'
12290 include 'COMMON.DERIV'
12291 include 'COMMON.IOUNITS'
12292 include 'COMMON.SHIELD'
12293 include 'COMMON.INTERACT'
12294 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12295 double precision div77_81/0.974996043d0/,
12296 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12298 C the vector between center of side_chain and peptide group
12299 double precision pep_side(3),long,side_calf(3),
12300 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12301 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12302 C the line belowe needs to be changed for FGPROC>1
12304 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12306 Cif there two consequtive dummy atoms there is no peptide group between them
12307 C the line below has to be changed for FGPROC>1
12310 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12314 C first lets set vector conecting the ithe side-chain with kth side-chain
12315 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12316 C pep_side(j)=2.0d0
12317 C and vector conecting the side-chain with its proper calfa
12318 side_calf(j)=c(j,k+nres)-c(j,k)
12319 C side_calf(j)=2.0d0
12320 pept_group(j)=c(j,i)-c(j,i+1)
12321 C lets have their lenght
12322 dist_pep_side=pep_side(j)**2+dist_pep_side
12323 dist_side_calf=dist_side_calf+side_calf(j)**2
12324 dist_pept_group=dist_pept_group+pept_group(j)**2
12326 dist_pep_side=dsqrt(dist_pep_side)
12327 dist_pept_group=dsqrt(dist_pept_group)
12328 dist_side_calf=dsqrt(dist_side_calf)
12330 pep_side_norm(j)=pep_side(j)/dist_pep_side
12331 side_calf_norm(j)=dist_side_calf
12333 C now sscale fraction
12334 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12335 C print *,buff_shield,"buff"
12337 if (sh_frac_dist.le.0.0) cycle
12338 C If we reach here it means that this side chain reaches the shielding sphere
12339 C Lets add him to the list for gradient
12340 ishield_list(i)=ishield_list(i)+1
12341 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12342 C this list is essential otherwise problem would be O3
12343 shield_list(ishield_list(i),i)=k
12344 C Lets have the sscale value
12345 if (sh_frac_dist.gt.1.0) then
12346 scale_fac_dist=1.0d0
12348 sh_frac_dist_grad(j)=0.0d0
12351 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12352 & *(2.0*sh_frac_dist-3.0d0)
12353 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12354 & /dist_pep_side/buff_shield*0.5
12355 C remember for the final gradient multiply sh_frac_dist_grad(j)
12356 C for side_chain by factor -2 !
12358 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12359 C print *,"jestem",scale_fac_dist,fac_help_scale,
12360 C & sh_frac_dist_grad(j)
12363 C if ((i.eq.3).and.(k.eq.2)) then
12364 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12368 C this is what is now we have the distance scaling now volume...
12369 short=short_r_sidechain(itype(k))
12370 long=long_r_sidechain(itype(k))
12371 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12374 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12375 C costhet_fac=0.0d0
12377 costhet_grad(j)=costhet_fac*pep_side(j)
12379 C remember for the final gradient multiply costhet_grad(j)
12380 C for side_chain by factor -2 !
12381 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12382 C pep_side0pept_group is vector multiplication
12383 pep_side0pept_group=0.0
12385 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12387 cosalfa=(pep_side0pept_group/
12388 & (dist_pep_side*dist_side_calf))
12389 fac_alfa_sin=1.0-cosalfa**2
12390 fac_alfa_sin=dsqrt(fac_alfa_sin)
12391 rkprim=fac_alfa_sin*(long-short)+short
12393 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12394 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12397 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12398 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12399 &*(long-short)/fac_alfa_sin*cosalfa/
12400 &((dist_pep_side*dist_side_calf))*
12401 &((side_calf(j))-cosalfa*
12402 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12404 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12405 &*(long-short)/fac_alfa_sin*cosalfa
12406 &/((dist_pep_side*dist_side_calf))*
12408 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12411 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12414 C now the gradient...
12415 C grad_shield is gradient of Calfa for peptide groups
12416 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12418 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12419 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12421 grad_shield(j,i)=grad_shield(j,i)
12422 C gradient po skalowaniu
12423 & +(sh_frac_dist_grad(j)
12424 C gradient po costhet
12425 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12426 &-scale_fac_dist*(cosphi_grad_long(j))
12427 &/(1.0-cosphi) )*div77_81
12429 C grad_shield_side is Cbeta sidechain gradient
12430 grad_shield_side(j,ishield_list(i),i)=
12431 & (sh_frac_dist_grad(j)*(-2.0d0)
12432 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12433 & +scale_fac_dist*(cosphi_grad_long(j))
12434 & *2.0d0/(1.0-cosphi))
12435 & *div77_81*VofOverlap
12437 grad_shield_loc(j,ishield_list(i),i)=
12438 & scale_fac_dist*cosphi_grad_loc(j)
12439 & *2.0d0/(1.0-cosphi)
12440 & *div77_81*VofOverlap
12442 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12444 fac_shield(i)=VolumeTotal*div77_81+div4_81
12445 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12449 C--------------------------------------------------------------------------
12450 double precision function tschebyshev(m,n,x,y)
12452 include "DIMENSIONS"
12454 double precision x(n),y,yy(0:maxvar),aux
12455 c Tschebyshev polynomial. Note that the first term is omitted
12456 c m=0: the constant term is included
12457 c m=1: the constant term is not included
12461 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12470 C--------------------------------------------------------------------------
12471 double precision function gradtschebyshev(m,n,x,y)
12473 include "DIMENSIONS"
12475 double precision x(n+1),y,yy(0:maxvar),aux
12476 c Tschebyshev polynomial. Note that the first term is omitted
12477 c m=0: the constant term is included
12478 c m=1: the constant term is not included
12482 yy(i)=2*y*yy(i-1)-yy(i-2)
12486 aux=aux+x(i+1)*yy(i)*(i+1)
12487 C print *, x(i+1),yy(i),i
12489 gradtschebyshev=aux
12492 C------------------------------------------------------------------------
12493 C first for shielding is setting of function of side-chains
12494 subroutine set_shield_fac2
12496 include 'DIMENSIONS'
12497 include 'COMMON.CHAIN'
12498 include 'COMMON.DERIV'
12499 include 'COMMON.IOUNITS'
12500 include 'COMMON.SHIELD'
12501 include 'COMMON.INTERACT'
12502 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12503 double precision div77_81/0.974996043d0/,
12504 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12506 C the vector between center of side_chain and peptide group
12507 double precision pep_side(3),long,side_calf(3),
12508 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12509 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12510 C the line belowe needs to be changed for FGPROC>1
12512 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12514 Cif there two consequtive dummy atoms there is no peptide group between them
12515 C the line below has to be changed for FGPROC>1
12518 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12522 C first lets set vector conecting the ithe side-chain with kth side-chain
12523 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12524 C pep_side(j)=2.0d0
12525 C and vector conecting the side-chain with its proper calfa
12526 side_calf(j)=c(j,k+nres)-c(j,k)
12527 C side_calf(j)=2.0d0
12528 pept_group(j)=c(j,i)-c(j,i+1)
12529 C lets have their lenght
12530 dist_pep_side=pep_side(j)**2+dist_pep_side
12531 dist_side_calf=dist_side_calf+side_calf(j)**2
12532 dist_pept_group=dist_pept_group+pept_group(j)**2
12534 dist_pep_side=dsqrt(dist_pep_side)
12535 dist_pept_group=dsqrt(dist_pept_group)
12536 dist_side_calf=dsqrt(dist_side_calf)
12538 pep_side_norm(j)=pep_side(j)/dist_pep_side
12539 side_calf_norm(j)=dist_side_calf
12541 C now sscale fraction
12542 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12543 C print *,buff_shield,"buff"
12545 if (sh_frac_dist.le.0.0) cycle
12546 C If we reach here it means that this side chain reaches the shielding sphere
12547 C Lets add him to the list for gradient
12548 ishield_list(i)=ishield_list(i)+1
12549 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12550 C this list is essential otherwise problem would be O3
12551 shield_list(ishield_list(i),i)=k
12552 C Lets have the sscale value
12553 if (sh_frac_dist.gt.1.0) then
12554 scale_fac_dist=1.0d0
12556 sh_frac_dist_grad(j)=0.0d0
12559 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12560 & *(2.0d0*sh_frac_dist-3.0d0)
12561 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12562 & /dist_pep_side/buff_shield*0.5d0
12563 C remember for the final gradient multiply sh_frac_dist_grad(j)
12564 C for side_chain by factor -2 !
12566 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12567 C sh_frac_dist_grad(j)=0.0d0
12568 C scale_fac_dist=1.0d0
12569 C print *,"jestem",scale_fac_dist,fac_help_scale,
12570 C & sh_frac_dist_grad(j)
12573 C this is what is now we have the distance scaling now volume...
12574 short=short_r_sidechain(itype(k))
12575 long=long_r_sidechain(itype(k))
12576 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12577 sinthet=short/dist_pep_side*costhet
12581 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12582 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12583 C & -short/dist_pep_side**2/costhet)
12584 C costhet_fac=0.0d0
12586 costhet_grad(j)=costhet_fac*pep_side(j)
12588 C remember for the final gradient multiply costhet_grad(j)
12589 C for side_chain by factor -2 !
12590 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12591 C pep_side0pept_group is vector multiplication
12592 pep_side0pept_group=0.0d0
12594 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12596 cosalfa=(pep_side0pept_group/
12597 & (dist_pep_side*dist_side_calf))
12598 fac_alfa_sin=1.0d0-cosalfa**2
12599 fac_alfa_sin=dsqrt(fac_alfa_sin)
12600 rkprim=fac_alfa_sin*(long-short)+short
12604 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12606 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12607 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12608 & dist_pep_side**2)
12611 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12612 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12613 &*(long-short)/fac_alfa_sin*cosalfa/
12614 &((dist_pep_side*dist_side_calf))*
12615 &((side_calf(j))-cosalfa*
12616 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12617 C cosphi_grad_long(j)=0.0d0
12618 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12619 &*(long-short)/fac_alfa_sin*cosalfa
12620 &/((dist_pep_side*dist_side_calf))*
12622 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12623 C cosphi_grad_loc(j)=0.0d0
12625 C print *,sinphi,sinthet
12626 c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12627 c & VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12628 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12631 C now the gradient...
12633 grad_shield(j,i)=grad_shield(j,i)
12634 C gradient po skalowaniu
12635 & +(sh_frac_dist_grad(j)*VofOverlap
12636 C gradient po costhet
12637 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12638 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12639 & sinphi/sinthet*costhet*costhet_grad(j)
12640 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12642 C grad_shield_side is Cbeta sidechain gradient
12643 grad_shield_side(j,ishield_list(i),i)=
12644 & (sh_frac_dist_grad(j)*(-2.0d0)
12646 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12647 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12648 & sinphi/sinthet*costhet*costhet_grad(j)
12649 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12652 grad_shield_loc(j,ishield_list(i),i)=
12653 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12654 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12655 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12659 c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12661 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12663 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12664 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12665 c & " wshield",wshield
12666 c write(2,*) "TU",rpp(1,1),short,long,buff_shield
12670 C-----------------------------------------------------------------------
12671 C-----------------------------------------------------------
12672 C This subroutine is to mimic the histone like structure but as well can be
12673 C utilizet to nanostructures (infinit) small modification has to be used to
12674 C make it finite (z gradient at the ends has to be changes as well as the x,y
12675 C gradient has to be modified at the ends
12676 C The energy function is Kihara potential
12677 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12678 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12679 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12680 C simple Kihara potential
12681 subroutine calctube(Etube)
12683 include 'DIMENSIONS'
12684 include 'COMMON.GEO'
12685 include 'COMMON.VAR'
12686 include 'COMMON.LOCAL'
12687 include 'COMMON.CHAIN'
12688 include 'COMMON.DERIV'
12689 include 'COMMON.NAMES'
12690 include 'COMMON.INTERACT'
12691 include 'COMMON.IOUNITS'
12692 include 'COMMON.CALC'
12693 include 'COMMON.CONTROL'
12694 include 'COMMON.SPLITELE'
12695 include 'COMMON.SBRIDGE'
12696 double precision tub_r,vectube(3),enetube(maxres*2)
12701 C first we calculate the distance from tube center
12702 C first sugare-phosphate group for NARES this would be peptide group
12705 C lets ommit dummy atoms for now
12706 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12707 C now calculate distance from center of tube and direction vectors
12708 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12709 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12710 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12711 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12712 vectube(1)=vectube(1)-tubecenter(1)
12713 vectube(2)=vectube(2)-tubecenter(2)
12715 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12716 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12718 C as the tube is infinity we do not calculate the Z-vector use of Z
12721 C now calculte the distance
12722 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12723 C now normalize vector
12724 vectube(1)=vectube(1)/tub_r
12725 vectube(2)=vectube(2)/tub_r
12726 C calculte rdiffrence between r and r0
12729 rdiff6=rdiff**6.0d0
12730 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12731 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12732 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12733 C print *,rdiff,rdiff6,pep_aa_tube
12734 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12735 C now we calculate gradient
12736 fac=(-12.0d0*pep_aa_tube/rdiff6+
12737 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12738 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12741 C now direction of gg_tube vector
12743 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12744 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12747 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12749 C Lets not jump over memory as we use many times iti
12751 C lets ommit dummy atoms for now
12753 C in UNRES uncomment the line below as GLY has no side-chain...
12756 vectube(1)=c(1,i+nres)
12757 vectube(1)=mod(vectube(1),boxxsize)
12758 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12759 vectube(2)=c(2,i+nres)
12760 vectube(2)=mod(vectube(2),boxxsize)
12761 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12763 vectube(1)=vectube(1)-tubecenter(1)
12764 vectube(2)=vectube(2)-tubecenter(2)
12766 C as the tube is infinity we do not calculate the Z-vector use of Z
12769 C now calculte the distance
12770 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12771 C now normalize vector
12772 vectube(1)=vectube(1)/tub_r
12773 vectube(2)=vectube(2)/tub_r
12774 C calculte rdiffrence between r and r0
12777 rdiff6=rdiff**6.0d0
12778 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12779 sc_aa_tube=sc_aa_tube_par(iti)
12780 sc_bb_tube=sc_bb_tube_par(iti)
12781 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12782 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12783 C now we calculate gradient
12784 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12785 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12786 C now direction of gg_tube vector
12788 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12789 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12793 Etube=Etube+enetube(i)
12795 C print *,"ETUBE", etube
12798 C TO DO 1) add to total energy
12799 C 2) add to gradient summation
12800 C 3) add reading parameters (AND of course oppening of PARAM file)
12801 C 4) add reading the center of tube
12803 C 6) add to zerograd
12805 C-----------------------------------------------------------------------
12806 C-----------------------------------------------------------
12807 C This subroutine is to mimic the histone like structure but as well can be
12808 C utilizet to nanostructures (infinit) small modification has to be used to
12809 C make it finite (z gradient at the ends has to be changes as well as the x,y
12810 C gradient has to be modified at the ends
12811 C The energy function is Kihara potential
12812 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12813 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12814 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12815 C simple Kihara potential
12816 subroutine calctube2(Etube)
12818 include 'DIMENSIONS'
12819 include 'COMMON.GEO'
12820 include 'COMMON.VAR'
12821 include 'COMMON.LOCAL'
12822 include 'COMMON.CHAIN'
12823 include 'COMMON.DERIV'
12824 include 'COMMON.NAMES'
12825 include 'COMMON.INTERACT'
12826 include 'COMMON.IOUNITS'
12827 include 'COMMON.CALC'
12828 include 'COMMON.CONTROL'
12829 include 'COMMON.SPLITELE'
12830 include 'COMMON.SBRIDGE'
12831 double precision tub_r,vectube(3),enetube(maxres*2)
12836 C first we calculate the distance from tube center
12837 C first sugare-phosphate group for NARES this would be peptide group
12840 C lets ommit dummy atoms for now
12841 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12842 C now calculate distance from center of tube and direction vectors
12843 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12844 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12845 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12846 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12847 vectube(1)=vectube(1)-tubecenter(1)
12848 vectube(2)=vectube(2)-tubecenter(2)
12850 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12851 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12853 C as the tube is infinity we do not calculate the Z-vector use of Z
12856 C now calculte the distance
12857 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12858 C now normalize vector
12859 vectube(1)=vectube(1)/tub_r
12860 vectube(2)=vectube(2)/tub_r
12861 C calculte rdiffrence between r and r0
12864 rdiff6=rdiff**6.0d0
12865 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12866 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12867 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12868 C print *,rdiff,rdiff6,pep_aa_tube
12869 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12870 C now we calculate gradient
12871 fac=(-12.0d0*pep_aa_tube/rdiff6+
12872 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12873 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12876 C now direction of gg_tube vector
12878 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12879 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12882 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12884 C Lets not jump over memory as we use many times iti
12886 C lets ommit dummy atoms for now
12888 C in UNRES uncomment the line below as GLY has no side-chain...
12891 vectube(1)=c(1,i+nres)
12892 vectube(1)=mod(vectube(1),boxxsize)
12893 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12894 vectube(2)=c(2,i+nres)
12895 vectube(2)=mod(vectube(2),boxxsize)
12896 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12898 vectube(1)=vectube(1)-tubecenter(1)
12899 vectube(2)=vectube(2)-tubecenter(2)
12900 C THIS FRAGMENT MAKES TUBE FINITE
12901 positi=(mod(c(3,i+nres),boxzsize))
12902 if (positi.le.0) positi=positi+boxzsize
12903 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12904 c for each residue check if it is in lipid or lipid water border area
12905 C respos=mod(c(3,i+nres),boxzsize)
12906 print *,positi,bordtubebot,buftubebot,bordtubetop
12907 if ((positi.gt.bordtubebot)
12908 & .and.(positi.lt.bordtubetop)) then
12909 C the energy transfer exist
12910 if (positi.lt.buftubebot) then
12912 & ((positi-bordtubebot)/tubebufthick)
12913 C lipbufthick is thickenes of lipid buffore
12914 sstube=sscalelip(fracinbuf)
12915 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12916 print *,ssgradtube, sstube,tubetranene(itype(i))
12917 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12918 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12919 &+ssgradtube*tubetranene(itype(i))
12920 gg_tube(3,i-1)= gg_tube(3,i-1)
12921 &+ssgradtube*tubetranene(itype(i))
12922 C print *,"doing sccale for lower part"
12923 elseif (positi.gt.buftubetop) then
12925 &((bordtubetop-positi)/tubebufthick)
12926 sstube=sscalelip(fracinbuf)
12927 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12928 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12929 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12930 C &+ssgradtube*tubetranene(itype(i))
12931 C gg_tube(3,i-1)= gg_tube(3,i-1)
12932 C &+ssgradtube*tubetranene(itype(i))
12933 C print *, "doing sscalefor top part",sslip,fracinbuf
12937 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12938 C print *,"I am in true lipid"
12944 endif ! if in lipid or buffor
12945 CEND OF FINITE FRAGMENT
12946 C as the tube is infinity we do not calculate the Z-vector use of Z
12949 C now calculte the distance
12950 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12951 C now normalize vector
12952 vectube(1)=vectube(1)/tub_r
12953 vectube(2)=vectube(2)/tub_r
12954 C calculte rdiffrence between r and r0
12957 rdiff6=rdiff**6.0d0
12958 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12959 sc_aa_tube=sc_aa_tube_par(iti)
12960 sc_bb_tube=sc_bb_tube_par(iti)
12961 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12962 & *sstube+enetube(i+nres)
12963 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12964 C now we calculate gradient
12965 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12966 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12967 C now direction of gg_tube vector
12969 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12970 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12972 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12973 &+ssgradtube*enetube(i+nres)/sstube
12974 gg_tube(3,i-1)= gg_tube(3,i-1)
12975 &+ssgradtube*enetube(i+nres)/sstube
12979 Etube=Etube+enetube(i)
12981 C print *,"ETUBE", etube
12984 C TO DO 1) add to total energy
12985 C 2) add to gradient summation
12986 C 3) add reading parameters (AND of course oppening of PARAM file)
12987 C 4) add reading the center of tube
12989 C 6) add to zerograd
12990 c----------------------------------------------------------------------------
12991 subroutine e_saxs(Esaxs_constr)
12993 include 'DIMENSIONS'
12996 include "COMMON.SETUP"
12999 include 'COMMON.SBRIDGE'
13000 include 'COMMON.CHAIN'
13001 include 'COMMON.GEO'
13002 include 'COMMON.DERIV'
13003 include 'COMMON.LOCAL'
13004 include 'COMMON.INTERACT'
13005 include 'COMMON.VAR'
13006 include 'COMMON.IOUNITS'
13007 include 'COMMON.MD'
13009 include 'COMMON.LANGEVIN.lang0'
13011 include 'COMMON.LANGEVIN'
13013 include 'COMMON.CONTROL'
13014 include 'COMMON.SAXS'
13015 include 'COMMON.NAMES'
13016 include 'COMMON.TIME1'
13017 include 'COMMON.FFIELD'
13019 double precision Esaxs_constr
13020 integer i,iint,j,k,l
13021 double precision PgradC(maxSAXS,3,maxres),
13022 & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
13024 double precision PgradC_(maxSAXS,3,maxres),
13025 & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
13027 double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
13028 & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
13029 & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
13030 & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
13031 double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
13032 double precision dist,mygauss,mygaussder
13034 integer llicz,lllicz
13035 double precision time01
13036 c SAXS restraint penalty function
13038 write(iout,*) "------- SAXS penalty function start -------"
13039 write (iout,*) "nsaxs",nsaxs
13040 write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13041 write (iout,*) "Psaxs"
13043 write (iout,'(i5,e15.5)') i, Psaxs(i)
13049 Esaxs_constr = 0.0d0
13054 PgradC(k,l,j)=0.0d0
13055 PgradX(k,l,j)=0.0d0
13060 do i=iatsc_s,iatsc_e
13061 if (itype(i).eq.ntyp1) cycle
13062 do iint=1,nint_gr(i)
13063 do j=istart(i,iint),iend(i,iint)
13064 if (itype(j).eq.ntyp1) cycle
13067 dijCASC=dist(i,j+nres)
13068 dijSCCA=dist(i+nres,j)
13069 dijSCSC=dist(i+nres,j+nres)
13070 sigma2CACA=2.0d0/(pstok**2)
13071 sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13072 sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13073 sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13076 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13077 if (itype(j).ne.10) then
13078 expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13082 if (itype(i).ne.10) then
13083 expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13087 if (itype(i).ne.10 .and. itype(j).ne.10) then
13088 expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13092 Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13094 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13096 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13097 CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13098 SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13099 SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13102 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13103 PgradC(k,l,i) = PgradC(k,l,i)-aux
13104 PgradC(k,l,j) = PgradC(k,l,j)+aux
13106 if (itype(j).ne.10) then
13107 aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13108 PgradC(k,l,i) = PgradC(k,l,i)-aux
13109 PgradC(k,l,j) = PgradC(k,l,j)+aux
13110 PgradX(k,l,j) = PgradX(k,l,j)+aux
13113 if (itype(i).ne.10) then
13114 aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13115 PgradX(k,l,i) = PgradX(k,l,i)-aux
13116 PgradC(k,l,i) = PgradC(k,l,i)-aux
13117 PgradC(k,l,j) = PgradC(k,l,j)+aux
13120 if (itype(i).ne.10 .and. itype(j).ne.10) then
13121 aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13122 PgradC(k,l,i) = PgradC(k,l,i)-aux
13123 PgradC(k,l,j) = PgradC(k,l,j)+aux
13124 PgradX(k,l,i) = PgradX(k,l,i)-aux
13125 PgradX(k,l,j) = PgradX(k,l,j)+aux
13131 sigma2CACA=scal_rad**2*0.25d0/
13132 & (restok(itype(j))**2+restok(itype(i))**2)
13133 c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13134 c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13136 sigmaCACA=dsqrt(sigma2CACA)
13137 threesig=3.0d0/sigmaCACA
13141 if (dabs(dijCACA-dk).ge.threesig) cycle
13144 aux = sigmaCACA*(dijCACA-dk)
13145 expCACA = mygauss(aux)
13146 c if (expcaca.eq.0.0d0) cycle
13147 Pcalc(k) = Pcalc(k)+expCACA
13148 CACAgrad = -sigmaCACA*mygaussder(aux)
13149 c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13151 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13152 PgradC(k,l,i) = PgradC(k,l,i)-aux
13153 PgradC(k,l,j) = PgradC(k,l,j)+aux
13156 c write (iout,*) "i",i," j",j," llicz",llicz
13158 IF (saxs_cutoff.eq.0) THEN
13161 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13162 Pcalc(k) = Pcalc(k)+expCACA
13163 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13165 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13166 PgradC(k,l,i) = PgradC(k,l,i)-aux
13167 PgradC(k,l,j) = PgradC(k,l,j)+aux
13171 rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13174 c write (2,*) "ijk",i,j,k
13175 sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13176 if (sss2.eq.0.0d0) cycle
13177 ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13178 if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13179 & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13180 & 1.0d0/dsqrt(sigma2CACA),rrr,dk,
13182 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13183 Pcalc(k) = Pcalc(k)+expCACA
13185 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13187 CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13188 & ssgrad2*expCACA/sss2
13191 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13192 PgradC(k,l,i) = PgradC(k,l,i)+aux
13193 PgradC(k,l,j) = PgradC(k,l,j)-aux
13203 c time_SAXS=time_SAXS+MPI_Wtime()-time01
13205 c write (iout,*) "lllicz",lllicz
13207 c time01=MPI_Wtime()
13210 if (nfgtasks.gt.1) then
13211 call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13212 & MPI_SUM,FG_COMM,IERR)
13213 c if (fg_rank.eq.king) then
13215 Pcalc(k) = Pcalc_(k)
13218 c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13219 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13220 c if (fg_rank.eq.king) then
13224 c PgradC(k,l,i) = PgradC_(k,l,i)
13230 c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13231 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13232 c if (fg_rank.eq.king) then
13236 c PgradX(k,l,i) = PgradX_(k,l,i)
13246 Cnorm = Cnorm + Pcalc(k)
13249 if (fg_rank.eq.king) then
13251 Esaxs_constr = dlog(Cnorm)-wsaxs0
13253 if (Pcalc(k).gt.0.0d0)
13254 & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13256 write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13260 write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13275 & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13276 auxC1 = auxC1+PgradC(k,l,i)
13278 auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13279 auxX1 = auxX1+PgradX(k,l,i)
13282 gsaxsC(l,i) = auxC - auxC1/Cnorm
13284 gsaxsX(l,i) = auxX - auxX1/Cnorm
13286 c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13287 c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
13288 c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13289 c * " gradX",wsaxs*gsaxsX(l,i)
13293 time_SAXS=time_SAXS+MPI_Wtime()-time01
13296 write (iout,*) "gsaxsc"
13298 write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13306 c----------------------------------------------------------------------------
13307 subroutine e_saxsC(Esaxs_constr)
13309 include 'DIMENSIONS'
13312 include "COMMON.SETUP"
13315 include 'COMMON.SBRIDGE'
13316 include 'COMMON.CHAIN'
13317 include 'COMMON.GEO'
13318 include 'COMMON.DERIV'
13319 include 'COMMON.LOCAL'
13320 include 'COMMON.INTERACT'
13321 include 'COMMON.VAR'
13322 include 'COMMON.IOUNITS'
13323 include 'COMMON.MD'
13325 include 'COMMON.LANGEVIN.lang0'
13327 include 'COMMON.LANGEVIN'
13329 include 'COMMON.CONTROL'
13330 include 'COMMON.SAXS'
13331 include 'COMMON.NAMES'
13332 include 'COMMON.TIME1'
13333 include 'COMMON.FFIELD'
13335 double precision Esaxs_constr
13336 integer i,iint,j,k,l
13337 double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13339 double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13341 double precision dk,dijCASPH,dijSCSPH,
13342 & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13343 & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13345 c SAXS restraint penalty function
13347 write(iout,*) "------- SAXS penalty function start -------"
13348 write (iout,*) "nsaxs",nsaxs
13351 print *,MyRank,"C",i,(C(j,i),j=1,3)
13354 print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13357 Esaxs_constr = 0.0d0
13359 do j=isaxs_start,isaxs_end
13368 if (itype(i).eq.ntyp1) cycle
13372 dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13374 if (itype(i).ne.10) then
13376 dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13379 sigma2CA=2.0d0/pstok**2
13380 sigma2SC=4.0d0/restok(itype(i))**2
13381 expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13382 expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13383 Pcalc = Pcalc+expCASPH+expSCSPH
13385 write(*,*) "processor i j Pcalc",
13386 & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13388 CASPHgrad = sigma2CA*expCASPH
13389 SCSPHgrad = sigma2SC*expSCSPH
13391 aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13392 PgradX(l,i) = PgradX(l,i) + aux
13393 PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13398 gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13399 gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13402 logPtot = logPtot - dlog(Pcalc)
13403 c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13404 c & " logPtot",logPtot
13407 if (nfgtasks.gt.1) then
13408 c write (iout,*) "logPtot before reduction",logPtot
13409 call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13410 & MPI_SUM,king,FG_COMM,IERR)
13412 c write (iout,*) "logPtot after reduction",logPtot
13413 call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13414 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13415 if (fg_rank.eq.king) then
13418 gsaxsC(l,i) = gsaxsC_(l,i)
13422 call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13423 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13424 if (fg_rank.eq.king) then
13427 gsaxsX(l,i) = gsaxsX_(l,i)
13433 Esaxs_constr = logPtot
13436 c----------------------------------------------------------------------------
13437 double precision function sscale2(r,r_cut,r0,rlamb)
13439 double precision r,gamm,r_cut,r0,rlamb,rr
13441 c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13442 c write (2,*) "rr",rr
13443 if(rr.lt.r_cut-rlamb) then
13445 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13446 gamm=(rr-(r_cut-rlamb))/rlamb
13447 sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13453 C-----------------------------------------------------------------------
13454 double precision function sscalgrad2(r,r_cut,r0,rlamb)
13456 double precision r,gamm,r_cut,r0,rlamb,rr
13458 if(rr.lt.r_cut-rlamb) then
13460 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13461 gamm=(rr-(r_cut-rlamb))/rlamb
13463 sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13465 sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb