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'
34 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
35 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
36 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
37 & eliptran,Eafmforce,Etube,
38 & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
39 integer n_corr,n_corr1
41 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
42 c & " nfgtasks",nfgtasks
43 if (nfgtasks.gt.1) then
45 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
46 if (fg_rank.eq.0) then
47 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
48 c print *,"Processor",myrank," BROADCAST iorder"
49 C FG master sets up the WEIGHTS_ array which will be broadcast to the
50 C FG slaves as WEIGHTS array.
73 weights_(28)=wdfa_dist
76 weights_(31)=wdfa_beta
77 C FG Master broadcasts the WEIGHTS_ array
78 call MPI_Bcast(weights_(1),n_ene,
79 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
81 C FG slaves receive the WEIGHTS array
82 call MPI_Bcast(weights(1),n_ene,
83 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
106 wdfa_dist=weights_(28)
107 wdfa_tor=weights_(29)
108 wdfa_nei=weights_(30)
109 wdfa_beta=weights_(31)
111 time_Bcast=time_Bcast+MPI_Wtime()-time00
112 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
113 c call chainbuild_cart
115 if (nfgtasks.gt.1) then
116 call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
118 c write (iout,*) "itime_mat",itime_mat," imatupdate",imatupdate
119 if (mod(itime_mat,imatupdate).eq.0) then
120 call make_SCp_inter_list
121 c write (iout,*) "Finished make_SCp_inter_list"
123 call make_SCSC_inter_list
124 c write (iout,*) "Finished make_SCSC_inter_list"
126 call make_pp_inter_list
127 c write (iout,*) "Finished make_pp_inter_list"
129 call make_pp_vdw_inter_list
130 c write (iout,*) "Finished make_pp_vdw_inter_list"
133 c print *,'Processor',myrank,' calling etotal ipot=',ipot
134 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
136 c if (modecalc.eq.12.or.modecalc.eq.14) then
137 c call int_from_cart1(.false.)
151 C Compute the side-chain and electrostatic interaction energy
154 goto (101,102,103,104,105,106) ipot
155 C Lennard-Jones potential.
157 cd print '(a)','Exit ELJ'
159 C Lennard-Jones-Kihara potential (shifted).
162 C Berne-Pechukas potential (dilated LJ, angular dependence).
165 C Gay-Berne potential (shifted LJ, angular dependence).
167 C print *,"bylem w egb"
169 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
172 C Soft-sphere potential
173 106 call e_softsphere(evdw)
175 C Calculate electrostatic (H-bonding) energy of the main chain.
179 C BARTEK for dfa test!
180 if (wdfa_dist.gt.0) then
185 c print*, 'edfad is finished!', edfadis
186 if (wdfa_tor.gt.0) then
191 c print*, 'edfat is finished!', edfator
192 if (wdfa_nei.gt.0) then
197 c print*, 'edfan is finished!', edfanei
198 if (wdfa_beta.gt.0) then
205 cmc Sep-06: egb takes care of dynamic ss bonds too
207 c if (dyn_ss) call dyn_set_nss
209 c print *,"Processor",myrank," computed USCSC"
215 time_vec=time_vec+MPI_Wtime()-time01
217 C Introduction of shielding effect first for each peptide group
218 C the shielding factor is set this factor is describing how each
219 C peptide group is shielded by side-chains
220 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
221 C write (iout,*) "shield_mode",shield_mode
222 if (shield_mode.eq.1) then
224 else if (shield_mode.eq.2) then
227 c print *,"Processor",myrank," left VEC_AND_DERIV"
230 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
231 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
232 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
233 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
235 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
236 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
237 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
238 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
240 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
249 write (iout,*) "Soft-spheer ELEC potential"
250 c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
254 c time_enecalc=time_enecalc+MPI_Wtime()-time00
256 c print *,"Processor",myrank," computed UELEC"
258 C Calculate excluded-volume interaction energy between peptide groups
263 call escp(evdw2,evdw2_14)
269 c write (iout,*) "Soft-sphere SCP potential"
270 call escp_soft_sphere(evdw2,evdw2_14)
273 c Calculate the bond-stretching energy
277 C Calculate the disulfide-bridge and other energy and the contributions
278 C from other distance constraints.
279 cd write (iout,*) 'Calling EHPB'
281 cd print *,'EHPB exitted succesfully.'
283 C Calculate the virtual-bond-angle energy.
285 if (wang.gt.0d0) then
286 if (tor_mode.eq.0) then
289 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
297 if (with_theta_constr) call etheta_constr(ethetacnstr)
298 c print *,"Processor",myrank," computed UB"
300 C Calculate the SC local energy.
302 C print *,"TU DOCHODZE?"
304 c print *,"Processor",myrank," computed USC"
306 C Calculate the virtual-bond torsional energy.
308 cd print *,'nterm=',nterm
309 C print *,"tor",tor_mode
310 if (wtor.gt.0.0d0) then
311 if (tor_mode.eq.0) then
314 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
322 if (ndih_constr.gt.0) call etor_constr(edihcnstr)
323 c print *,"Processor",myrank," computed Utor"
324 if (constr_homology.ge.1) then
325 call e_modeller(ehomology_constr)
326 c print *,'iset=',iset,'me=',me,ehomology_constr,
327 c & 'Processor',fg_rank,' CG group',kolor,
328 c & ' absolute rank',MyRank
330 ehomology_constr=0.0d0
333 C 6/23/01 Calculate double-torsional energy
335 if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
340 c print *,"Processor",myrank," computed Utord"
342 C 21/5/07 Calculate local sicdechain correlation energy
344 if (wsccor.gt.0.0d0) then
345 call eback_sc_corr(esccor)
350 C print *,"PRZED MULIt"
351 c print *,"Processor",myrank," computed Usccorr"
353 C 12/1/95 Multi-body terms
357 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
358 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
359 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
360 c write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
361 c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
369 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
370 c write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
373 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
374 c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
389 c print *,"Processor",myrank," computed Ucorr"
390 c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
391 if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
392 call e_saxs(Esaxs_constr)
393 c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
394 else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
395 call e_saxsC(Esaxs_constr)
396 c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
401 C If performing constraint dynamics, call the constraint energy
402 C after the equilibration time
403 c if(usampl.and.totT.gt.eq_time) then
404 c write (iout,*) "usampl",usampl
408 call Econstr_back_qlike
416 C 01/27/2015 added by adasko
417 C the energy component below is energy transfer into lipid environment
418 C based on partition function
419 C print *,"przed lipidami"
420 if (wliptran.gt.0) then
421 call Eliptransfer(eliptran)
425 C print *,"za lipidami"
426 if (AFMlog.gt.0) then
427 call AFMforce(Eafmforce)
428 else if (selfguide.gt.0) then
429 call AFMvel(Eafmforce)
433 if (TUBElog.eq.1) then
434 C print *,"just before call"
436 elseif (TUBElog.eq.2) then
437 call calctube2(Etube)
443 time_enecalc=time_enecalc+MPI_Wtime()-time00
445 c print *,"Processor",myrank," computed Uconstr"
454 energia(2)=evdw2-evdw2_14
471 energia(8)=eello_turn3
472 energia(9)=eello_turn4
479 energia(19)=edihcnstr
481 energia(20)=Uconst+Uconst_back
484 energia(23)=Eafmforce
485 energia(24)=ethetacnstr
487 energia(26)=Esaxs_constr
488 energia(27)=ehomology_constr
493 c write (iout,*) "esaxs_constr",energia(26)
494 c Here are the energies showed per procesor if the are more processors
495 c per molecule then we sum it up in sum_energy subroutine
496 c print *," Processor",myrank," calls SUM_ENERGY"
497 call sum_energy(energia,.true.)
498 c write (iout,*) "After sum_energy: esaxs_constr",energia(26)
499 if (dyn_ss) call dyn_set_nss
500 c print *," Processor",myrank," left SUM_ENERGY"
502 time_sumene=time_sumene+MPI_Wtime()-time00
506 c-------------------------------------------------------------------------------
507 subroutine sum_energy(energia,reduce)
513 cMS$ATTRIBUTES C :: proc_proc
519 double precision time00
521 include 'COMMON.SETUP'
522 include 'COMMON.IOUNITS'
523 double precision energia(0:n_ene),enebuff(0:n_ene+1)
524 include 'COMMON.FFIELD'
525 include 'COMMON.DERIV'
526 include 'COMMON.INTERACT'
527 include 'COMMON.SBRIDGE'
528 include 'COMMON.CHAIN'
530 include 'COMMON.CONTROL'
531 include 'COMMON.TIME1'
534 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
535 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
536 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
537 & eliptran,Eafmforce,Etube,
538 & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
539 double precision Uconst,etot
541 if (nfgtasks.gt.1 .and. reduce) then
543 write (iout,*) "energies before REDUCE"
544 call enerprint(energia)
548 enebuff(i)=energia(i)
551 call MPI_Barrier(FG_COMM,IERR)
552 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
554 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
555 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
557 write (iout,*) "energies after REDUCE"
558 call enerprint(energia)
561 time_Reduce=time_Reduce+MPI_Wtime()-time00
563 if (fg_rank.eq.0) then
567 evdw2=energia(2)+energia(18)
583 eello_turn3=energia(8)
584 eello_turn4=energia(9)
591 edihcnstr=energia(19)
596 Eafmforce=energia(23)
597 ethetacnstr=energia(24)
599 esaxs_constr=energia(26)
600 ehomology_constr=energia(27)
606 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
607 & +wang*ebe+wtor*etors+wscloc*escloc
608 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
609 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
610 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
611 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
612 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
613 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
616 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
617 & +wang*ebe+wtor*etors+wscloc*escloc
618 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
619 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
620 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
621 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
623 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
624 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
631 if (isnan(etot).ne.0) energia(0)=1.0d+99
633 if (isnan(etot)) energia(0)=1.0d+99
638 idumm=proc_proc(etot,i)
640 call proc_proc(etot,i)
642 if(i.eq.1)energia(0)=1.0d+99
649 c-------------------------------------------------------------------------------
650 subroutine sum_gradient
656 cMS$ATTRIBUTES C :: proc_proc
662 double precision time00,time01
664 double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
665 & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
666 & ,gloc_scbuf(3,-1:maxres)
667 include 'COMMON.SETUP'
668 include 'COMMON.IOUNITS'
669 include 'COMMON.FFIELD'
670 include 'COMMON.DERIV'
671 include 'COMMON.INTERACT'
672 include 'COMMON.SBRIDGE'
673 include 'COMMON.CHAIN'
675 include 'COMMON.CONTROL'
676 include 'COMMON.TIME1'
677 include 'COMMON.MAXGRAD'
678 include 'COMMON.SCCOR'
679 c include 'COMMON.MD'
680 include 'COMMON.QRESTR'
682 double precision scalar
683 double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
684 &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
685 &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
686 &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
687 &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
693 write (iout,*) "sum_gradient gvdwc, gvdwx"
695 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
696 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
701 write (iout,*) "sum_gradient gsaxsc, gsaxsx"
703 write (iout,'(i3,3e15.5,5x,3e15.5)')
704 & i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
709 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
710 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
711 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
714 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
715 C in virtual-bond-vector coordinates
718 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
720 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
721 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
723 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
725 c write (iout,'(i5,3f10.5,2x,f10.5)')
726 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
728 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
730 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
731 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
737 write (iout,*) "gsaxsc"
739 write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
746 gradbufc(j,i)=wsc*gvdwc(j,i)+
747 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
748 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
749 & wel_loc*gel_loc_long(j,i)+
750 & wcorr*gradcorr_long(j,i)+
751 & wcorr5*gradcorr5_long(j,i)+
752 & wcorr6*gradcorr6_long(j,i)+
753 & wturn6*gcorr6_turn_long(j,i)+
755 & +wliptran*gliptranc(j,i)
757 & +welec*gshieldc(j,i)
758 & +wcorr*gshieldc_ec(j,i)
759 & +wturn3*gshieldc_t3(j,i)
760 & +wturn4*gshieldc_t4(j,i)
761 & +wel_loc*gshieldc_ll(j,i)
762 & +wtube*gg_tube(j,i)
769 gradbufc(j,i)=wsc*gvdwc(j,i)+
770 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
771 & welec*gelc_long(j,i)+
773 & wel_loc*gel_loc_long(j,i)+
774 & wcorr*gradcorr_long(j,i)+
775 & wcorr5*gradcorr5_long(j,i)+
776 & wcorr6*gradcorr6_long(j,i)+
777 & wturn6*gcorr6_turn_long(j,i)+
779 & +wliptran*gliptranc(j,i)
781 & +welec*gshieldc(j,i)
782 & +wcorr*gshieldc_ec(j,i)
783 & +wturn4*gshieldc_t4(j,i)
784 & +wel_loc*gshieldc_ll(j,i)
785 & +wtube*gg_tube(j,i)
792 gradbufc(j,i)=gradbufc(j,i)+
793 & wdfa_dist*gdfad(j,i)+
794 & wdfa_tor*gdfat(j,i)+
795 & wdfa_nei*gdfan(j,i)+
796 & wdfa_beta*gdfab(j,i)
800 write (iout,*) "gradc from gradbufc"
802 write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
807 if (nfgtasks.gt.1) then
810 write (iout,*) "gradbufc before allreduce"
812 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
818 gradbufc_sum(j,i)=gradbufc(j,i)
821 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
822 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
823 c time_reduce=time_reduce+MPI_Wtime()-time00
825 c write (iout,*) "gradbufc_sum after allreduce"
827 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
832 c time_allreduce=time_allreduce+MPI_Wtime()-time00
840 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
841 write (iout,*) (i," jgrad_start",jgrad_start(i),
842 & " jgrad_end ",jgrad_end(i),
843 & i=igrad_start,igrad_end)
846 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
847 c do not parallelize this part.
849 c do i=igrad_start,igrad_end
850 c do j=jgrad_start(i),jgrad_end(i)
852 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
857 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
861 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
865 write (iout,*) "gradbufc after summing"
867 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
874 write (iout,*) "gradbufc"
876 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
882 gradbufc_sum(j,i)=gradbufc(j,i)
887 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
891 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
896 c gradbufc(k,i)=0.0d0
900 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
905 write (iout,*) "gradbufc after summing"
907 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
915 gradbufc(k,nres)=0.0d0
920 C print *,gradbufc(1,13)
921 C print *,welec*gelc(1,13)
922 C print *,wel_loc*gel_loc(1,13)
923 C print *,0.5d0*(wscp*gvdwc_scpp(1,13))
924 C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
925 C print *,wel_loc*gel_loc_long(1,13)
926 C print *,gradafm(1,13),"AFM"
927 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
928 & wel_loc*gel_loc(j,i)+
929 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
930 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
931 & wel_loc*gel_loc_long(j,i)+
932 & wcorr*gradcorr_long(j,i)+
933 & wcorr5*gradcorr5_long(j,i)+
934 & wcorr6*gradcorr6_long(j,i)+
935 & wturn6*gcorr6_turn_long(j,i))+
937 & wcorr*gradcorr(j,i)+
938 & wturn3*gcorr3_turn(j,i)+
939 & wturn4*gcorr4_turn(j,i)+
940 & wcorr5*gradcorr5(j,i)+
941 & wcorr6*gradcorr6(j,i)+
942 & wturn6*gcorr6_turn(j,i)+
943 & wsccor*gsccorc(j,i)
944 & +wscloc*gscloc(j,i)
945 & +wliptran*gliptranc(j,i)
947 & +welec*gshieldc(j,i)
948 & +welec*gshieldc_loc(j,i)
949 & +wcorr*gshieldc_ec(j,i)
950 & +wcorr*gshieldc_loc_ec(j,i)
951 & +wturn3*gshieldc_t3(j,i)
952 & +wturn3*gshieldc_loc_t3(j,i)
953 & +wturn4*gshieldc_t4(j,i)
954 & +wturn4*gshieldc_loc_t4(j,i)
955 & +wel_loc*gshieldc_ll(j,i)
956 & +wel_loc*gshieldc_loc_ll(j,i)
957 & +wtube*gg_tube(j,i)
960 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
961 & wel_loc*gel_loc(j,i)+
962 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
963 & welec*gelc_long(j,i)+
964 & wel_loc*gel_loc_long(j,i)+
965 & wcorr*gcorr_long(j,i)+
966 & wcorr5*gradcorr5_long(j,i)+
967 & wcorr6*gradcorr6_long(j,i)+
968 & wturn6*gcorr6_turn_long(j,i))+
970 & wcorr*gradcorr(j,i)+
971 & wturn3*gcorr3_turn(j,i)+
972 & wturn4*gcorr4_turn(j,i)+
973 & wcorr5*gradcorr5(j,i)+
974 & wcorr6*gradcorr6(j,i)+
975 & wturn6*gcorr6_turn(j,i)+
976 & wsccor*gsccorc(j,i)
977 & +wscloc*gscloc(j,i)
978 & +wliptran*gliptranc(j,i)
980 & +welec*gshieldc(j,i)
981 & +welec*gshieldc_loc(j,i)
982 & +wcorr*gshieldc_ec(j,i)
983 & +wcorr*gshieldc_loc_ec(j,i)
984 & +wturn3*gshieldc_t3(j,i)
985 & +wturn3*gshieldc_loc_t3(j,i)
986 & +wturn4*gshieldc_t4(j,i)
987 & +wturn4*gshieldc_loc_t4(j,i)
988 & +wel_loc*gshieldc_ll(j,i)
989 & +wel_loc*gshieldc_loc_ll(j,i)
990 & +wtube*gg_tube(j,i)
994 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
996 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
997 & wsccor*gsccorx(j,i)
998 & +wscloc*gsclocx(j,i)
999 & +wliptran*gliptranx(j,i)
1000 & +welec*gshieldx(j,i)
1001 & +wcorr*gshieldx_ec(j,i)
1002 & +wturn3*gshieldx_t3(j,i)
1003 & +wturn4*gshieldx_t4(j,i)
1004 & +wel_loc*gshieldx_ll(j,i)
1005 & +wtube*gg_tube_sc(j,i)
1006 & +wsaxs*gsaxsx(j,i)
1012 if (constr_homology.gt.0) then
1015 gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
1016 gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
1021 write (iout,*) "gradc gradx gloc after adding"
1023 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1024 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1028 write (iout,*) "gloc before adding corr"
1030 write (iout,*) i,gloc(i,icg)
1034 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
1035 & +wcorr5*g_corr5_loc(i)
1036 & +wcorr6*g_corr6_loc(i)
1037 & +wturn4*gel_loc_turn4(i)
1038 & +wturn3*gel_loc_turn3(i)
1039 & +wturn6*gel_loc_turn6(i)
1040 & +wel_loc*gel_loc_loc(i)
1043 write (iout,*) "gloc after adding corr"
1045 write (iout,*) i,gloc(i,icg)
1049 if (nfgtasks.gt.1) then
1052 gradbufc(j,i)=gradc(j,i,icg)
1053 gradbufx(j,i)=gradx(j,i,icg)
1057 glocbuf(i)=gloc(i,icg)
1061 write (iout,*) "gloc_sc before reduce"
1064 write (iout,*) i,j,gloc_sc(j,i,icg)
1071 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1075 call MPI_Barrier(FG_COMM,IERR)
1076 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1078 call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1079 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1080 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1081 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1082 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1083 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1084 time_reduce=time_reduce+MPI_Wtime()-time00
1085 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1086 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1087 time_reduce=time_reduce+MPI_Wtime()-time00
1089 write (iout,*) "gradc after reduce"
1092 write (iout,*) i,j,gradc(j,i,icg)
1097 write (iout,*) "gloc_sc after reduce"
1100 write (iout,*) i,j,gloc_sc(j,i,icg)
1105 write (iout,*) "gloc after reduce"
1107 write (iout,*) i,gloc(i,icg)
1112 if (gnorm_check) then
1114 c Compute the maximum elements of the gradient
1124 gcorr3_turn_max=0.0d0
1125 gcorr4_turn_max=0.0d0
1128 gcorr6_turn_max=0.0d0
1138 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1139 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1140 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1141 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1142 & gvdwc_scp_max=gvdwc_scp_norm
1143 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1144 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1145 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1146 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1147 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1148 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1149 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1150 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1151 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1152 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1153 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1154 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1155 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1156 & gcorr3_turn(1,i)))
1157 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1158 & gcorr3_turn_max=gcorr3_turn_norm
1159 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1160 & gcorr4_turn(1,i)))
1161 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1162 & gcorr4_turn_max=gcorr4_turn_norm
1163 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1164 if (gradcorr5_norm.gt.gradcorr5_max)
1165 & gradcorr5_max=gradcorr5_norm
1166 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1167 if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1168 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1169 & gcorr6_turn(1,i)))
1170 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1171 & gcorr6_turn_max=gcorr6_turn_norm
1172 gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1173 if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1174 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1175 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1176 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1177 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1178 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1179 if (gradx_scp_norm.gt.gradx_scp_max)
1180 & gradx_scp_max=gradx_scp_norm
1181 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1182 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1183 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1184 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1185 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1186 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1187 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1188 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1191 #if (defined AIX || defined CRAY)
1192 open(istat,file=statname,position="append")
1194 open(istat,file=statname,access="append")
1196 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1197 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1198 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1199 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1200 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1201 & gsccorrx_max,gsclocx_max
1203 if (gvdwc_max.gt.1.0d4) then
1204 write (iout,*) "gvdwc gvdwx gradb gradbx"
1206 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1207 & gradb(j,i),gradbx(j,i),j=1,3)
1209 call pdbout(0.0d0,'cipiszcze',iout)
1215 write (iout,*) "gradc gradx gloc"
1217 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1218 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1222 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1226 c-------------------------------------------------------------------------------
1227 subroutine rescale_weights(t_bath)
1233 include 'DIMENSIONS'
1234 include 'COMMON.IOUNITS'
1235 include 'COMMON.FFIELD'
1236 include 'COMMON.SBRIDGE'
1237 include 'COMMON.CONTROL'
1238 double precision t_bath
1239 double precision facT,facT2,facT3,facT4,facT5
1240 double precision kfac /2.4d0/
1241 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1243 c facT=2*temp0/(t_bath+temp0)
1244 if (rescale_mode.eq.0) then
1250 else if (rescale_mode.eq.1) then
1251 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1252 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1253 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1254 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1255 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1256 else if (rescale_mode.eq.2) then
1262 facT=licznik/dlog(dexp(x)+dexp(-x))
1263 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1264 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1265 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1266 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1268 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1269 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1271 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1275 if (shield_mode.gt.0) then
1276 wscp=weights(2)*fact
1278 wvdwpp=weights(16)*fact
1280 welec=weights(3)*fact
1281 wcorr=weights(4)*fact3
1282 wcorr5=weights(5)*fact4
1283 wcorr6=weights(6)*fact5
1284 wel_loc=weights(7)*fact2
1285 wturn3=weights(8)*fact2
1286 wturn4=weights(9)*fact3
1287 wturn6=weights(10)*fact5
1288 wtor=weights(13)*fact
1289 wtor_d=weights(14)*fact2
1290 wsccor=weights(21)*fact
1291 if (scale_umb) wumb=t_bath/temp0
1292 c write (iout,*) "scale_umb",scale_umb
1293 c write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1297 C------------------------------------------------------------------------
1298 subroutine enerprint(energia)
1300 include 'DIMENSIONS'
1301 include 'COMMON.IOUNITS'
1302 include 'COMMON.FFIELD'
1303 include 'COMMON.SBRIDGE'
1304 include 'COMMON.QRESTR'
1305 double precision energia(0:n_ene)
1306 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1307 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1308 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1310 & eliptran,Eafmforce,Etube,
1311 & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1316 evdw2=energia(2)+energia(18)
1328 eello_turn3=energia(8)
1329 eello_turn4=energia(9)
1330 eello_turn6=energia(10)
1336 edihcnstr=energia(19)
1340 eliptran=energia(22)
1341 Eafmforce=energia(23)
1342 ethetacnstr=energia(24)
1345 ehomology_constr=energia(27)
1347 edfadis = energia(28)
1348 edfator = energia(29)
1349 edfanei = energia(30)
1350 edfabet = energia(31)
1352 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1353 & estr,wbond,ebe,wang,
1354 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1357 & ecorr5,wcorr5,ecorr6,wcorr6,
1359 & eel_loc,wel_loc,eello_turn3,wturn3,
1360 & eello_turn4,wturn4,
1362 & eello_turn6,wturn6,
1364 & esccor,wsccor,edihcnstr,
1365 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1366 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1367 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1368 & edfabet,wdfa_beta,
1370 10 format (/'Virtual-chain energies:'//
1371 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1372 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1373 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1374 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1375 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1376 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1377 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1378 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1379 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1380 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1381 & ' (SS bridges & dist. cnstr.)'/
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)'/
1387 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1388 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1389 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1391 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1393 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1394 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1395 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1396 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1397 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1398 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1399 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1400 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1401 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1402 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1403 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1404 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1405 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1406 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1407 & 'ETOT= ',1pE16.6,' (total)')
1410 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1411 & estr,wbond,ebe,wang,
1412 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1415 & ecorr5,wcorr5,ecorr6,wcorr6,
1417 & eel_loc,wel_loc,eello_turn3,wturn3,
1418 & eello_turn4,wturn4,
1420 & eello_turn6,wturn6,
1422 & esccor,wsccor,edihcnstr,
1423 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1424 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1425 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1426 & edfabet,wdfa_beta,
1428 10 format (/'Virtual-chain energies:'//
1429 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1430 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1431 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1432 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1433 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1434 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1435 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1436 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1437 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1438 & ' (SS bridges & dist. restr.)'/
1440 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1441 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1442 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1444 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1445 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1446 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1448 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1450 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1451 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1452 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1453 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1454 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1455 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1456 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1457 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1458 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1459 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1460 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1461 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1462 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1463 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1464 & 'ETOT= ',1pE16.6,' (total)')
1468 C-----------------------------------------------------------------------
1469 subroutine elj(evdw)
1471 C This subroutine calculates the interaction energy of nonbonded side chains
1472 C assuming the LJ potential of interaction.
1475 double precision accur
1476 include 'DIMENSIONS'
1477 parameter (accur=1.0d-10)
1478 include 'COMMON.GEO'
1479 include 'COMMON.VAR'
1480 include 'COMMON.LOCAL'
1481 include 'COMMON.CHAIN'
1482 include 'COMMON.DERIV'
1483 include 'COMMON.INTERACT'
1484 include 'COMMON.TORSION'
1485 include 'COMMON.SBRIDGE'
1486 include 'COMMON.NAMES'
1487 include 'COMMON.IOUNITS'
1488 include 'COMMON.SPLITELE'
1490 include 'COMMON.CONTACTS'
1491 include 'COMMON.CONTMAT'
1493 double precision gg(3)
1494 double precision evdw,evdwij
1495 integer i,j,k,itypi,itypj,itypi1,num_conti,iint,ikont
1496 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1497 & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1498 double precision fcont,fprimcont
1499 double precision sscale,sscagrad
1500 double precision boxshift
1501 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1503 c do i=iatsc_s,iatsc_e
1504 do ikont=g_listscsc_start,g_listscsc_end
1505 i=newcontlisti(ikont)
1506 j=newcontlistj(ikont)
1507 itypi=iabs(itype(i))
1508 if (itypi.eq.ntyp1) cycle
1509 itypi1=iabs(itype(i+1))
1513 call to_box(xi,yi,zi)
1517 C Calculate SC interaction energy.
1519 c do iint=1,nint_gr(i)
1520 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1521 cd & 'iend=',iend(i,iint)
1522 c do j=istart(i,iint),iend(i,iint)
1523 itypj=iabs(itype(j))
1524 if (itypj.eq.ntyp1) cycle
1528 call to_box(xj,yj,zj)
1529 xj=boxshift(xj-xi,boxxsize)
1530 yj=boxshift(yj-yi,boxysize)
1531 zj=boxshift(zj-zi,boxzsize)
1532 C Change 12/1/95 to calculate four-body interactions
1533 rij=xj*xj+yj*yj+zj*zj
1536 sss1=sscale(sqrij,r_cut_int)
1537 if (sss1.eq.0.0d0) cycle
1538 sssgrad1=sscagrad(sqrij,r_cut_int)
1540 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1541 eps0ij=eps(itypi,itypj)
1543 C have you changed here?
1547 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1548 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1549 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1550 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1551 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1552 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1553 evdw=evdw+sss1*evdwij
1555 C Calculate the components of the gradient in DC and X
1557 fac=-rrij*(e1+evdwij)*sss1
1558 & +evdwij*sssgrad1/sqrij/expon
1563 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1564 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1565 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1566 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1570 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1575 C 12/1/95, revised on 5/20/97
1577 C Calculate the contact function. The ith column of the array JCONT will
1578 C contain the numbers of atoms that make contacts with the atom I (of numbers
1579 C greater than I). The arrays FACONT and GACONT will contain the values of
1580 C the contact function and its derivative.
1582 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1583 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1584 C Uncomment next line, if the correlation interactions are contact function only
1585 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1587 sigij=sigma(itypi,itypj)
1588 r0ij=rs0(itypi,itypj)
1590 C Check whether the SC's are not too far to make a contact.
1593 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1594 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1596 if (fcont.gt.0.0D0) then
1597 C If the SC-SC distance if close to sigma, apply spline.
1598 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1599 cAdam & fcont1,fprimcont1)
1600 cAdam fcont1=1.0d0-fcont1
1601 cAdam if (fcont1.gt.0.0d0) then
1602 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1603 cAdam fcont=fcont*fcont1
1605 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1606 cga eps0ij=1.0d0/dsqrt(eps0ij)
1608 cga gg(k)=gg(k)*eps0ij
1610 cga eps0ij=-evdwij*eps0ij
1611 C Uncomment for AL's type of SC correlation interactions.
1612 cadam eps0ij=-evdwij
1613 num_conti=num_conti+1
1614 jcont(num_conti,i)=j
1615 facont(num_conti,i)=fcont*eps0ij
1616 fprimcont=eps0ij*fprimcont/rij
1618 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1619 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1620 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1621 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1622 gacont(1,num_conti,i)=-fprimcont*xj
1623 gacont(2,num_conti,i)=-fprimcont*yj
1624 gacont(3,num_conti,i)=-fprimcont*zj
1625 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1626 cd write (iout,'(2i3,3f10.5)')
1627 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1635 num_cont(i)=num_conti
1640 gvdwc(j,i)=expon*gvdwc(j,i)
1641 gvdwx(j,i)=expon*gvdwx(j,i)
1644 C******************************************************************************
1648 C To save time, the factor of EXPON has been extracted from ALL components
1649 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1652 C******************************************************************************
1655 C-----------------------------------------------------------------------------
1656 subroutine eljk(evdw)
1658 C This subroutine calculates the interaction energy of nonbonded side chains
1659 C assuming the LJK potential of interaction.
1662 include 'DIMENSIONS'
1663 include 'COMMON.GEO'
1664 include 'COMMON.VAR'
1665 include 'COMMON.LOCAL'
1666 include 'COMMON.CHAIN'
1667 include 'COMMON.DERIV'
1668 include 'COMMON.INTERACT'
1669 include 'COMMON.IOUNITS'
1670 include 'COMMON.NAMES'
1671 include 'COMMON.SPLITELE'
1672 double precision gg(3)
1673 double precision evdw,evdwij
1674 integer i,j,k,itypi,itypj,itypi1,iint,ikont
1675 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1676 & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1678 double precision sscale,sscagrad
1679 double precision boxshift
1680 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1682 c do i=iatsc_s,iatsc_e
1683 do ikont=g_listscsc_start,g_listscsc_end
1684 i=newcontlisti(ikont)
1685 j=newcontlistj(ikont)
1686 itypi=iabs(itype(i))
1687 if (itypi.eq.ntyp1) cycle
1688 itypi1=iabs(itype(i+1))
1692 call to_box(xi,yi,zi)
1694 C Calculate SC interaction energy.
1696 c do iint=1,nint_gr(i)
1697 c do j=istart(i,iint),iend(i,iint)
1698 itypj=iabs(itype(j))
1699 if (itypj.eq.ntyp1) cycle
1703 call to_box(xj,yj,zj)
1704 xj=boxshift(xj-xi,boxxsize)
1705 yj=boxshift(yj-yi,boxysize)
1706 zj=boxshift(zj-zi,boxzsize)
1707 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1708 fac_augm=rrij**expon
1709 e_augm=augm(itypi,itypj)*fac_augm
1710 r_inv_ij=dsqrt(rrij)
1712 sss1=sscale(rij,r_cut_int)
1713 if (sss1.eq.0.0d0) cycle
1714 sssgrad1=sscagrad(rij,r_cut_int)
1715 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1716 fac=r_shift_inv**expon
1717 C have you changed here?
1721 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1722 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1723 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1724 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1725 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1726 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1727 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1728 evdw=evdw+evdwij*sss1
1730 C Calculate the components of the gradient in DC and X
1732 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1733 & +evdwij*sssgrad1*r_inv_ij/expon
1738 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1739 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1740 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1741 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1745 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1753 gvdwc(j,i)=expon*gvdwc(j,i)
1754 gvdwx(j,i)=expon*gvdwx(j,i)
1759 C-----------------------------------------------------------------------------
1760 subroutine ebp(evdw)
1762 C This subroutine calculates the interaction energy of nonbonded side chains
1763 C assuming the Berne-Pechukas potential of interaction.
1766 include 'DIMENSIONS'
1767 include 'COMMON.GEO'
1768 include 'COMMON.VAR'
1769 include 'COMMON.LOCAL'
1770 include 'COMMON.CHAIN'
1771 include 'COMMON.DERIV'
1772 include 'COMMON.NAMES'
1773 include 'COMMON.INTERACT'
1774 include 'COMMON.IOUNITS'
1775 include 'COMMON.CALC'
1776 include 'COMMON.SPLITELE'
1778 common /srutu/ icall
1779 double precision evdw
1780 integer itypi,itypj,itypi1,iint,ind,ikont
1781 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1783 double precision sscale,sscagrad
1784 double precision boxshift
1785 c double precision rrsave(maxdim)
1788 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1790 c if (icall.eq.0) then
1796 c do i=iatsc_s,iatsc_e
1797 do ikont=g_listscsc_start,g_listscsc_end
1798 i=newcontlisti(ikont)
1799 j=newcontlistj(ikont)
1800 itypi=iabs(itype(i))
1801 if (itypi.eq.ntyp1) cycle
1802 itypi1=iabs(itype(i+1))
1806 call to_box(xi,yi,zi)
1807 dxi=dc_norm(1,nres+i)
1808 dyi=dc_norm(2,nres+i)
1809 dzi=dc_norm(3,nres+i)
1810 c dsci_inv=dsc_inv(itypi)
1811 dsci_inv=vbld_inv(i+nres)
1813 C Calculate SC interaction energy.
1815 c do iint=1,nint_gr(i)
1816 c do j=istart(i,iint),iend(i,iint)
1818 itypj=iabs(itype(j))
1819 if (itypj.eq.ntyp1) cycle
1820 c dscj_inv=dsc_inv(itypj)
1821 dscj_inv=vbld_inv(j+nres)
1822 chi1=chi(itypi,itypj)
1823 chi2=chi(itypj,itypi)
1830 alf12=0.5D0*(alf1+alf2)
1831 C For diagnostics only!!!
1844 call to_box(xj,yj,zj)
1845 xj=boxshift(xj-xi,boxxsize)
1846 yj=boxshift(yj-yi,boxysize)
1847 zj=boxshift(zj-zi,boxzsize)
1848 dxj=dc_norm(1,nres+j)
1849 dyj=dc_norm(2,nres+j)
1850 dzj=dc_norm(3,nres+j)
1851 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1852 cd if (icall.eq.0) then
1858 sss1=sscale(1.0d0/rij,r_cut_int)
1859 if (sss1.eq.0.0d0) cycle
1860 sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1861 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1863 C Calculate whole angle-dependent part of epsilon and contributions
1864 C to its derivatives
1865 C have you changed here?
1866 fac=(rrij*sigsq)**expon2
1869 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1870 eps2der=evdwij*eps3rt
1871 eps3der=evdwij*eps2rt
1872 evdwij=evdwij*eps2rt*eps3rt
1873 evdw=evdw+sss1*evdwij
1875 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1877 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1878 cd & restyp(itypi),i,restyp(itypj),j,
1879 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1880 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1881 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1884 C Calculate gradient components.
1885 e1=e1*eps1*eps2rt**2*eps3rt**2
1886 fac=-expon*(e1+evdwij)
1889 & +evdwij*sssgrad1/sss1*rij
1890 C Calculate radial part of the gradient
1894 C Calculate the angular part of the gradient and sum add the contributions
1895 C to the appropriate components of the Cartesian gradient.
1903 C-----------------------------------------------------------------------------
1904 subroutine egb(evdw)
1906 C This subroutine calculates the interaction energy of nonbonded side chains
1907 C assuming the Gay-Berne potential of interaction.
1910 include 'DIMENSIONS'
1911 include 'COMMON.GEO'
1912 include 'COMMON.VAR'
1913 include 'COMMON.LOCAL'
1914 include 'COMMON.CHAIN'
1915 include 'COMMON.DERIV'
1916 include 'COMMON.NAMES'
1917 include 'COMMON.INTERACT'
1918 include 'COMMON.IOUNITS'
1919 include 'COMMON.CALC'
1920 include 'COMMON.CONTROL'
1921 include 'COMMON.SPLITELE'
1922 include 'COMMON.SBRIDGE'
1924 double precision evdw
1925 integer itypi,itypj,itypi1,iint,ind,ikont
1926 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1927 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1928 & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip
1929 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1930 double precision boxshift
1932 ccccc energy_dec=.false.
1933 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1936 c if (icall.eq.0) lprn=.false.
1938 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1939 C we have the original box)
1943 c do i=iatsc_s,iatsc_e
1944 do ikont=g_listscsc_start,g_listscsc_end
1945 i=newcontlisti(ikont)
1946 j=newcontlistj(ikont)
1947 itypi=iabs(itype(i))
1948 if (itypi.eq.ntyp1) cycle
1949 itypi1=iabs(itype(i+1))
1953 call to_box(xi,yi,zi)
1954 C define scaling factor for lipids
1956 C if (positi.le.0) positi=positi+boxzsize
1958 C first for peptide groups
1959 c for each residue check if it is in lipid or lipid water border area
1960 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1961 C xi=xi+xshift*boxxsize
1962 C yi=yi+yshift*boxysize
1963 C zi=zi+zshift*boxzsize
1965 dxi=dc_norm(1,nres+i)
1966 dyi=dc_norm(2,nres+i)
1967 dzi=dc_norm(3,nres+i)
1968 c dsci_inv=dsc_inv(itypi)
1969 dsci_inv=vbld_inv(i+nres)
1970 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1971 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1973 C Calculate SC interaction energy.
1975 c do iint=1,nint_gr(i)
1976 c do j=istart(i,iint),iend(i,iint)
1977 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1979 c write(iout,*) "PRZED ZWYKLE", evdwij
1980 call dyn_ssbond_ene(i,j,evdwij)
1981 c write(iout,*) "PO ZWYKLE", evdwij
1984 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1985 & 'evdw',i,j,evdwij,' ss'
1986 C triple bond artifac removal
1987 do k=j+1,iend(i,iint)
1988 C search over all next residues
1989 if (dyn_ss_mask(k)) then
1990 C check if they are cysteins
1991 C write(iout,*) 'k=',k
1993 c write(iout,*) "PRZED TRI", evdwij
1994 evdwij_przed_tri=evdwij
1995 call triple_ssbond_ene(i,j,k,evdwij)
1996 c if(evdwij_przed_tri.ne.evdwij) then
1997 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
2000 c write(iout,*) "PO TRI", evdwij
2001 C call the energy function that removes the artifical triple disulfide
2002 C bond the soubroutine is located in ssMD.F
2004 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2005 & 'evdw',i,j,evdwij,'tss'
2006 endif!dyn_ss_mask(k)
2010 itypj=iabs(itype(j))
2011 if (itypj.eq.ntyp1) cycle
2012 c dscj_inv=dsc_inv(itypj)
2013 dscj_inv=vbld_inv(j+nres)
2014 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2015 c & 1.0d0/vbld(j+nres)
2016 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2017 sig0ij=sigma(itypi,itypj)
2018 chi1=chi(itypi,itypj)
2019 chi2=chi(itypj,itypi)
2026 alf12=0.5D0*(alf1+alf2)
2027 C For diagnostics only!!!
2040 call to_box(xj,yj,zj)
2041 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2042 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2043 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2044 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2045 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2046 C write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2047 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2048 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2049 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2050 C print *,sslipi,sslipj,bordlipbot,zi,zj
2051 xj=boxshift(xj-xi,boxxsize)
2052 yj=boxshift(yj-yi,boxysize)
2053 zj=boxshift(zj-zi,boxzsize)
2054 dxj=dc_norm(1,nres+j)
2055 dyj=dc_norm(2,nres+j)
2056 dzj=dc_norm(3,nres+j)
2060 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2061 c write (iout,*) "j",j," dc_norm",
2062 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2063 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2065 sss=sscale(1.0d0/rij,r_cut_int)
2066 c write (iout,'(a7,4f8.3)')
2067 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2068 if (sss.eq.0.0d0) cycle
2069 sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2070 C Calculate angle-dependent terms of energy and contributions to their
2074 sig=sig0ij*dsqrt(sigsq)
2075 rij_shift=1.0D0/rij-sig+sig0ij
2077 c & write (iout,*) "rij",1.0d0/rij," rij_shift",rij_shift,
2078 c & " sig",sig," sig0ij",sig0ij
2079 c for diagnostics; uncomment
2080 c rij_shift=1.2*sig0ij
2081 C I hate to put IF's in the loops, but here don't have another choice!!!!
2082 if (rij_shift.le.0.0D0) then
2084 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2085 cd & restyp(itypi),i,restyp(itypj),j,
2086 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2090 c---------------------------------------------------------------
2091 rij_shift=1.0D0/rij_shift
2092 fac=rij_shift**expon
2093 C here to start with
2098 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2099 eps2der=evdwij*eps3rt
2100 eps3der=evdwij*eps2rt
2101 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2102 C &((sslipi+sslipj)/2.0d0+
2103 C &(2.0d0-sslipi-sslipj)/2.0d0)
2104 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2105 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2106 evdwij=evdwij*eps2rt*eps3rt
2107 evdw=evdw+evdwij*sss
2109 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2111 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2112 & restyp(itypi),i,restyp(itypj),j,
2113 & epsi,sigm,chi1,chi2,chip1,chip2,
2114 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2115 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2119 if (energy_dec) write (iout,'(a,2i5,2f10.5,e15.5)')
2120 & 'r sss evdw',i,j,1.0d0/rij,sss,evdwij
2122 C Calculate gradient components.
2123 e1=e1*eps1*eps2rt**2*eps3rt**2
2124 fac=-expon*(e1+evdwij)*rij_shift
2127 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
2128 c & evdwij,fac,sigma(itypi,itypj),expon
2129 fac=fac+evdwij*sssgrad/sss*rij
2131 C Calculate the radial part of the gradient
2132 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2133 & *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2134 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2135 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2136 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2137 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2143 C Calculate angular part of the gradient.
2144 c call sc_grad_scale(sss)
2153 c write (iout,*) "Number of loop steps in EGB:",ind
2154 cccc energy_dec=.false.
2157 C-----------------------------------------------------------------------------
2158 subroutine egbv(evdw)
2160 C This subroutine calculates the interaction energy of nonbonded side chains
2161 C assuming the Gay-Berne-Vorobjev potential of interaction.
2164 include 'DIMENSIONS'
2165 include 'COMMON.GEO'
2166 include 'COMMON.VAR'
2167 include 'COMMON.LOCAL'
2168 include 'COMMON.CHAIN'
2169 include 'COMMON.DERIV'
2170 include 'COMMON.NAMES'
2171 include 'COMMON.INTERACT'
2172 include 'COMMON.IOUNITS'
2173 include 'COMMON.CALC'
2174 include 'COMMON.SPLITELE'
2175 double precision boxshift
2177 common /srutu/ icall
2179 double precision evdw
2180 integer itypi,itypj,itypi1,iint,ind,ikont
2181 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2182 & xi,yi,zi,fac_augm,e_augm
2183 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2184 & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip,sssgrad1
2185 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2187 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2190 c if (icall.eq.0) lprn=.true.
2192 c do i=iatsc_s,iatsc_e
2193 do ikont=g_listscsc_start,g_listscsc_end
2194 i=newcontlisti(ikont)
2195 j=newcontlistj(ikont)
2196 itypi=iabs(itype(i))
2197 if (itypi.eq.ntyp1) cycle
2198 itypi1=iabs(itype(i+1))
2202 call to_box(xi,yi,zi)
2203 C define scaling factor for lipids
2205 C if (positi.le.0) positi=positi+boxzsize
2207 C first for peptide groups
2208 c for each residue check if it is in lipid or lipid water border area
2209 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2210 dxi=dc_norm(1,nres+i)
2211 dyi=dc_norm(2,nres+i)
2212 dzi=dc_norm(3,nres+i)
2213 c dsci_inv=dsc_inv(itypi)
2214 dsci_inv=vbld_inv(i+nres)
2216 C Calculate SC interaction energy.
2218 c do iint=1,nint_gr(i)
2219 c do j=istart(i,iint),iend(i,iint)
2221 itypj=iabs(itype(j))
2222 if (itypj.eq.ntyp1) cycle
2223 c dscj_inv=dsc_inv(itypj)
2224 dscj_inv=vbld_inv(j+nres)
2225 sig0ij=sigma(itypi,itypj)
2226 r0ij=r0(itypi,itypj)
2227 chi1=chi(itypi,itypj)
2228 chi2=chi(itypj,itypi)
2235 alf12=0.5D0*(alf1+alf2)
2236 C For diagnostics only!!!
2249 call to_box(xj,yj,zj)
2250 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2251 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2252 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2253 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2254 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2255 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2256 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2257 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2258 xj=boxshift(xj-xi,boxxsize)
2259 yj=boxshift(yj-yi,boxysize)
2260 zj=boxshift(zj-zi,boxzsize)
2261 dxj=dc_norm(1,nres+j)
2262 dyj=dc_norm(2,nres+j)
2263 dzj=dc_norm(3,nres+j)
2264 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2266 sss=sscale(1.0d0/rij,r_cut_int)
2267 if (sss.eq.0.0d0) cycle
2268 sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2269 C Calculate angle-dependent terms of energy and contributions to their
2273 sig=sig0ij*dsqrt(sigsq)
2274 rij_shift=1.0D0/rij-sig+r0ij
2275 C I hate to put IF's in the loops, but here don't have another choice!!!!
2276 if (rij_shift.le.0.0D0) then
2281 c---------------------------------------------------------------
2282 rij_shift=1.0D0/rij_shift
2283 fac=rij_shift**expon
2286 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2287 eps2der=evdwij*eps3rt
2288 eps3der=evdwij*eps2rt
2289 fac_augm=rrij**expon
2290 e_augm=augm(itypi,itypj)*fac_augm
2291 evdwij=evdwij*eps2rt*eps3rt
2292 evdw=evdw+evdwij+e_augm
2294 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2296 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2297 & restyp(itypi),i,restyp(itypj),j,
2298 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2299 & chi1,chi2,chip1,chip2,
2300 & eps1,eps2rt**2,eps3rt**2,
2301 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2304 C Calculate gradient components.
2305 e1=e1*eps1*eps2rt**2*eps3rt**2
2306 fac=-expon*(e1+evdwij)*rij_shift
2308 fac=rij*fac-2*expon*rrij*e_augm
2309 fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2310 C Calculate the radial part of the gradient
2314 C Calculate angular part of the gradient.
2315 c call sc_grad_scale(sss)
2321 C-----------------------------------------------------------------------------
2322 subroutine sc_angular
2323 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2324 C om12. Called by ebp, egb, and egbv.
2326 include 'COMMON.CALC'
2327 include 'COMMON.IOUNITS'
2331 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2332 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2333 om12=dxi*dxj+dyi*dyj+dzi*dzj
2335 C Calculate eps1(om12) and its derivative in om12
2336 faceps1=1.0D0-om12*chiom12
2337 faceps1_inv=1.0D0/faceps1
2338 eps1=dsqrt(faceps1_inv)
2339 C Following variable is eps1*deps1/dom12
2340 eps1_om12=faceps1_inv*chiom12
2345 c write (iout,*) "om12",om12," eps1",eps1
2346 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2351 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2352 sigsq=1.0D0-facsig*faceps1_inv
2353 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2354 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2355 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2361 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2362 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2364 C Calculate eps2 and its derivatives in om1, om2, and om12.
2367 chipom12=chip12*om12
2368 facp=1.0D0-om12*chipom12
2370 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2371 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2372 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2373 C Following variable is the square root of eps2
2374 eps2rt=1.0D0-facp1*facp_inv
2375 C Following three variables are the derivatives of the square root of eps
2376 C in om1, om2, and om12.
2377 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2378 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2379 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2380 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2381 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2382 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2383 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2384 c & " eps2rt_om12",eps2rt_om12
2385 C Calculate whole angle-dependent part of epsilon and contributions
2386 C to its derivatives
2389 C----------------------------------------------------------------------------
2391 implicit real*8 (a-h,o-z)
2392 include 'DIMENSIONS'
2393 include 'COMMON.CHAIN'
2394 include 'COMMON.DERIV'
2395 include 'COMMON.CALC'
2396 include 'COMMON.IOUNITS'
2397 double precision dcosom1(3),dcosom2(3)
2398 cc print *,'sss=',sss
2399 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2400 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2401 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2402 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2406 c eom12=evdwij*eps1_om12
2408 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2409 c & " sigder",sigder
2410 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2411 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2413 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2414 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2417 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2419 c write (iout,*) "gg",(gg(k),k=1,3)
2421 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2422 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2423 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2424 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2425 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2426 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2427 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2428 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2429 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2430 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2433 C Calculate the components of the gradient in DC and X
2437 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2441 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2442 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2446 C-----------------------------------------------------------------------
2447 subroutine e_softsphere(evdw)
2449 C This subroutine calculates the interaction energy of nonbonded side chains
2450 C assuming the LJ potential of interaction.
2452 implicit real*8 (a-h,o-z)
2453 include 'DIMENSIONS'
2454 parameter (accur=1.0d-10)
2455 include 'COMMON.GEO'
2456 include 'COMMON.VAR'
2457 include 'COMMON.LOCAL'
2458 include 'COMMON.CHAIN'
2459 include 'COMMON.DERIV'
2460 include 'COMMON.INTERACT'
2461 include 'COMMON.TORSION'
2462 include 'COMMON.SBRIDGE'
2463 include 'COMMON.NAMES'
2464 include 'COMMON.IOUNITS'
2465 c include 'COMMON.CONTACTS'
2467 double precision boxshift
2468 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2470 c do i=iatsc_s,iatsc_e
2471 do ikont=g_listscsc_start,g_listscsc_end
2472 i=newcontlisti(ikont)
2473 j=newcontlistj(ikont)
2474 itypi=iabs(itype(i))
2475 if (itypi.eq.ntyp1) cycle
2476 itypi1=iabs(itype(i+1))
2480 call to_box(xi,yi,zi)
2482 C Calculate SC interaction energy.
2484 c do iint=1,nint_gr(i)
2485 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2486 cd & 'iend=',iend(i,iint)
2487 c do j=istart(i,iint),iend(i,iint)
2488 itypj=iabs(itype(j))
2489 if (itypj.eq.ntyp1) cycle
2490 xj=boxshift(c(1,nres+j)-xi,boxxsize)
2491 yj=boxshift(c(2,nres+j)-yi,boxysize)
2492 zj=boxshift(c(3,nres+j)-zi,boxzsize)
2493 rij=xj*xj+yj*yj+zj*zj
2494 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2495 r0ij=r0(itypi,itypj)
2497 c print *,i,j,r0ij,dsqrt(rij)
2498 if (rij.lt.r0ijsq) then
2499 evdwij=0.25d0*(rij-r0ijsq)**2
2507 C Calculate the components of the gradient in DC and X
2513 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2514 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2515 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2516 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2520 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2528 C--------------------------------------------------------------------------
2529 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2532 C Soft-sphere potential of p-p interaction
2534 implicit real*8 (a-h,o-z)
2535 include 'DIMENSIONS'
2536 include 'COMMON.CONTROL'
2537 include 'COMMON.IOUNITS'
2538 include 'COMMON.GEO'
2539 include 'COMMON.VAR'
2540 include 'COMMON.LOCAL'
2541 include 'COMMON.CHAIN'
2542 include 'COMMON.DERIV'
2543 include 'COMMON.INTERACT'
2544 c include 'COMMON.CONTACTS'
2545 include 'COMMON.TORSION'
2546 include 'COMMON.VECTORS'
2547 include 'COMMON.FFIELD'
2549 double precision boxshift
2550 C write(iout,*) 'In EELEC_soft_sphere'
2557 do i=iatel_s,iatel_e
2558 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2562 xmedi=c(1,i)+0.5d0*dxi
2563 ymedi=c(2,i)+0.5d0*dyi
2564 zmedi=c(3,i)+0.5d0*dzi
2565 call to_box(xmedi,ymedi,zmedi)
2567 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2568 do j=ielstart(i),ielend(i)
2569 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2573 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2574 r0ij=rpp(iteli,itelj)
2582 call to_box(xj,yj,zj)
2583 xj=boxshift(xj-xmedi,boxxsize)
2584 yj=boxshift(yj-ymedi,boxysize)
2585 zj=boxshift(zj-zmedi,boxzsize)
2586 rij=xj*xj+yj*yj+zj*zj
2587 sss=sscale(sqrt(rij),r_cut_int)
2588 sssgrad=sscagrad(sqrt(rij),r_cut_int)
2589 if (rij.lt.r0ijsq) then
2590 evdw1ij=0.25d0*(rij-r0ijsq)**2
2596 evdw1=evdw1+evdw1ij*sss
2598 C Calculate contributions to the Cartesian gradient.
2600 ggg(1)=fac*xj*sssgrad
2601 ggg(2)=fac*yj*sssgrad
2602 ggg(3)=fac*zj*sssgrad
2604 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2605 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2608 * Loop over residues i+1 thru j-1.
2612 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2617 cgrad do i=nnt,nct-1
2619 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2621 cgrad do j=i+1,nct-1
2623 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2629 c------------------------------------------------------------------------------
2630 subroutine vec_and_deriv
2631 implicit real*8 (a-h,o-z)
2632 include 'DIMENSIONS'
2636 include 'COMMON.IOUNITS'
2637 include 'COMMON.GEO'
2638 include 'COMMON.VAR'
2639 include 'COMMON.LOCAL'
2640 include 'COMMON.CHAIN'
2641 include 'COMMON.VECTORS'
2642 include 'COMMON.SETUP'
2643 include 'COMMON.TIME1'
2644 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2645 C Compute the local reference systems. For reference system (i), the
2646 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2647 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2649 do i=ivec_start,ivec_end
2653 if (i.eq.nres-1) then
2654 C Case of the last full residue
2655 C Compute the Z-axis
2656 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2657 costh=dcos(pi-theta(nres))
2658 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2662 C Compute the derivatives of uz
2664 uzder(2,1,1)=-dc_norm(3,i-1)
2665 uzder(3,1,1)= dc_norm(2,i-1)
2666 uzder(1,2,1)= dc_norm(3,i-1)
2668 uzder(3,2,1)=-dc_norm(1,i-1)
2669 uzder(1,3,1)=-dc_norm(2,i-1)
2670 uzder(2,3,1)= dc_norm(1,i-1)
2673 uzder(2,1,2)= dc_norm(3,i)
2674 uzder(3,1,2)=-dc_norm(2,i)
2675 uzder(1,2,2)=-dc_norm(3,i)
2677 uzder(3,2,2)= dc_norm(1,i)
2678 uzder(1,3,2)= dc_norm(2,i)
2679 uzder(2,3,2)=-dc_norm(1,i)
2681 C Compute the Y-axis
2684 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2686 C Compute the derivatives of uy
2689 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2690 & -dc_norm(k,i)*dc_norm(j,i-1)
2691 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2693 uyder(j,j,1)=uyder(j,j,1)-costh
2694 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2699 uygrad(l,k,j,i)=uyder(l,k,j)
2700 uzgrad(l,k,j,i)=uzder(l,k,j)
2704 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2705 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2706 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2707 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2710 C Compute the Z-axis
2711 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2712 costh=dcos(pi-theta(i+2))
2713 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2717 C Compute the derivatives of uz
2719 uzder(2,1,1)=-dc_norm(3,i+1)
2720 uzder(3,1,1)= dc_norm(2,i+1)
2721 uzder(1,2,1)= dc_norm(3,i+1)
2723 uzder(3,2,1)=-dc_norm(1,i+1)
2724 uzder(1,3,1)=-dc_norm(2,i+1)
2725 uzder(2,3,1)= dc_norm(1,i+1)
2728 uzder(2,1,2)= dc_norm(3,i)
2729 uzder(3,1,2)=-dc_norm(2,i)
2730 uzder(1,2,2)=-dc_norm(3,i)
2732 uzder(3,2,2)= dc_norm(1,i)
2733 uzder(1,3,2)= dc_norm(2,i)
2734 uzder(2,3,2)=-dc_norm(1,i)
2736 C Compute the Y-axis
2739 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2741 C Compute the derivatives of uy
2744 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2745 & -dc_norm(k,i)*dc_norm(j,i+1)
2746 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2748 uyder(j,j,1)=uyder(j,j,1)-costh
2749 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2754 uygrad(l,k,j,i)=uyder(l,k,j)
2755 uzgrad(l,k,j,i)=uzder(l,k,j)
2759 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2760 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2761 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2762 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2766 vbld_inv_temp(1)=vbld_inv(i+1)
2767 if (i.lt.nres-1) then
2768 vbld_inv_temp(2)=vbld_inv(i+2)
2770 vbld_inv_temp(2)=vbld_inv(i)
2775 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2776 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2781 #if defined(PARVEC) && defined(MPI)
2782 if (nfgtasks1.gt.1) then
2784 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2785 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2786 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2787 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2788 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2790 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2791 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2793 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2794 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2795 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2796 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2797 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2798 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2799 time_gather=time_gather+MPI_Wtime()-time00
2803 if (fg_rank.eq.0) then
2804 write (iout,*) "Arrays UY and UZ"
2806 write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2813 C--------------------------------------------------------------------------
2814 subroutine set_matrices
2815 implicit real*8 (a-h,o-z)
2816 include 'DIMENSIONS'
2819 include "COMMON.SETUP"
2821 integer status(MPI_STATUS_SIZE)
2823 include 'COMMON.IOUNITS'
2824 include 'COMMON.GEO'
2825 include 'COMMON.VAR'
2826 include 'COMMON.LOCAL'
2827 include 'COMMON.CHAIN'
2828 include 'COMMON.DERIV'
2829 include 'COMMON.INTERACT'
2830 include 'COMMON.CORRMAT'
2831 include 'COMMON.TORSION'
2832 include 'COMMON.VECTORS'
2833 include 'COMMON.FFIELD'
2834 double precision auxvec(2),auxmat(2,2)
2836 C Compute the virtual-bond-torsional-angle dependent quantities needed
2837 C to calculate the el-loc multibody terms of various order.
2839 c write(iout,*) 'nphi=',nphi,nres
2840 c write(iout,*) "itype2loc",itype2loc
2842 do i=ivec_start+2,ivec_end+2
2847 c write (iout,*) "i",i,i-2," ii",ii
2849 innt=chain_border(1,ii)
2850 inct=chain_border(2,ii)
2851 c write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2852 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
2853 if (i.gt. innt+2 .and. i.lt.inct+2) then
2854 iti = itype2loc(itype(i-2))
2858 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2859 if (i.gt. innt+1 .and. i.lt.inct+1) then
2860 iti1 = itype2loc(itype(i-1))
2864 c write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
2865 c & " iti1",itype(i-1),iti1
2867 cost1=dcos(theta(i-1))
2868 sint1=dsin(theta(i-1))
2870 sint1cub=sint1sq*sint1
2871 sint1cost1=2*sint1*cost1
2872 c write (iout,*) "bnew1",i,iti
2873 c write (iout,*) (bnew1(k,1,iti),k=1,3)
2874 c write (iout,*) (bnew1(k,2,iti),k=1,3)
2875 c write (iout,*) "bnew2",i,iti
2876 c write (iout,*) (bnew2(k,1,iti),k=1,3)
2877 c write (iout,*) (bnew2(k,2,iti),k=1,3)
2879 b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2881 gtb1(k,i-2)=cost1*b1k-sint1sq*
2882 & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2883 b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2885 gtb2(k,i-2)=cost1*b2k-sint1sq*
2886 & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2889 aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2890 cc(1,k,i-2)=sint1sq*aux
2891 gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2892 & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2893 aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2894 dd(1,k,i-2)=sint1sq*aux
2895 gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2896 & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2898 cc(2,1,i-2)=cc(1,2,i-2)
2899 cc(2,2,i-2)=-cc(1,1,i-2)
2900 gtcc(2,1,i-2)=gtcc(1,2,i-2)
2901 gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2902 dd(2,1,i-2)=dd(1,2,i-2)
2903 dd(2,2,i-2)=-dd(1,1,i-2)
2904 gtdd(2,1,i-2)=gtdd(1,2,i-2)
2905 gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2908 aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2909 EE(l,k,i-2)=sint1sq*aux
2910 gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2913 EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2914 EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2915 EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2916 EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2917 gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2918 gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2919 gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2920 c b1tilde(1,i-2)=b1(1,i-2)
2921 c b1tilde(2,i-2)=-b1(2,i-2)
2922 c b2tilde(1,i-2)=b2(1,i-2)
2923 c b2tilde(2,i-2)=-b2(2,i-2)
2925 write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2926 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
2927 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
2928 write (iout,*) 'theta=', theta(i-1)
2931 if (i.gt. innt+2 .and. i.lt.inct+2) then
2932 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
2933 iti = itype2loc(itype(i-2))
2937 c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2938 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2939 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2940 iti1 = itype2loc(itype(i-1))
2950 CC(k,l,i-2)=ccold(k,l,iti)
2951 DD(k,l,i-2)=ddold(k,l,iti)
2952 EE(k,l,i-2)=eeold(k,l,iti)
2957 b1tilde(1,i-2)= b1(1,i-2)
2958 b1tilde(2,i-2)=-b1(2,i-2)
2959 b2tilde(1,i-2)= b2(1,i-2)
2960 b2tilde(2,i-2)=-b2(2,i-2)
2962 Ctilde(1,1,i-2)= CC(1,1,i-2)
2963 Ctilde(1,2,i-2)= CC(1,2,i-2)
2964 Ctilde(2,1,i-2)=-CC(2,1,i-2)
2965 Ctilde(2,2,i-2)=-CC(2,2,i-2)
2967 Dtilde(1,1,i-2)= DD(1,1,i-2)
2968 Dtilde(1,2,i-2)= DD(1,2,i-2)
2969 Dtilde(2,1,i-2)=-DD(2,1,i-2)
2970 Dtilde(2,2,i-2)=-DD(2,2,i-2)
2972 write(iout,*) "i",i," iti",iti
2973 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
2974 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
2979 do i=ivec_start+2,ivec_end+2
2983 c if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
2984 if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3022 obrot_der(1,i-2)=-sin1
3023 obrot_der(2,i-2)= cos1
3024 Ugder(1,1,i-2)= sin1
3025 Ugder(1,2,i-2)=-cos1
3026 Ugder(2,1,i-2)=-cos1
3027 Ugder(2,2,i-2)=-sin1
3030 obrot2_der(1,i-2)=-dwasin2
3031 obrot2_der(2,i-2)= dwacos2
3032 Ug2der(1,1,i-2)= dwasin2
3033 Ug2der(1,2,i-2)=-dwacos2
3034 Ug2der(2,1,i-2)=-dwacos2
3035 Ug2der(2,2,i-2)=-dwasin2
3037 obrot_der(1,i-2)=0.0d0
3038 obrot_der(2,i-2)=0.0d0
3039 Ugder(1,1,i-2)=0.0d0
3040 Ugder(1,2,i-2)=0.0d0
3041 Ugder(2,1,i-2)=0.0d0
3042 Ugder(2,2,i-2)=0.0d0
3043 obrot2_der(1,i-2)=0.0d0
3044 obrot2_der(2,i-2)=0.0d0
3045 Ug2der(1,1,i-2)=0.0d0
3046 Ug2der(1,2,i-2)=0.0d0
3047 Ug2der(2,1,i-2)=0.0d0
3048 Ug2der(2,2,i-2)=0.0d0
3050 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3051 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3052 if (i.gt.nnt+2 .and.i.lt.nct+2) then
3053 iti = itype2loc(itype(i-2))
3057 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3058 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3059 iti1 = itype2loc(itype(i-1))
3063 cd write (iout,*) '*******i',i,' iti1',iti
3064 cd write (iout,*) 'b1',b1(:,iti)
3065 cd write (iout,*) 'b2',b2(:,iti)
3066 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3067 c if (i .gt. iatel_s+2) then
3068 if (i .gt. nnt+2) then
3069 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3071 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3072 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3074 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3075 c & EE(1,2,iti),EE(2,2,i)
3076 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3077 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3078 c write(iout,*) "Macierz EUG",
3079 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3082 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3084 call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3085 call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3086 call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3087 call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3088 call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3100 DtUg2(l,k,i-2)=0.0d0
3104 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3105 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3107 muder(k,i-2)=Ub2der(k,i-2)
3109 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3110 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3111 if (itype(i-1).le.ntyp) then
3112 iti1 = itype2loc(itype(i-1))
3120 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3121 c mu(k,i-2)=b1(k,i-1)
3122 c mu(k,i-2)=Ub2(k,i-2)
3125 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3126 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3127 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3128 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3129 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3130 & ((ee(l,k,i-2),l=1,2),k=1,2)
3132 cd write (iout,*) 'mu1',mu1(:,i-2)
3133 cd write (iout,*) 'mu2',mu2(:,i-2)
3134 cd write (iout,*) 'mu',i-2,mu(:,i-2)
3136 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3138 call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3139 call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3140 call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3141 call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3142 call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3143 C Vectors and matrices dependent on a single virtual-bond dihedral.
3144 call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3145 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3146 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3147 call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3148 call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3149 call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3150 call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3151 call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3152 call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3157 C Matrices dependent on two consecutive virtual-bond dihedrals.
3158 C The order of matrices is from left to right.
3159 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3161 c do i=max0(ivec_start,2),ivec_end
3163 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3164 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3165 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3166 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3167 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3168 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3169 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3170 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3174 #if defined(MPI) && defined(PARMAT)
3176 c if (fg_rank.eq.0) then
3177 write (iout,*) "Arrays UG and UGDER before GATHER"
3179 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3180 & ((ug(l,k,i),l=1,2),k=1,2),
3181 & ((ugder(l,k,i),l=1,2),k=1,2)
3183 write (iout,*) "Arrays UG2 and UG2DER"
3185 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3186 & ((ug2(l,k,i),l=1,2),k=1,2),
3187 & ((ug2der(l,k,i),l=1,2),k=1,2)
3189 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3191 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3192 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3193 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3195 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3197 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3198 & costab(i),sintab(i),costab2(i),sintab2(i)
3200 write (iout,*) "Array MUDER"
3202 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3206 if (nfgtasks.gt.1) then
3208 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3209 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3210 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3212 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3213 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3215 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3216 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3218 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3219 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3221 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3222 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3224 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3225 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3227 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3228 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3230 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3231 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3232 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3233 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3234 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3235 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3236 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3237 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3238 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3239 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3240 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3241 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3243 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3245 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3246 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3248 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3249 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3251 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3252 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3254 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3255 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3257 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3258 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3260 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3261 & ivec_count(fg_rank1),
3262 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3264 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3265 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3267 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3268 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3270 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3271 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3273 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3274 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3276 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3277 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3279 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3280 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3282 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3283 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3285 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3286 & ivec_count(fg_rank1),
3287 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3289 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3290 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3292 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3293 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3295 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3296 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3298 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3299 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3301 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3302 & ivec_count(fg_rank1),
3303 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3305 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3306 & ivec_count(fg_rank1),
3307 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3309 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3310 & ivec_count(fg_rank1),
3311 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3312 & MPI_MAT2,FG_COMM1,IERR)
3313 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3314 & ivec_count(fg_rank1),
3315 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3316 & MPI_MAT2,FG_COMM1,IERR)
3320 c Passes matrix info through the ring
3323 if (irecv.lt.0) irecv=nfgtasks1-1
3326 if (inext.ge.nfgtasks1) inext=0
3328 c write (iout,*) "isend",isend," irecv",irecv
3330 lensend=lentyp(isend)
3331 lenrecv=lentyp(irecv)
3332 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3333 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3334 c & MPI_ROTAT1(lensend),inext,2200+isend,
3335 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3336 c & iprev,2200+irecv,FG_COMM,status,IERR)
3337 c write (iout,*) "Gather ROTAT1"
3339 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3340 c & MPI_ROTAT2(lensend),inext,3300+isend,
3341 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3342 c & iprev,3300+irecv,FG_COMM,status,IERR)
3343 c write (iout,*) "Gather ROTAT2"
3345 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3346 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3347 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3348 & iprev,4400+irecv,FG_COMM,status,IERR)
3349 c write (iout,*) "Gather ROTAT_OLD"
3351 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3352 & MPI_PRECOMP11(lensend),inext,5500+isend,
3353 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3354 & iprev,5500+irecv,FG_COMM,status,IERR)
3355 c write (iout,*) "Gather PRECOMP11"
3357 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3358 & MPI_PRECOMP12(lensend),inext,6600+isend,
3359 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3360 & iprev,6600+irecv,FG_COMM,status,IERR)
3361 c write (iout,*) "Gather PRECOMP12"
3364 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3366 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3367 & MPI_ROTAT2(lensend),inext,7700+isend,
3368 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3369 & iprev,7700+irecv,FG_COMM,status,IERR)
3370 c write (iout,*) "Gather PRECOMP21"
3372 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3373 & MPI_PRECOMP22(lensend),inext,8800+isend,
3374 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3375 & iprev,8800+irecv,FG_COMM,status,IERR)
3376 c write (iout,*) "Gather PRECOMP22"
3378 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3379 & MPI_PRECOMP23(lensend),inext,9900+isend,
3380 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3381 & MPI_PRECOMP23(lenrecv),
3382 & iprev,9900+irecv,FG_COMM,status,IERR)
3384 c write (iout,*) "Gather PRECOMP23"
3389 if (irecv.lt.0) irecv=nfgtasks1-1
3392 time_gather=time_gather+MPI_Wtime()-time00
3395 c if (fg_rank.eq.0) then
3396 write (iout,*) "Arrays UG and UGDER"
3398 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3399 & ((ug(l,k,i),l=1,2),k=1,2),
3400 & ((ugder(l,k,i),l=1,2),k=1,2)
3402 write (iout,*) "Arrays UG2 and UG2DER"
3404 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3405 & ((ug2(l,k,i),l=1,2),k=1,2),
3406 & ((ug2der(l,k,i),l=1,2),k=1,2)
3408 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3410 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3411 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3412 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3414 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3416 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3417 & costab(i),sintab(i),costab2(i),sintab2(i)
3419 write (iout,*) "Array MUDER"
3421 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3427 cd iti = itype2loc(itype(i))
3430 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3431 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3436 C-----------------------------------------------------------------------------
3437 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3439 C This subroutine calculates the average interaction energy and its gradient
3440 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3441 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3442 C The potential depends both on the distance of peptide-group centers and on
3443 C the orientation of the CA-CA virtual bonds.
3445 implicit real*8 (a-h,o-z)
3449 include 'DIMENSIONS'
3450 include 'COMMON.CONTROL'
3451 include 'COMMON.SETUP'
3452 include 'COMMON.IOUNITS'
3453 include 'COMMON.GEO'
3454 include 'COMMON.VAR'
3455 include 'COMMON.LOCAL'
3456 include 'COMMON.CHAIN'
3457 include 'COMMON.DERIV'
3458 include 'COMMON.INTERACT'
3460 include 'COMMON.CONTACTS'
3461 include 'COMMON.CONTMAT'
3463 include 'COMMON.CORRMAT'
3464 include 'COMMON.TORSION'
3465 include 'COMMON.VECTORS'
3466 include 'COMMON.FFIELD'
3467 include 'COMMON.TIME1'
3468 include 'COMMON.SPLITELE'
3469 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3470 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3471 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3472 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3473 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3474 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3476 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3478 double precision scal_el /1.0d0/
3480 double precision scal_el /0.5d0/
3483 C 13-go grudnia roku pamietnego...
3484 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3485 & 0.0d0,1.0d0,0.0d0,
3486 & 0.0d0,0.0d0,1.0d0/
3487 cd write(iout,*) 'In EELEC'
3489 cd write(iout,*) 'Type',i
3490 cd write(iout,*) 'B1',B1(:,i)
3491 cd write(iout,*) 'B2',B2(:,i)
3492 cd write(iout,*) 'CC',CC(:,:,i)
3493 cd write(iout,*) 'DD',DD(:,:,i)
3494 cd write(iout,*) 'EE',EE(:,:,i)
3496 cd call check_vecgrad
3498 if (icheckgrad.eq.1) then
3500 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3502 dc_norm(k,i)=dc(k,i)*fac
3504 c write (iout,*) 'i',i,' fac',fac
3507 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3508 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3509 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3510 c call vec_and_deriv
3516 time_mat=time_mat+MPI_Wtime()-time01
3520 cd write (iout,*) 'i=',i
3522 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3525 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3526 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3541 cd print '(a)','Enter EELEC'
3542 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3544 gel_loc_loc(i)=0.0d0
3549 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3551 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3553 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3554 do i=iturn3_start,iturn3_end
3556 C write(iout,*) "tu jest i",i
3557 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3558 C changes suggested by Ana to avoid out of bounds
3559 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3560 c & .or.((i+4).gt.nres)
3561 c & .or.((i-1).le.0)
3562 C end of changes by Ana
3563 & .or. itype(i+2).eq.ntyp1
3564 & .or. itype(i+3).eq.ntyp1) cycle
3565 C Adam: Instructions below will switch off existing interactions
3567 c if(itype(i-1).eq.ntyp1)cycle
3569 c if(i.LT.nres-3)then
3570 c if (itype(i+4).eq.ntyp1) cycle
3575 dx_normi=dc_norm(1,i)
3576 dy_normi=dc_norm(2,i)
3577 dz_normi=dc_norm(3,i)
3578 xmedi=c(1,i)+0.5d0*dxi
3579 ymedi=c(2,i)+0.5d0*dyi
3580 zmedi=c(3,i)+0.5d0*dzi
3581 call to_box(xmedi,ymedi,zmedi)
3583 call eelecij(i,i+2,ees,evdw1,eel_loc)
3584 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3586 num_cont_hb(i)=num_conti
3589 do i=iturn4_start,iturn4_end
3591 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3592 C changes suggested by Ana to avoid out of bounds
3593 c & .or.((i+5).gt.nres)
3594 c & .or.((i-1).le.0)
3595 C end of changes suggested by Ana
3596 & .or. itype(i+3).eq.ntyp1
3597 & .or. itype(i+4).eq.ntyp1
3598 c & .or. itype(i+5).eq.ntyp1
3599 c & .or. itype(i).eq.ntyp1
3600 c & .or. itype(i-1).eq.ntyp1
3605 dx_normi=dc_norm(1,i)
3606 dy_normi=dc_norm(2,i)
3607 dz_normi=dc_norm(3,i)
3608 xmedi=c(1,i)+0.5d0*dxi
3609 ymedi=c(2,i)+0.5d0*dyi
3610 zmedi=c(3,i)+0.5d0*dzi
3611 C Return atom into box, boxxsize is size of box in x dimension
3613 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3614 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3615 C Condition for being inside the proper box
3616 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3617 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3621 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3622 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3623 C Condition for being inside the proper box
3624 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3625 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3629 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3630 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3631 C Condition for being inside the proper box
3632 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3633 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3636 call to_box(xmedi,ymedi,zmedi)
3638 num_conti=num_cont_hb(i)
3640 c write(iout,*) "JESTEM W PETLI"
3641 call eelecij(i,i+3,ees,evdw1,eel_loc)
3642 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3643 & call eturn4(i,eello_turn4)
3645 num_cont_hb(i)=num_conti
3648 C Loop over all neighbouring boxes
3653 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3656 c do i=iatel_s,iatel_e
3657 do ikont=g_listpp_start,g_listpp_end
3658 i=newcontlistppi(ikont)
3659 j=newcontlistppj(ikont)
3662 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3663 C changes suggested by Ana to avoid out of bounds
3664 c & .or.((i+2).gt.nres)
3665 c & .or.((i-1).le.0)
3666 C end of changes by Ana
3667 c & .or. itype(i+2).eq.ntyp1
3668 c & .or. itype(i-1).eq.ntyp1
3673 dx_normi=dc_norm(1,i)
3674 dy_normi=dc_norm(2,i)
3675 dz_normi=dc_norm(3,i)
3676 xmedi=c(1,i)+0.5d0*dxi
3677 ymedi=c(2,i)+0.5d0*dyi
3678 zmedi=c(3,i)+0.5d0*dzi
3679 call to_box(xmedi,ymedi,zmedi)
3680 C xmedi=xmedi+xshift*boxxsize
3681 C ymedi=ymedi+yshift*boxysize
3682 C zmedi=zmedi+zshift*boxzsize
3684 C Return tom into box, boxxsize is size of box in x dimension
3686 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3687 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3688 C Condition for being inside the proper box
3689 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3690 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3694 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3695 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3696 C Condition for being inside the proper box
3697 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3698 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3702 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3703 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3704 cC Condition for being inside the proper box
3705 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3706 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3710 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3712 num_conti=num_cont_hb(i)
3715 c do j=ielstart(i),ielend(i)
3717 C write (iout,*) i,j
3719 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3720 C changes suggested by Ana to avoid out of bounds
3721 c & .or.((j+2).gt.nres)
3722 c & .or.((j-1).le.0)
3723 C end of changes by Ana
3724 c & .or.itype(j+2).eq.ntyp1
3725 c & .or.itype(j-1).eq.ntyp1
3727 call eelecij(i,j,ees,evdw1,eel_loc)
3730 num_cont_hb(i)=num_conti
3737 c write (iout,*) "Number of loop steps in EELEC:",ind
3739 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3740 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3742 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3743 ccc eel_loc=eel_loc+eello_turn3
3744 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3747 C-------------------------------------------------------------------------------
3748 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3750 include 'DIMENSIONS'
3754 include 'COMMON.CONTROL'
3755 include 'COMMON.IOUNITS'
3756 include 'COMMON.GEO'
3757 include 'COMMON.VAR'
3758 include 'COMMON.LOCAL'
3759 include 'COMMON.CHAIN'
3760 include 'COMMON.DERIV'
3761 include 'COMMON.INTERACT'
3763 include 'COMMON.CONTACTS'
3764 include 'COMMON.CONTMAT'
3766 include 'COMMON.CORRMAT'
3767 include 'COMMON.TORSION'
3768 include 'COMMON.VECTORS'
3769 include 'COMMON.FFIELD'
3770 include 'COMMON.TIME1'
3771 include 'COMMON.SPLITELE'
3772 include 'COMMON.SHIELD'
3773 double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3774 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3775 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3776 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3777 & gmuij2(4),gmuji2(4)
3778 double precision dxi,dyi,dzi
3779 double precision dx_normi,dy_normi,dz_normi,aux
3780 integer j1,j2,lll,num_conti
3781 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3782 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3784 integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3785 double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3786 double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3787 double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3788 & rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3789 & evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3790 & ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3791 & a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3792 & ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3793 & ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3794 & ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3795 double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3796 double precision xmedi,ymedi,zmedi
3797 double precision sscale,sscagrad,scalar
3798 double precision boxshift
3799 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3801 double precision scal_el /1.0d0/
3803 double precision scal_el /0.5d0/
3806 C 13-go grudnia roku pamietnego...
3807 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3808 & 0.0d0,1.0d0,0.0d0,
3809 & 0.0d0,0.0d0,1.0d0/
3810 c time00=MPI_Wtime()
3811 cd write (iout,*) "eelecij",i,j
3815 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3816 aaa=app(iteli,itelj)
3817 bbb=bpp(iteli,itelj)
3818 ael6i=ael6(iteli,itelj)
3819 ael3i=ael3(iteli,itelj)
3823 dx_normj=dc_norm(1,j)
3824 dy_normj=dc_norm(2,j)
3825 dz_normj=dc_norm(3,j)
3826 C xj=c(1,j)+0.5D0*dxj-xmedi
3827 C yj=c(2,j)+0.5D0*dyj-ymedi
3828 C zj=c(3,j)+0.5D0*dzj-zmedi
3832 call to_box(xj,yj,zj)
3833 xj=boxshift(xj-xmedi,boxxsize)
3834 yj=boxshift(yj-ymedi,boxysize)
3835 zj=boxshift(zj-zmedi,boxzsize)
3836 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3838 rij=xj*xj+yj*yj+zj*zj
3840 sss=sscale(dsqrt(rij),r_cut_int)
3841 if (sss.eq.0.0d0) return
3842 sssgrad=sscagrad(dsqrt(rij),r_cut_int)
3843 c if (sss.gt.0.0d0) then
3849 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3850 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3851 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3852 fac=cosa-3.0D0*cosb*cosg
3854 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3855 if (j.eq.i+2) ev1=scal_el*ev1
3860 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3864 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3865 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3866 if (shield_mode.gt.0) then
3869 el1=el1*fac_shield(i)**2*fac_shield(j)**2
3870 el2=el2*fac_shield(i)**2*fac_shield(j)**2
3879 evdw1=evdw1+evdwij*sss
3880 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3881 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3882 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
3883 cd & xmedi,ymedi,zmedi,xj,yj,zj
3885 if (energy_dec) then
3886 write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
3887 & 'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
3888 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3889 & fac_shield(i),fac_shield(j)
3893 C Calculate contributions to the Cartesian gradient.
3896 facvdw=-6*rrmij*(ev1+evdwij)*sss
3897 facel=-3*rrmij*(el1+eesij)
3904 * Radial derivatives. First process both termini of the fragment (i,j)
3906 aux=facel*sss+rmij*sssgrad*eesij
3910 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3911 & (shield_mode.gt.0)) then
3913 do ilist=1,ishield_list(i)
3914 iresshield=shield_list(ilist,i)
3916 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3918 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3920 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3921 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3922 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3923 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3924 C if (iresshield.gt.i) then
3925 C do ishi=i+1,iresshield-1
3926 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3927 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3931 C do ishi=iresshield,i
3932 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3933 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3939 do ilist=1,ishield_list(j)
3940 iresshield=shield_list(ilist,j)
3942 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3944 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3946 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
3947 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3949 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3950 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3951 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3952 C if (iresshield.gt.j) then
3953 C do ishi=j+1,iresshield-1
3954 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3955 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3959 C do ishi=iresshield,j
3960 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3961 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3968 gshieldc(k,i)=gshieldc(k,i)+
3969 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3970 gshieldc(k,j)=gshieldc(k,j)+
3971 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3972 gshieldc(k,i-1)=gshieldc(k,i-1)+
3973 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3974 gshieldc(k,j-1)=gshieldc(k,j-1)+
3975 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3980 c ghalf=0.5D0*ggg(k)
3981 c gelc(k,i)=gelc(k,i)+ghalf
3982 c gelc(k,j)=gelc(k,j)+ghalf
3984 c 9/28/08 AL Gradient compotents will be summed only at the end
3985 C print *,"before", gelc_long(1,i), gelc_long(1,j)
3987 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3988 C & +grad_shield(k,j)*eesij/fac_shield(j)
3989 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3990 C & +grad_shield(k,i)*eesij/fac_shield(i)
3991 C gelc_long(k,i-1)=gelc_long(k,i-1)
3992 C & +grad_shield(k,i)*eesij/fac_shield(i)
3993 C gelc_long(k,j-1)=gelc_long(k,j-1)
3994 C & +grad_shield(k,j)*eesij/fac_shield(j)
3996 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3999 * Loop over residues i+1 thru j-1.
4003 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4006 facvdw=facvdw+sssgrad*rmij*evdwij
4011 c ghalf=0.5D0*ggg(k)
4012 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4013 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4015 c 9/28/08 AL Gradient compotents will be summed only at the end
4017 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4018 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4021 * Loop over residues i+1 thru j-1.
4025 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4033 fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4034 & +(evdwij+eesij)*sssgrad*rrmij
4039 * Radial derivatives. First process both termini of the fragment (i,j)
4042 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4044 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4046 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4048 c ghalf=0.5D0*ggg(k)
4049 c gelc(k,i)=gelc(k,i)+ghalf
4050 c gelc(k,j)=gelc(k,j)+ghalf
4052 c 9/28/08 AL Gradient compotents will be summed only at the end
4054 gelc_long(k,j)=gelc(k,j)+ggg(k)
4055 gelc_long(k,i)=gelc(k,i)-ggg(k)
4058 * Loop over residues i+1 thru j-1.
4062 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4065 c 9/28/08 AL Gradient compotents will be summed only at the end
4066 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4067 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4068 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4070 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4071 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4077 ecosa=2.0D0*fac3*fac1+fac4
4080 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4081 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4083 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4084 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4086 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4087 cd & (dcosg(k),k=1,3)
4089 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4090 & fac_shield(i)**2*fac_shield(j)**2*sss
4093 c ghalf=0.5D0*ggg(k)
4094 c gelc(k,i)=gelc(k,i)+ghalf
4095 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4096 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4097 c gelc(k,j)=gelc(k,j)+ghalf
4098 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4099 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4103 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4106 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4109 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4110 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4111 & *fac_shield(i)**2*fac_shield(j)**2
4113 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4114 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4115 & *fac_shield(i)**2*fac_shield(j)**2
4116 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4117 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4119 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4123 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4124 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4125 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4127 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4128 C energy of a peptide unit is assumed in the form of a second-order
4129 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4130 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4131 C are computed for EVERY pair of non-contiguous peptide groups.
4134 if (j.lt.nres-1) then
4146 muij(kkk)=mu(k,i)*mu(l,j)
4147 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4149 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4150 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4151 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4152 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4153 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4154 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4159 write (iout,*) 'EELEC: i',i,' j',j
4160 write (iout,*) 'j',j,' j1',j1,' j2',j2
4161 write(iout,*) 'muij',muij
4163 ury=scalar(uy(1,i),erij)
4164 urz=scalar(uz(1,i),erij)
4165 vry=scalar(uy(1,j),erij)
4166 vrz=scalar(uz(1,j),erij)
4167 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4168 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4169 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4170 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4171 fac=dsqrt(-ael6i)*r3ij
4173 write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4174 write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4175 & "uyvz",scalar(uy(1,i),uz(1,j)),
4176 & "uzvy",scalar(uz(1,i),uy(1,j)),
4177 & "uzvz",scalar(uz(1,i),uz(1,j))
4178 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4179 write (iout,*) "fac",fac
4186 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4189 cd write (iout,'(4i5,4f10.5)')
4190 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4191 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4192 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4193 cd & uy(:,j),uz(:,j)
4194 cd write (iout,'(4f10.5)')
4195 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4196 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4197 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4198 cd write (iout,'(9f10.5/)')
4199 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4200 C Derivatives of the elements of A in virtual-bond vectors
4201 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4203 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4204 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4205 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4206 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4207 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4208 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4209 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4210 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4211 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4212 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4213 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4214 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4216 C Compute radial contributions to the gradient
4234 C Add the contributions coming from er
4237 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4238 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4239 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4240 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4243 C Derivatives in DC(i)
4244 cgrad ghalf1=0.5d0*agg(k,1)
4245 cgrad ghalf2=0.5d0*agg(k,2)
4246 cgrad ghalf3=0.5d0*agg(k,3)
4247 cgrad ghalf4=0.5d0*agg(k,4)
4248 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4249 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4250 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4251 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4252 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4253 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4254 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4255 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4256 C Derivatives in DC(i+1)
4257 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4258 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4259 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4260 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4261 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4262 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4263 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4264 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4265 C Derivatives in DC(j)
4266 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4267 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4268 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4269 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4270 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4271 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4272 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4273 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4274 C Derivatives in DC(j+1) or DC(nres-1)
4275 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4276 & -3.0d0*vryg(k,3)*ury)
4277 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4278 & -3.0d0*vrzg(k,3)*ury)
4279 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4280 & -3.0d0*vryg(k,3)*urz)
4281 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4282 & -3.0d0*vrzg(k,3)*urz)
4283 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4285 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4298 aggi(k,l)=-aggi(k,l)
4299 aggi1(k,l)=-aggi1(k,l)
4300 aggj(k,l)=-aggj(k,l)
4301 aggj1(k,l)=-aggj1(k,l)
4304 if (j.lt.nres-1) then
4310 aggi(k,l)=-aggi(k,l)
4311 aggi1(k,l)=-aggi1(k,l)
4312 aggj(k,l)=-aggj(k,l)
4313 aggj1(k,l)=-aggj1(k,l)
4324 aggi(k,l)=-aggi(k,l)
4325 aggi1(k,l)=-aggi1(k,l)
4326 aggj(k,l)=-aggj(k,l)
4327 aggj1(k,l)=-aggj1(k,l)
4332 IF (wel_loc.gt.0.0d0) THEN
4333 C Contribution to the local-electrostatic energy coming from the i-j pair
4334 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4337 write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4339 write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4340 & " wel_loc",wel_loc
4342 if (shield_mode.eq.0) then
4349 eel_loc_ij=eel_loc_ij
4350 & *fac_shield(i)*fac_shield(j)*sss
4351 c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4352 c & 'eelloc',i,j,eel_loc_ij
4353 C Now derivative over eel_loc
4354 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4355 & (shield_mode.gt.0)) then
4358 do ilist=1,ishield_list(i)
4359 iresshield=shield_list(ilist,i)
4361 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4364 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4366 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4367 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4371 do ilist=1,ishield_list(j)
4372 iresshield=shield_list(ilist,j)
4374 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4377 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4379 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4380 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4387 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4388 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4389 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4390 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4391 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4392 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4393 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4394 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4399 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4400 c & ' eel_loc_ij',eel_loc_ij
4401 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4402 C Calculate patrial derivative for theta angle
4404 geel_loc_ij=(a22*gmuij1(1)
4408 & *fac_shield(i)*fac_shield(j)*sss
4409 c write(iout,*) "derivative over thatai"
4410 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4412 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4413 & geel_loc_ij*wel_loc
4414 c write(iout,*) "derivative over thatai-1"
4415 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4422 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4423 & geel_loc_ij*wel_loc
4424 & *fac_shield(i)*fac_shield(j)*sss
4426 c Derivative over j residue
4427 geel_loc_ji=a22*gmuji1(1)
4431 c write(iout,*) "derivative over thataj"
4432 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4435 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4436 & geel_loc_ji*wel_loc
4437 & *fac_shield(i)*fac_shield(j)*sss
4444 c write(iout,*) "derivative over thataj-1"
4445 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4447 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4448 & geel_loc_ji*wel_loc
4449 & *fac_shield(i)*fac_shield(j)*sss
4451 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4453 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4454 & 'eelloc',i,j,eel_loc_ij
4455 c if (eel_loc_ij.ne.0)
4456 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4457 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4459 eel_loc=eel_loc+eel_loc_ij
4460 C Partial derivatives in virtual-bond dihedral angles gamma
4462 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4463 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4464 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4465 & *fac_shield(i)*fac_shield(j)*sss
4467 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4468 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4469 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4470 & *fac_shield(i)*fac_shield(j)*sss
4471 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4472 aux=eel_loc_ij/sss*sssgrad*rmij
4477 ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4478 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4479 & *fac_shield(i)*fac_shield(j)*sss
4480 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4481 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4482 cgrad ghalf=0.5d0*ggg(l)
4483 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4484 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4488 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4491 C Remaining derivatives of eello
4493 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4494 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4495 & *fac_shield(i)*fac_shield(j)*sss
4497 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4498 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4499 & *fac_shield(i)*fac_shield(j)*sss
4501 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4502 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4503 & *fac_shield(i)*fac_shield(j)*sss
4505 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4506 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4507 & *fac_shield(i)*fac_shield(j)*sss
4511 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4512 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4514 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4515 & .and. num_conti.le.maxconts) then
4516 c write (iout,*) i,j," entered corr"
4518 C Calculate the contact function. The ith column of the array JCONT will
4519 C contain the numbers of atoms that make contacts with the atom I (of numbers
4520 C greater than I). The arrays FACONT and GACONT will contain the values of
4521 C the contact function and its derivative.
4522 c r0ij=1.02D0*rpp(iteli,itelj)
4523 c r0ij=1.11D0*rpp(iteli,itelj)
4524 r0ij=2.20D0*rpp(iteli,itelj)
4525 c r0ij=1.55D0*rpp(iteli,itelj)
4526 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4527 if (fcont.gt.0.0D0) then
4528 num_conti=num_conti+1
4529 if (num_conti.gt.maxconts) then
4530 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4531 & ' will skip next contacts for this conf.'
4533 jcont_hb(num_conti,i)=j
4534 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4535 cd & " jcont_hb",jcont_hb(num_conti,i)
4536 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4537 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4538 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4540 d_cont(num_conti,i)=rij
4541 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4542 C --- Electrostatic-interaction matrix ---
4543 a_chuj(1,1,num_conti,i)=a22
4544 a_chuj(1,2,num_conti,i)=a23
4545 a_chuj(2,1,num_conti,i)=a32
4546 a_chuj(2,2,num_conti,i)=a33
4547 C --- Gradient of rij
4549 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4556 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4557 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4558 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4559 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4560 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4565 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4566 C Calculate contact energies
4568 wij=cosa-3.0D0*cosb*cosg
4571 c fac3=dsqrt(-ael6i)/r0ij**3
4572 fac3=dsqrt(-ael6i)*r3ij
4573 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4574 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4575 if (ees0tmp.gt.0) then
4576 ees0pij=dsqrt(ees0tmp)
4580 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4581 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4582 if (ees0tmp.gt.0) then
4583 ees0mij=dsqrt(ees0tmp)
4588 if (shield_mode.eq.0) then
4592 ees0plist(num_conti,i)=j
4593 C fac_shield(i)=0.4d0
4594 C fac_shield(j)=0.6d0
4596 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4597 & *fac_shield(i)*fac_shield(j)*sss
4598 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4599 & *fac_shield(i)*fac_shield(j)*sss
4600 C Diagnostics. Comment out or remove after debugging!
4601 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4602 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4603 c ees0m(num_conti,i)=0.0D0
4605 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4606 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4607 C Angular derivatives of the contact function
4608 ees0pij1=fac3/ees0pij
4609 ees0mij1=fac3/ees0mij
4610 fac3p=-3.0D0*fac3*rrmij
4611 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4612 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4614 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4615 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4616 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4617 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4618 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4619 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4620 ecosap=ecosa1+ecosa2
4621 ecosbp=ecosb1+ecosb2
4622 ecosgp=ecosg1+ecosg2
4623 ecosam=ecosa1-ecosa2
4624 ecosbm=ecosb1-ecosb2
4625 ecosgm=ecosg1-ecosg2
4634 facont_hb(num_conti,i)=fcont
4635 fprimcont=fprimcont/rij
4636 cd facont_hb(num_conti,i)=1.0D0
4637 C Following line is for diagnostics.
4640 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4641 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4644 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4645 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4647 gggp(1)=gggp(1)+ees0pijp*xj
4648 & +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4649 gggp(2)=gggp(2)+ees0pijp*yj
4650 & +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4651 gggp(3)=gggp(3)+ees0pijp*zj
4652 & +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4653 gggm(1)=gggm(1)+ees0mijp*xj
4654 & +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4655 gggm(2)=gggm(2)+ees0mijp*yj
4656 & +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4657 gggm(3)=gggm(3)+ees0mijp*zj
4658 & +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4659 C Derivatives due to the contact function
4660 gacont_hbr(1,num_conti,i)=fprimcont*xj
4661 gacont_hbr(2,num_conti,i)=fprimcont*yj
4662 gacont_hbr(3,num_conti,i)=fprimcont*zj
4665 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4666 c following the change of gradient-summation algorithm.
4668 cgrad ghalfp=0.5D0*gggp(k)
4669 cgrad ghalfm=0.5D0*gggm(k)
4670 gacontp_hb1(k,num_conti,i)=!ghalfp
4671 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4672 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4673 & *fac_shield(i)*fac_shield(j)*sss
4675 gacontp_hb2(k,num_conti,i)=!ghalfp
4676 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4677 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4678 & *fac_shield(i)*fac_shield(j)*sss
4680 gacontp_hb3(k,num_conti,i)=gggp(k)
4681 & *fac_shield(i)*fac_shield(j)*sss
4683 gacontm_hb1(k,num_conti,i)=!ghalfm
4684 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4685 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4686 & *fac_shield(i)*fac_shield(j)*sss
4688 gacontm_hb2(k,num_conti,i)=!ghalfm
4689 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4690 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4691 & *fac_shield(i)*fac_shield(j)*sss
4693 gacontm_hb3(k,num_conti,i)=gggm(k)
4694 & *fac_shield(i)*fac_shield(j)*sss
4697 C Diagnostics. Comment out or remove after debugging!
4699 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4700 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4701 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4702 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4703 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4704 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4707 endif ! num_conti.le.maxconts
4711 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4714 ghalf=0.5d0*agg(l,k)
4715 aggi(l,k)=aggi(l,k)+ghalf
4716 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4717 aggj(l,k)=aggj(l,k)+ghalf
4720 if (j.eq.nres-1 .and. i.lt.j-2) then
4723 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4728 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4731 C-----------------------------------------------------------------------------
4732 subroutine eturn3(i,eello_turn3)
4733 C Third- and fourth-order contributions from turns
4734 implicit real*8 (a-h,o-z)
4735 include 'DIMENSIONS'
4736 include 'COMMON.IOUNITS'
4737 include 'COMMON.GEO'
4738 include 'COMMON.VAR'
4739 include 'COMMON.LOCAL'
4740 include 'COMMON.CHAIN'
4741 include 'COMMON.DERIV'
4742 include 'COMMON.INTERACT'
4743 include 'COMMON.CORRMAT'
4744 include 'COMMON.TORSION'
4745 include 'COMMON.VECTORS'
4746 include 'COMMON.FFIELD'
4747 include 'COMMON.CONTROL'
4748 include 'COMMON.SHIELD'
4750 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4751 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4752 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4753 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4754 & auxgmat2(2,2),auxgmatt2(2,2)
4755 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4756 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4757 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4758 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4761 c write (iout,*) "eturn3",i,j,j1,j2
4766 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4768 C Third-order contributions
4775 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4776 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4777 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4778 c auxalary matices for theta gradient
4779 c auxalary matrix for i+1 and constant i+2
4780 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4781 c auxalary matrix for i+2 and constant i+1
4782 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4783 call transpose2(auxmat(1,1),auxmat1(1,1))
4784 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4785 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4786 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4787 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4788 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4789 if (shield_mode.eq.0) then
4796 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4797 & *fac_shield(i)*fac_shield(j)
4798 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4799 & *fac_shield(i)*fac_shield(j)
4800 if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4803 C Derivatives in theta
4804 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4805 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4806 & *fac_shield(i)*fac_shield(j)
4807 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4808 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4809 & *fac_shield(i)*fac_shield(j)
4812 C Derivatives in shield mode
4813 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4814 & (shield_mode.gt.0)) then
4817 do ilist=1,ishield_list(i)
4818 iresshield=shield_list(ilist,i)
4820 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4822 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4824 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4825 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4829 do ilist=1,ishield_list(j)
4830 iresshield=shield_list(ilist,j)
4832 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4834 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4836 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4837 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4844 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4845 & grad_shield(k,i)*eello_t3/fac_shield(i)
4846 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4847 & grad_shield(k,j)*eello_t3/fac_shield(j)
4848 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4849 & grad_shield(k,i)*eello_t3/fac_shield(i)
4850 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4851 & grad_shield(k,j)*eello_t3/fac_shield(j)
4855 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4856 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
4857 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
4858 cd & ' eello_turn3_num',4*eello_turn3_num
4859 C Derivatives in gamma(i)
4860 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4861 call transpose2(auxmat2(1,1),auxmat3(1,1))
4862 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4863 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4864 & *fac_shield(i)*fac_shield(j)
4865 C Derivatives in gamma(i+1)
4866 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4867 call transpose2(auxmat2(1,1),auxmat3(1,1))
4868 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4869 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4870 & +0.5d0*(pizda(1,1)+pizda(2,2))
4871 & *fac_shield(i)*fac_shield(j)
4872 C Cartesian derivatives
4874 c ghalf1=0.5d0*agg(l,1)
4875 c ghalf2=0.5d0*agg(l,2)
4876 c ghalf3=0.5d0*agg(l,3)
4877 c ghalf4=0.5d0*agg(l,4)
4878 a_temp(1,1)=aggi(l,1)!+ghalf1
4879 a_temp(1,2)=aggi(l,2)!+ghalf2
4880 a_temp(2,1)=aggi(l,3)!+ghalf3
4881 a_temp(2,2)=aggi(l,4)!+ghalf4
4882 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4883 gcorr3_turn(l,i)=gcorr3_turn(l,i)
4884 & +0.5d0*(pizda(1,1)+pizda(2,2))
4885 & *fac_shield(i)*fac_shield(j)
4887 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4888 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4889 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4890 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4891 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4892 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4893 & +0.5d0*(pizda(1,1)+pizda(2,2))
4894 & *fac_shield(i)*fac_shield(j)
4895 a_temp(1,1)=aggj(l,1)!+ghalf1
4896 a_temp(1,2)=aggj(l,2)!+ghalf2
4897 a_temp(2,1)=aggj(l,3)!+ghalf3
4898 a_temp(2,2)=aggj(l,4)!+ghalf4
4899 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4900 gcorr3_turn(l,j)=gcorr3_turn(l,j)
4901 & +0.5d0*(pizda(1,1)+pizda(2,2))
4902 & *fac_shield(i)*fac_shield(j)
4903 a_temp(1,1)=aggj1(l,1)
4904 a_temp(1,2)=aggj1(l,2)
4905 a_temp(2,1)=aggj1(l,3)
4906 a_temp(2,2)=aggj1(l,4)
4907 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4908 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4909 & +0.5d0*(pizda(1,1)+pizda(2,2))
4910 & *fac_shield(i)*fac_shield(j)
4914 C-------------------------------------------------------------------------------
4915 subroutine eturn4(i,eello_turn4)
4916 C Third- and fourth-order contributions from turns
4917 implicit real*8 (a-h,o-z)
4918 include 'DIMENSIONS'
4919 include 'COMMON.IOUNITS'
4920 include 'COMMON.GEO'
4921 include 'COMMON.VAR'
4922 include 'COMMON.LOCAL'
4923 include 'COMMON.CHAIN'
4924 include 'COMMON.DERIV'
4925 include 'COMMON.INTERACT'
4926 include 'COMMON.CORRMAT'
4927 include 'COMMON.TORSION'
4928 include 'COMMON.VECTORS'
4929 include 'COMMON.FFIELD'
4930 include 'COMMON.CONTROL'
4931 include 'COMMON.SHIELD'
4933 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4934 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4935 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4936 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4937 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
4938 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4939 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(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 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4948 C Fourth-order contributions
4956 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4957 cd call checkint_turn4(i,a_temp,eello_turn4_num)
4958 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4959 c write(iout,*)"WCHODZE W PROGRAM"
4964 iti1=itype2loc(itype(i+1))
4965 iti2=itype2loc(itype(i+2))
4966 iti3=itype2loc(itype(i+3))
4967 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4968 call transpose2(EUg(1,1,i+1),e1t(1,1))
4969 call transpose2(Eug(1,1,i+2),e2t(1,1))
4970 call transpose2(Eug(1,1,i+3),e3t(1,1))
4971 C Ematrix derivative in theta
4972 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4973 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4974 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4975 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4976 c eta1 in derivative theta
4977 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4978 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4979 c auxgvec is derivative of Ub2 so i+3 theta
4980 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4981 c auxalary matrix of E i+1
4982 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4985 s1=scalar2(b1(1,i+2),auxvec(1))
4986 c derivative of theta i+2 with constant i+3
4987 gs23=scalar2(gtb1(1,i+2),auxvec(1))
4988 c derivative of theta i+2 with constant i+2
4989 gs32=scalar2(b1(1,i+2),auxgvec(1))
4990 c derivative of E matix in theta of i+1
4991 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4993 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4994 c ea31 in derivative theta
4995 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4996 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4997 c auxilary matrix auxgvec of Ub2 with constant E matirx
4998 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4999 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5000 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5004 s2=scalar2(b1(1,i+1),auxvec(1))
5005 c derivative of theta i+1 with constant i+3
5006 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5007 c derivative of theta i+2 with constant i+1
5008 gs21=scalar2(b1(1,i+1),auxgvec(1))
5009 c derivative of theta i+3 with constant i+1
5010 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5011 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5013 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5014 c two derivatives over diffetent matrices
5015 c gtae3e2 is derivative over i+3
5016 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5017 c ae3gte2 is derivative over i+2
5018 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5019 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5020 c three possible derivative over theta E matices
5022 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5024 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5026 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5027 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5029 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5030 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5031 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5032 if (shield_mode.eq.0) then
5039 eello_turn4=eello_turn4-(s1+s2+s3)
5040 & *fac_shield(i)*fac_shield(j)
5041 eello_t4=-(s1+s2+s3)
5042 & *fac_shield(i)*fac_shield(j)
5043 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5044 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5045 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5046 C Now derivative over shield:
5047 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5048 & (shield_mode.gt.0)) then
5051 do ilist=1,ishield_list(i)
5052 iresshield=shield_list(ilist,i)
5054 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5056 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5058 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5059 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5063 do ilist=1,ishield_list(j)
5064 iresshield=shield_list(ilist,j)
5066 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5068 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5070 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5071 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5078 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5079 & grad_shield(k,i)*eello_t4/fac_shield(i)
5080 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5081 & grad_shield(k,j)*eello_t4/fac_shield(j)
5082 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5083 & grad_shield(k,i)*eello_t4/fac_shield(i)
5084 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5085 & grad_shield(k,j)*eello_t4/fac_shield(j)
5094 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5095 cd & ' eello_turn4_num',8*eello_turn4_num
5097 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5098 & -(gs13+gsE13+gsEE1)*wturn4
5099 & *fac_shield(i)*fac_shield(j)
5100 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5101 & -(gs23+gs21+gsEE2)*wturn4
5102 & *fac_shield(i)*fac_shield(j)
5104 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5105 & -(gs32+gsE31+gsEE3)*wturn4
5106 & *fac_shield(i)*fac_shield(j)
5108 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5111 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5112 & 'eturn4',i,j,-(s1+s2+s3)
5113 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5114 c & ' eello_turn4_num',8*eello_turn4_num
5115 C Derivatives in gamma(i)
5116 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5117 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5118 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5119 s1=scalar2(b1(1,i+2),auxvec(1))
5120 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5121 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5122 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5123 & *fac_shield(i)*fac_shield(j)
5124 C Derivatives in gamma(i+1)
5125 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5126 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5127 s2=scalar2(b1(1,i+1),auxvec(1))
5128 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5129 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5130 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5131 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5132 & *fac_shield(i)*fac_shield(j)
5133 C Derivatives in gamma(i+2)
5134 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5135 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5136 s1=scalar2(b1(1,i+2),auxvec(1))
5137 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5138 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5139 s2=scalar2(b1(1,i+1),auxvec(1))
5140 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5141 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5142 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5143 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5144 & *fac_shield(i)*fac_shield(j)
5145 C Cartesian derivatives
5146 C Derivatives of this turn contributions in DC(i+2)
5147 if (j.lt.nres-1) then
5149 a_temp(1,1)=agg(l,1)
5150 a_temp(1,2)=agg(l,2)
5151 a_temp(2,1)=agg(l,3)
5152 a_temp(2,2)=agg(l,4)
5153 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5154 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5155 s1=scalar2(b1(1,i+2),auxvec(1))
5156 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5157 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5158 s2=scalar2(b1(1,i+1),auxvec(1))
5159 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5160 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5161 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5163 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5164 & *fac_shield(i)*fac_shield(j)
5167 C Remaining derivatives of this turn contribution
5169 a_temp(1,1)=aggi(l,1)
5170 a_temp(1,2)=aggi(l,2)
5171 a_temp(2,1)=aggi(l,3)
5172 a_temp(2,2)=aggi(l,4)
5173 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5174 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5175 s1=scalar2(b1(1,i+2),auxvec(1))
5176 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5177 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5178 s2=scalar2(b1(1,i+1),auxvec(1))
5179 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5180 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5181 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5182 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5183 & *fac_shield(i)*fac_shield(j)
5184 a_temp(1,1)=aggi1(l,1)
5185 a_temp(1,2)=aggi1(l,2)
5186 a_temp(2,1)=aggi1(l,3)
5187 a_temp(2,2)=aggi1(l,4)
5188 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5189 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5190 s1=scalar2(b1(1,i+2),auxvec(1))
5191 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5192 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5193 s2=scalar2(b1(1,i+1),auxvec(1))
5194 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5195 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5196 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5197 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5198 & *fac_shield(i)*fac_shield(j)
5199 a_temp(1,1)=aggj(l,1)
5200 a_temp(1,2)=aggj(l,2)
5201 a_temp(2,1)=aggj(l,3)
5202 a_temp(2,2)=aggj(l,4)
5203 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5204 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5205 s1=scalar2(b1(1,i+2),auxvec(1))
5206 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5207 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5208 s2=scalar2(b1(1,i+1),auxvec(1))
5209 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5210 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5211 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5212 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5213 & *fac_shield(i)*fac_shield(j)
5214 a_temp(1,1)=aggj1(l,1)
5215 a_temp(1,2)=aggj1(l,2)
5216 a_temp(2,1)=aggj1(l,3)
5217 a_temp(2,2)=aggj1(l,4)
5218 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5219 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5220 s1=scalar2(b1(1,i+2),auxvec(1))
5221 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5222 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5223 s2=scalar2(b1(1,i+1),auxvec(1))
5224 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5225 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5226 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5227 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5228 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5229 & *fac_shield(i)*fac_shield(j)
5233 C-----------------------------------------------------------------------------
5234 subroutine vecpr(u,v,w)
5235 implicit real*8(a-h,o-z)
5236 dimension u(3),v(3),w(3)
5237 w(1)=u(2)*v(3)-u(3)*v(2)
5238 w(2)=-u(1)*v(3)+u(3)*v(1)
5239 w(3)=u(1)*v(2)-u(2)*v(1)
5242 C-----------------------------------------------------------------------------
5243 subroutine unormderiv(u,ugrad,unorm,ungrad)
5244 C This subroutine computes the derivatives of a normalized vector u, given
5245 C the derivatives computed without normalization conditions, ugrad. Returns
5248 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5249 double precision vec(3)
5250 double precision scalar
5252 c write (2,*) 'ugrad',ugrad
5255 vec(i)=scalar(ugrad(1,i),u(1))
5257 c write (2,*) 'vec',vec
5260 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5263 c write (2,*) 'ungrad',ungrad
5266 C-----------------------------------------------------------------------------
5267 subroutine escp_soft_sphere(evdw2,evdw2_14)
5269 C This subroutine calculates the excluded-volume interaction energy between
5270 C peptide-group centers and side chains and its gradient in virtual-bond and
5271 C side-chain vectors.
5273 implicit real*8 (a-h,o-z)
5274 include 'DIMENSIONS'
5275 include 'COMMON.GEO'
5276 include 'COMMON.VAR'
5277 include 'COMMON.LOCAL'
5278 include 'COMMON.CHAIN'
5279 include 'COMMON.DERIV'
5280 include 'COMMON.INTERACT'
5281 include 'COMMON.FFIELD'
5282 include 'COMMON.IOUNITS'
5283 include 'COMMON.CONTROL'
5285 double precision boxshift
5289 cd print '(a)','Enter ESCP'
5290 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5294 c do i=iatscp_s,iatscp_e
5295 do ikont=g_listscp_start,g_listscp_end
5296 i=newcontlistscpi(ikont)
5297 j=newcontlistscpj(ikont)
5298 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5300 xi=0.5D0*(c(1,i)+c(1,i+1))
5301 yi=0.5D0*(c(2,i)+c(2,i+1))
5302 zi=0.5D0*(c(3,i)+c(3,i+1))
5303 C Return atom into box, boxxsize is size of box in x dimension
5305 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5306 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5307 C Condition for being inside the proper box
5308 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5309 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5313 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5314 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5315 C Condition for being inside the proper box
5316 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5317 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5321 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5322 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5323 cC Condition for being inside the proper box
5324 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5325 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5328 call to_box(xi,yi,zi)
5329 C xi=xi+xshift*boxxsize
5330 C yi=yi+yshift*boxysize
5331 C zi=zi+zshift*boxzsize
5332 c do iint=1,nscp_gr(i)
5334 c do j=iscpstart(i,iint),iscpend(i,iint)
5335 if (itype(j).eq.ntyp1) cycle
5336 itypj=iabs(itype(j))
5337 C Uncomment following three lines for SC-p interactions
5341 C Uncomment following three lines for Ca-p interactions
5345 call to_box(xj,yj,zj)
5346 xj=boxshift(xj-xi,boxxsize)
5347 yj=boxshift(yj-yi,boxysize)
5348 zj=boxshift(zj-zi,boxzsize)
5352 rij=xj*xj+yj*yj+zj*zj
5356 if (rij.lt.r0ijsq) then
5357 evdwij=0.25d0*(rij-r0ijsq)**2
5365 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5371 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5372 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5383 C-----------------------------------------------------------------------------
5384 subroutine escp(evdw2,evdw2_14)
5386 C This subroutine calculates the excluded-volume interaction energy between
5387 C peptide-group centers and side chains and its gradient in virtual-bond and
5388 C side-chain vectors.
5391 include 'DIMENSIONS'
5392 include 'COMMON.GEO'
5393 include 'COMMON.VAR'
5394 include 'COMMON.LOCAL'
5395 include 'COMMON.CHAIN'
5396 include 'COMMON.DERIV'
5397 include 'COMMON.INTERACT'
5398 include 'COMMON.FFIELD'
5399 include 'COMMON.IOUNITS'
5400 include 'COMMON.CONTROL'
5401 include 'COMMON.SPLITELE'
5402 double precision ggg(3)
5403 integer i,iint,j,k,iteli,itypj,subchap,ikont
5404 double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5406 double precision evdw2,evdw2_14,evdwij
5407 double precision sscale,sscagrad
5408 double precision boxshift
5411 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5412 cd print '(a)','Enter ESCP'
5413 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5417 if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5418 c do i=iatscp_s,iatscp_e
5419 do ikont=g_listscp_start,g_listscp_end
5420 i=newcontlistscpi(ikont)
5421 j=newcontlistscpj(ikont)
5422 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5424 xi=0.5D0*(c(1,i)+c(1,i+1))
5425 yi=0.5D0*(c(2,i)+c(2,i+1))
5426 zi=0.5D0*(c(3,i)+c(3,i+1))
5427 call to_box(xi,yi,zi)
5428 c do iint=1,nscp_gr(i)
5430 c do j=iscpstart(i,iint),iscpend(i,iint)
5431 itypj=iabs(itype(j))
5432 if (itypj.eq.ntyp1) cycle
5433 C Uncomment following three lines for SC-p interactions
5437 C Uncomment following three lines for Ca-p interactions
5441 call to_box(xj,yj,zj)
5442 xj=boxshift(xj-xi,boxxsize)
5443 yj=boxshift(yj-yi,boxysize)
5444 zj=boxshift(zj-zi,boxzsize)
5445 c print *,xj,yj,zj,'polozenie j'
5446 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5448 sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5449 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5450 c if (sss.eq.0) print *,'czasem jest OK'
5451 if (sss.le.0.0d0) cycle
5452 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5454 e1=fac*fac*aad(itypj,iteli)
5455 e2=fac*bad(itypj,iteli)
5456 if (iabs(j-i) .le. 2) then
5459 evdw2_14=evdw2_14+(e1+e2)*sss
5462 evdw2=evdw2+evdwij*sss
5463 if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5464 & 'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5465 & evdwij,iteli,itypj,fac,aad(itypj,iteli),
5468 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5470 fac=-(evdwij+e1)*rrij*sss
5471 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5475 cgrad if (j.lt.i) then
5476 cd write (iout,*) 'j<i'
5477 C Uncomment following three lines for SC-p interactions
5479 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5482 cd write (iout,*) 'j>i'
5484 cgrad ggg(k)=-ggg(k)
5485 C Uncomment following line for SC-p interactions
5486 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5487 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5491 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5493 cgrad kstart=min0(i+1,j)
5494 cgrad kend=max0(i-1,j-1)
5495 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5496 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5497 cgrad do k=kstart,kend
5499 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5503 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5504 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5506 c endif !endif for sscale cutoff
5516 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5517 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5518 gradx_scp(j,i)=expon*gradx_scp(j,i)
5521 C******************************************************************************
5525 C To save time the factor EXPON has been extracted from ALL components
5526 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5529 C******************************************************************************
5532 C--------------------------------------------------------------------------
5533 subroutine edis(ehpb)
5535 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5537 implicit real*8 (a-h,o-z)
5538 include 'DIMENSIONS'
5539 include 'COMMON.SBRIDGE'
5540 include 'COMMON.CHAIN'
5541 include 'COMMON.DERIV'
5542 include 'COMMON.VAR'
5543 include 'COMMON.INTERACT'
5544 include 'COMMON.IOUNITS'
5545 include 'COMMON.CONTROL'
5546 dimension ggg(3),ggg_peak(3,1000)
5551 c 8/21/18 AL: added explicit restraints on reference coords
5552 c write (iout,*) "restr_on_coord",restr_on_coord
5553 if (restr_on_coord) then
5557 if (itype(i).eq.ntyp1) cycle
5559 ecoor=ecoor+(c(j,i)-cref(j,i))**2
5560 ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5562 if (itype(i).ne.10) then
5564 ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5565 ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5568 if (energy_dec) write (iout,*)
5569 & "i",i," bfac",bfac(i)," ecoor",ecoor
5570 ehpb=ehpb+0.5d0*bfac(i)*ecoor
5574 C write (iout,*) ,"link_end",link_end,constr_dist
5575 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5576 c write(iout,*)'link_start=',link_start,' link_end=',link_end,
5577 c & " constr_dist",constr_dist," link_start_peak",link_start_peak,
5578 c & " link_end_peak",link_end_peak
5579 if (link_end.eq.0.and.link_end_peak.eq.0) return
5580 do i=link_start_peak,link_end_peak
5582 c print *,"i",i," link_end_peak",link_end_peak," ipeak",
5583 c & ipeak(1,i),ipeak(2,i)
5584 do ip=ipeak(1,i),ipeak(2,i)
5589 C iii and jjj point to the residues for which the distance is assigned.
5590 c if (ii.gt.nres) then
5597 if (ii.gt.nres) then
5602 if (jj.gt.nres) then
5607 aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5608 aux=dexp(-scal_peak*aux)
5609 ehpb_peak=ehpb_peak+aux
5610 fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5611 & forcon_peak(ip))*aux/dd
5613 ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5615 if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5616 & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5617 & forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5619 c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5620 ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5621 do ip=ipeak(1,i),ipeak(2,i)
5624 ggg(j)=ggg_peak(j,iip)/ehpb_peak
5628 C iii and jjj point to the residues for which the distance is assigned.
5629 c if (ii.gt.nres) then
5636 if (ii.gt.nres) then
5641 if (jj.gt.nres) then
5648 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5653 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5657 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5658 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5662 do i=link_start,link_end
5663 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5664 C CA-CA distance used in regularization of structure.
5667 C iii and jjj point to the residues for which the distance is assigned.
5668 if (ii.gt.nres) then
5673 if (jj.gt.nres) then
5678 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5679 c & dhpb(i),dhpb1(i),forcon(i)
5680 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5681 C distance and angle dependent SS bond potential.
5682 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5683 C & iabs(itype(jjj)).eq.1) then
5684 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5685 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5686 if (.not.dyn_ss .and. i.le.nss) then
5687 C 15/02/13 CC dynamic SSbond - additional check
5688 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5689 & iabs(itype(jjj)).eq.1) then
5690 call ssbond_ene(iii,jjj,eij)
5693 cd write (iout,*) "eij",eij
5694 cd & ' waga=',waga,' fac=',fac
5695 ! else if (ii.gt.nres .and. jj.gt.nres) then
5697 C Calculate the distance between the two points and its difference from the
5700 if (irestr_type(i).eq.11) then
5701 ehpb=ehpb+fordepth(i)!**4.0d0
5702 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5703 fac=fordepth(i)!**4.0d0
5704 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5705 if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5706 & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5707 & ehpb,irestr_type(i)
5708 else if (irestr_type(i).eq.10) then
5709 c AL 6//19/2018 cross-link restraints
5710 xdis = 0.5d0*(dd/forcon(i))**2
5711 expdis = dexp(-xdis)
5712 c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5713 aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5714 c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5715 c & " wboltzd",wboltzd
5716 ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5717 c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5718 fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5719 & *expdis/(aux*forcon(i)**2)
5720 if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5721 & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5722 & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5723 else if (irestr_type(i).eq.2) then
5724 c Quartic restraints
5725 ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5726 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5727 & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5728 & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5729 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5731 c Quadratic restraints
5733 C Get the force constant corresponding to this distance.
5735 C Calculate the contribution to energy.
5736 ehpb=ehpb+0.5d0*waga*rdis*rdis
5737 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5738 & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5739 & 0.5d0*waga*rdis*rdis,irestr_type(i)
5741 C Evaluate gradient.
5745 c Calculate Cartesian gradient
5747 ggg(j)=fac*(c(j,jj)-c(j,ii))
5749 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5750 C If this is a SC-SC distance, we need to calculate the contributions to the
5751 C Cartesian gradient in the SC vectors (ghpbx).
5754 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5759 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5763 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5764 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5770 C--------------------------------------------------------------------------
5771 subroutine ssbond_ene(i,j,eij)
5773 C Calculate the distance and angle dependent SS-bond potential energy
5774 C using a free-energy function derived based on RHF/6-31G** ab initio
5775 C calculations of diethyl disulfide.
5777 C A. Liwo and U. Kozlowska, 11/24/03
5779 implicit real*8 (a-h,o-z)
5780 include 'DIMENSIONS'
5781 include 'COMMON.SBRIDGE'
5782 include 'COMMON.CHAIN'
5783 include 'COMMON.DERIV'
5784 include 'COMMON.LOCAL'
5785 include 'COMMON.INTERACT'
5786 include 'COMMON.VAR'
5787 include 'COMMON.IOUNITS'
5788 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5789 itypi=iabs(itype(i))
5793 dxi=dc_norm(1,nres+i)
5794 dyi=dc_norm(2,nres+i)
5795 dzi=dc_norm(3,nres+i)
5796 c dsci_inv=dsc_inv(itypi)
5797 dsci_inv=vbld_inv(nres+i)
5798 itypj=iabs(itype(j))
5799 c dscj_inv=dsc_inv(itypj)
5800 dscj_inv=vbld_inv(nres+j)
5804 dxj=dc_norm(1,nres+j)
5805 dyj=dc_norm(2,nres+j)
5806 dzj=dc_norm(3,nres+j)
5807 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5812 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5813 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5814 om12=dxi*dxj+dyi*dyj+dzi*dzj
5816 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5817 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5823 deltat12=om2-om1+2.0d0
5825 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5826 & +akct*deltad*deltat12
5827 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5828 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5829 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5830 c & " deltat12",deltat12," eij",eij
5831 ed=2*akcm*deltad+akct*deltat12
5833 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5834 eom1=-2*akth*deltat1-pom1-om2*pom2
5835 eom2= 2*akth*deltat2+pom1-om1*pom2
5838 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5839 ghpbx(k,i)=ghpbx(k,i)-ggk
5840 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5841 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5842 ghpbx(k,j)=ghpbx(k,j)+ggk
5843 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5844 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5845 ghpbc(k,i)=ghpbc(k,i)-ggk
5846 ghpbc(k,j)=ghpbc(k,j)+ggk
5849 C Calculate the components of the gradient in DC and X
5853 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
5858 C--------------------------------------------------------------------------
5859 subroutine ebond(estr)
5861 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5863 implicit real*8 (a-h,o-z)
5864 include 'DIMENSIONS'
5865 include 'COMMON.LOCAL'
5866 include 'COMMON.GEO'
5867 include 'COMMON.INTERACT'
5868 include 'COMMON.DERIV'
5869 include 'COMMON.VAR'
5870 include 'COMMON.CHAIN'
5871 include 'COMMON.IOUNITS'
5872 include 'COMMON.NAMES'
5873 include 'COMMON.FFIELD'
5874 include 'COMMON.CONTROL'
5875 include 'COMMON.SETUP'
5876 double precision u(3),ud(3)
5879 do i=ibondp_start,ibondp_end
5880 c 3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
5883 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5884 diff = vbld(i)-vbldp0
5886 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5887 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5889 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5890 c & *dc(j,i-1)/vbld(i)
5892 c if (energy_dec) write(iout,*)
5893 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5895 C Checking if it involves dummy (NH3+ or COO-) group
5896 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5897 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
5898 diff = vbld(i)-vbldpDUM
5899 if (energy_dec) write(iout,*) "dum_bond",i,diff
5901 C NO vbldp0 is the equlibrium length of spring for peptide group
5902 diff = vbld(i)-vbldp0
5905 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5906 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5909 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5911 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5915 estr=0.5d0*AKP*estr+estr1
5917 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5919 do i=ibond_start,ibond_end
5921 if (iti.ne.10 .and. iti.ne.ntyp1) then
5924 diff=vbld(i+nres)-vbldsc0(1,iti)
5925 if (energy_dec) write (iout,*)
5926 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5927 & AKSC(1,iti),AKSC(1,iti)*diff*diff
5928 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5930 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5934 diff=vbld(i+nres)-vbldsc0(j,iti)
5935 ud(j)=aksc(j,iti)*diff
5936 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5950 uprod2=uprod2*u(k)*u(k)
5954 usumsqder=usumsqder+ud(j)*uprod2
5956 estr=estr+uprod/usum
5958 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5966 C--------------------------------------------------------------------------
5967 subroutine ebend(etheta)
5969 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5970 C angles gamma and its derivatives in consecutive thetas and gammas.
5972 implicit real*8 (a-h,o-z)
5973 include 'DIMENSIONS'
5974 include 'COMMON.LOCAL'
5975 include 'COMMON.GEO'
5976 include 'COMMON.INTERACT'
5977 include 'COMMON.DERIV'
5978 include 'COMMON.VAR'
5979 include 'COMMON.CHAIN'
5980 include 'COMMON.IOUNITS'
5981 include 'COMMON.NAMES'
5982 include 'COMMON.FFIELD'
5983 include 'COMMON.CONTROL'
5984 include 'COMMON.TORCNSTR'
5985 common /calcthet/ term1,term2,termm,diffak,ratak,
5986 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5987 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5988 double precision y(2),z(2)
5990 c time11=dexp(-2*time)
5993 c write (*,'(a,i2)') 'EBEND ICG=',icg
5994 do i=ithet_start,ithet_end
5995 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5996 & .or.itype(i).eq.ntyp1) cycle
5997 C Zero the energy function and its derivative at 0 or pi.
5998 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6000 ichir1=isign(1,itype(i-2))
6001 ichir2=isign(1,itype(i))
6002 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6003 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6004 if (itype(i-1).eq.10) then
6005 itype1=isign(10,itype(i-2))
6006 ichir11=isign(1,itype(i-2))
6007 ichir12=isign(1,itype(i-2))
6008 itype2=isign(10,itype(i))
6009 ichir21=isign(1,itype(i))
6010 ichir22=isign(1,itype(i))
6013 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6016 if (phii.ne.phii) phii=150.0
6026 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6029 if (phii1.ne.phii1) phii1=150.0
6041 C Calculate the "mean" value of theta from the part of the distribution
6042 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6043 C In following comments this theta will be referred to as t_c.
6044 thet_pred_mean=0.0d0
6046 athetk=athet(k,it,ichir1,ichir2)
6047 bthetk=bthet(k,it,ichir1,ichir2)
6049 athetk=athet(k,itype1,ichir11,ichir12)
6050 bthetk=bthet(k,itype2,ichir21,ichir22)
6052 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6053 c write(iout,*) 'chuj tu', y(k),z(k)
6055 dthett=thet_pred_mean*ssd
6056 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6057 C Derivatives of the "mean" values in gamma1 and gamma2.
6058 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6059 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6060 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6061 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6063 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6064 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6065 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6066 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6068 if (theta(i).gt.pi-delta) then
6069 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6071 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6072 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6073 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6075 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6077 else if (theta(i).lt.delta) then
6078 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6079 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6080 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6082 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6083 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6086 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6089 etheta=etheta+ethetai
6090 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6091 & 'ebend',i,ethetai,theta(i),itype(i)
6092 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6093 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6094 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6097 C Ufff.... We've done all this!!!
6100 C---------------------------------------------------------------------------
6101 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6103 implicit real*8 (a-h,o-z)
6104 include 'DIMENSIONS'
6105 include 'COMMON.LOCAL'
6106 include 'COMMON.IOUNITS'
6107 common /calcthet/ term1,term2,termm,diffak,ratak,
6108 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6109 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6110 C Calculate the contributions to both Gaussian lobes.
6111 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6112 C The "polynomial part" of the "standard deviation" of this part of
6113 C the distributioni.
6114 ccc write (iout,*) thetai,thet_pred_mean
6117 sig=sig*thet_pred_mean+polthet(j,it)
6119 C Derivative of the "interior part" of the "standard deviation of the"
6120 C gamma-dependent Gaussian lobe in t_c.
6121 sigtc=3*polthet(3,it)
6123 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6126 C Set the parameters of both Gaussian lobes of the distribution.
6127 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6128 fac=sig*sig+sigc0(it)
6131 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6132 sigsqtc=-4.0D0*sigcsq*sigtc
6133 c print *,i,sig,sigtc,sigsqtc
6134 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6135 sigtc=-sigtc/(fac*fac)
6136 C Following variable is sigma(t_c)**(-2)
6137 sigcsq=sigcsq*sigcsq
6139 sig0inv=1.0D0/sig0i**2
6140 delthec=thetai-thet_pred_mean
6141 delthe0=thetai-theta0i
6142 term1=-0.5D0*sigcsq*delthec*delthec
6143 term2=-0.5D0*sig0inv*delthe0*delthe0
6144 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6145 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6146 C NaNs in taking the logarithm. We extract the largest exponent which is added
6147 C to the energy (this being the log of the distribution) at the end of energy
6148 C term evaluation for this virtual-bond angle.
6149 if (term1.gt.term2) then
6151 term2=dexp(term2-termm)
6155 term1=dexp(term1-termm)
6158 C The ratio between the gamma-independent and gamma-dependent lobes of
6159 C the distribution is a Gaussian function of thet_pred_mean too.
6160 diffak=gthet(2,it)-thet_pred_mean
6161 ratak=diffak/gthet(3,it)**2
6162 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6163 C Let's differentiate it in thet_pred_mean NOW.
6165 C Now put together the distribution terms to make complete distribution.
6166 termexp=term1+ak*term2
6167 termpre=sigc+ak*sig0i
6168 C Contribution of the bending energy from this theta is just the -log of
6169 C the sum of the contributions from the two lobes and the pre-exponential
6170 C factor. Simple enough, isn't it?
6171 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6172 C write (iout,*) 'termexp',termexp,termm,termpre,i
6173 C NOW the derivatives!!!
6174 C 6/6/97 Take into account the deformation.
6175 E_theta=(delthec*sigcsq*term1
6176 & +ak*delthe0*sig0inv*term2)/termexp
6177 E_tc=((sigtc+aktc*sig0i)/termpre
6178 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6179 & aktc*term2)/termexp)
6182 c-----------------------------------------------------------------------------
6183 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6184 implicit real*8 (a-h,o-z)
6185 include 'DIMENSIONS'
6186 include 'COMMON.LOCAL'
6187 include 'COMMON.IOUNITS'
6188 common /calcthet/ term1,term2,termm,diffak,ratak,
6189 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6190 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6191 delthec=thetai-thet_pred_mean
6192 delthe0=thetai-theta0i
6193 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6194 t3 = thetai-thet_pred_mean
6198 t14 = t12+t6*sigsqtc
6200 t21 = thetai-theta0i
6206 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6207 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6208 & *(-t12*t9-ak*sig0inv*t27)
6212 C--------------------------------------------------------------------------
6213 subroutine ebend(etheta)
6215 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6216 C angles gamma and its derivatives in consecutive thetas and gammas.
6217 C ab initio-derived potentials from
6218 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6220 implicit real*8 (a-h,o-z)
6221 include 'DIMENSIONS'
6222 include 'COMMON.LOCAL'
6223 include 'COMMON.GEO'
6224 include 'COMMON.INTERACT'
6225 include 'COMMON.DERIV'
6226 include 'COMMON.VAR'
6227 include 'COMMON.CHAIN'
6228 include 'COMMON.IOUNITS'
6229 include 'COMMON.NAMES'
6230 include 'COMMON.FFIELD'
6231 include 'COMMON.CONTROL'
6232 include 'COMMON.TORCNSTR'
6233 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6234 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6235 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6236 & sinph1ph2(maxdouble,maxdouble)
6237 logical lprn /.false./, lprn1 /.false./
6239 do i=ithet_start,ithet_end
6240 c print *,i,itype(i-1),itype(i),itype(i-2)
6241 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6242 & .or.itype(i).eq.ntyp1) cycle
6243 C print *,i,theta(i)
6244 if (iabs(itype(i+1)).eq.20) iblock=2
6245 if (iabs(itype(i+1)).ne.20) iblock=1
6249 theti2=0.5d0*theta(i)
6250 ityp2=ithetyp((itype(i-1)))
6252 coskt(k)=dcos(k*theti2)
6253 sinkt(k)=dsin(k*theti2)
6256 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6259 if (phii.ne.phii) phii=150.0
6263 ityp1=ithetyp((itype(i-2)))
6264 C propagation of chirality for glycine type
6266 cosph1(k)=dcos(k*phii)
6267 sinph1(k)=dsin(k*phii)
6272 ityp1=ithetyp((itype(i-2)))
6277 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6280 if (phii1.ne.phii1) phii1=150.0
6285 ityp3=ithetyp((itype(i)))
6287 cosph2(k)=dcos(k*phii1)
6288 sinph2(k)=dsin(k*phii1)
6292 ityp3=ithetyp((itype(i)))
6298 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6301 ccl=cosph1(l)*cosph2(k-l)
6302 ssl=sinph1(l)*sinph2(k-l)
6303 scl=sinph1(l)*cosph2(k-l)
6304 csl=cosph1(l)*sinph2(k-l)
6305 cosph1ph2(l,k)=ccl-ssl
6306 cosph1ph2(k,l)=ccl+ssl
6307 sinph1ph2(l,k)=scl+csl
6308 sinph1ph2(k,l)=scl-csl
6312 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6313 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6314 write (iout,*) "coskt and sinkt"
6316 write (iout,*) k,coskt(k),sinkt(k)
6320 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6321 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6324 & write (iout,*) "k",k,"
6325 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6326 & " ethetai",ethetai
6329 write (iout,*) "cosph and sinph"
6331 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6333 write (iout,*) "cosph1ph2 and sinph2ph2"
6336 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6337 & sinph1ph2(l,k),sinph1ph2(k,l)
6340 write(iout,*) "ethetai",ethetai
6345 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6346 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6347 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6348 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6349 ethetai=ethetai+sinkt(m)*aux
6350 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6351 dephii=dephii+k*sinkt(m)*(
6352 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6353 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6354 dephii1=dephii1+k*sinkt(m)*(
6355 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6356 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6358 & write (iout,*) "m",m," k",k," bbthet",
6359 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6360 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6361 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6362 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6363 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6366 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6367 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6368 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6369 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6371 & write(iout,*) "ethetai",ethetai
6372 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6376 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6377 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6378 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6379 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6380 ethetai=ethetai+sinkt(m)*aux
6381 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6382 dephii=dephii+l*sinkt(m)*(
6383 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6384 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6385 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6386 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6387 dephii1=dephii1+(k-l)*sinkt(m)*(
6388 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6389 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6390 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6391 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6393 write (iout,*) "m",m," k",k," l",l," ffthet",
6394 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6395 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6396 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6397 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6398 & " ethetai",ethetai
6399 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6400 & cosph1ph2(k,l)*sinkt(m),
6401 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6410 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6411 & i,theta(i)*rad2deg,phii*rad2deg,
6412 & phii1*rad2deg,ethetai
6414 etheta=etheta+ethetai
6415 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6416 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6417 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6424 c-----------------------------------------------------------------------------
6425 subroutine esc(escloc)
6426 C Calculate the local energy of a side chain and its derivatives in the
6427 C corresponding virtual-bond valence angles THETA and the spherical angles
6429 implicit real*8 (a-h,o-z)
6430 include 'DIMENSIONS'
6431 include 'COMMON.GEO'
6432 include 'COMMON.LOCAL'
6433 include 'COMMON.VAR'
6434 include 'COMMON.INTERACT'
6435 include 'COMMON.DERIV'
6436 include 'COMMON.CHAIN'
6437 include 'COMMON.IOUNITS'
6438 include 'COMMON.NAMES'
6439 include 'COMMON.FFIELD'
6440 include 'COMMON.CONTROL'
6441 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6442 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6443 common /sccalc/ time11,time12,time112,theti,it,nlobit
6446 c write (iout,'(a)') 'ESC'
6447 do i=loc_start,loc_end
6449 if (it.eq.ntyp1) cycle
6450 if (it.eq.10) goto 1
6451 nlobit=nlob(iabs(it))
6452 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6453 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6454 theti=theta(i+1)-pipol
6459 if (x(2).gt.pi-delta) then
6463 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6465 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6466 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6468 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6469 & ddersc0(1),dersc(1))
6470 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6471 & ddersc0(3),dersc(3))
6473 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6475 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6476 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6477 & dersc0(2),esclocbi,dersc02)
6478 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6480 call splinthet(x(2),0.5d0*delta,ss,ssd)
6485 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6487 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6488 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6490 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6492 c write (iout,*) escloci
6493 else if (x(2).lt.delta) then
6497 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6499 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6500 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6502 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6503 & ddersc0(1),dersc(1))
6504 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6505 & ddersc0(3),dersc(3))
6507 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6509 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6510 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6511 & dersc0(2),esclocbi,dersc02)
6512 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6517 call splinthet(x(2),0.5d0*delta,ss,ssd)
6519 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6521 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6522 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6524 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6525 c write (iout,*) escloci
6527 call enesc(x,escloci,dersc,ddummy,.false.)
6530 escloc=escloc+escloci
6531 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6532 & 'escloc',i,escloci
6533 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6535 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6537 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6538 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6543 C---------------------------------------------------------------------------
6544 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6545 implicit real*8 (a-h,o-z)
6546 include 'DIMENSIONS'
6547 include 'COMMON.GEO'
6548 include 'COMMON.LOCAL'
6549 include 'COMMON.IOUNITS'
6550 common /sccalc/ time11,time12,time112,theti,it,nlobit
6551 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6552 double precision contr(maxlob,-1:1)
6554 c write (iout,*) 'it=',it,' nlobit=',nlobit
6558 if (mixed) ddersc(j)=0.0d0
6562 C Because of periodicity of the dependence of the SC energy in omega we have
6563 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6564 C To avoid underflows, first compute & store the exponents.
6572 z(k)=x(k)-censc(k,j,it)
6577 Axk=Axk+gaussc(l,k,j,it)*z(l)
6583 expfac=expfac+Ax(k,j,iii)*z(k)
6591 C As in the case of ebend, we want to avoid underflows in exponentiation and
6592 C subsequent NaNs and INFs in energy calculation.
6593 C Find the largest exponent
6597 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6601 cd print *,'it=',it,' emin=',emin
6603 C Compute the contribution to SC energy and derivatives
6608 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6609 if(adexp.ne.adexp) adexp=1.0
6612 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6614 cd print *,'j=',j,' expfac=',expfac
6615 escloc_i=escloc_i+expfac
6617 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6621 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6622 & +gaussc(k,2,j,it))*expfac
6629 dersc(1)=dersc(1)/cos(theti)**2
6630 ddersc(1)=ddersc(1)/cos(theti)**2
6633 escloci=-(dlog(escloc_i)-emin)
6635 dersc(j)=dersc(j)/escloc_i
6639 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6644 C------------------------------------------------------------------------------
6645 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6646 implicit real*8 (a-h,o-z)
6647 include 'DIMENSIONS'
6648 include 'COMMON.GEO'
6649 include 'COMMON.LOCAL'
6650 include 'COMMON.IOUNITS'
6651 common /sccalc/ time11,time12,time112,theti,it,nlobit
6652 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6653 double precision contr(maxlob)
6664 z(k)=x(k)-censc(k,j,it)
6670 Axk=Axk+gaussc(l,k,j,it)*z(l)
6676 expfac=expfac+Ax(k,j)*z(k)
6681 C As in the case of ebend, we want to avoid underflows in exponentiation and
6682 C subsequent NaNs and INFs in energy calculation.
6683 C Find the largest exponent
6686 if (emin.gt.contr(j)) emin=contr(j)
6690 C Compute the contribution to SC energy and derivatives
6694 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6695 escloc_i=escloc_i+expfac
6697 dersc(k)=dersc(k)+Ax(k,j)*expfac
6699 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6700 & +gaussc(1,2,j,it))*expfac
6704 dersc(1)=dersc(1)/cos(theti)**2
6705 dersc12=dersc12/cos(theti)**2
6706 escloci=-(dlog(escloc_i)-emin)
6708 dersc(j)=dersc(j)/escloc_i
6710 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6714 c----------------------------------------------------------------------------------
6715 subroutine esc(escloc)
6716 C Calculate the local energy of a side chain and its derivatives in the
6717 C corresponding virtual-bond valence angles THETA and the spherical angles
6718 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6719 C added by Urszula Kozlowska. 07/11/2007
6721 implicit real*8 (a-h,o-z)
6722 include 'DIMENSIONS'
6723 include 'COMMON.GEO'
6724 include 'COMMON.LOCAL'
6725 include 'COMMON.VAR'
6726 include 'COMMON.SCROT'
6727 include 'COMMON.INTERACT'
6728 include 'COMMON.DERIV'
6729 include 'COMMON.CHAIN'
6730 include 'COMMON.IOUNITS'
6731 include 'COMMON.NAMES'
6732 include 'COMMON.FFIELD'
6733 include 'COMMON.CONTROL'
6734 include 'COMMON.VECTORS'
6735 double precision x_prime(3),y_prime(3),z_prime(3)
6736 & , sumene,dsc_i,dp2_i,x(65),
6737 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6738 & de_dxx,de_dyy,de_dzz,de_dt
6739 double precision s1_t,s1_6_t,s2_t,s2_6_t
6741 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6742 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6743 & dt_dCi(3),dt_dCi1(3)
6744 common /sccalc/ time11,time12,time112,theti,it,nlobit
6747 do i=loc_start,loc_end
6748 if (itype(i).eq.ntyp1) cycle
6749 costtab(i+1) =dcos(theta(i+1))
6750 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6751 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6752 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6753 cosfac2=0.5d0/(1.0d0+costtab(i+1))
6754 cosfac=dsqrt(cosfac2)
6755 sinfac2=0.5d0/(1.0d0-costtab(i+1))
6756 sinfac=dsqrt(sinfac2)
6758 if (it.eq.10) goto 1
6760 C Compute the axes of tghe local cartesian coordinates system; store in
6761 c x_prime, y_prime and z_prime
6768 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6769 C & dc_norm(3,i+nres)
6771 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6772 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6775 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6778 c write (2,*) "x_prime",(x_prime(j),j=1,3)
6779 c write (2,*) "y_prime",(y_prime(j),j=1,3)
6780 c write (2,*) "z_prime",(z_prime(j),j=1,3)
6781 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6782 c & " xy",scalar(x_prime(1),y_prime(1)),
6783 c & " xz",scalar(x_prime(1),z_prime(1)),
6784 c & " yy",scalar(y_prime(1),y_prime(1)),
6785 c & " yz",scalar(y_prime(1),z_prime(1)),
6786 c & " zz",scalar(z_prime(1),z_prime(1))
6788 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6789 C to local coordinate system. Store in xx, yy, zz.
6795 xx = xx + x_prime(j)*dc_norm(j,i+nres)
6796 yy = yy + y_prime(j)*dc_norm(j,i+nres)
6797 zz = zz + z_prime(j)*dc_norm(j,i+nres)
6804 C Compute the energy of the ith side cbain
6806 c write (2,*) "xx",xx," yy",yy," zz",zz
6809 x(j) = sc_parmin(j,it)
6812 Cc diagnostics - remove later
6814 yy1 = dsin(alph(2))*dcos(omeg(2))
6815 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6816 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6817 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6819 C," --- ", xx_w,yy_w,zz_w
6822 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
6823 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
6825 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6826 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6828 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6829 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6830 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6831 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6832 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6834 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6835 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6836 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6837 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6838 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6840 dsc_i = 0.743d0+x(61)
6842 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6843 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6844 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6845 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6846 s1=(1+x(63))/(0.1d0 + dscp1)
6847 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6848 s2=(1+x(65))/(0.1d0 + dscp2)
6849 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6850 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6851 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6852 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6854 c & dscp1,dscp2,sumene
6855 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6856 escloc = escloc + sumene
6857 if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
6858 & " escloc",sumene,escloc,it,itype(i)
6863 C This section to check the numerical derivatives of the energy of ith side
6864 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6865 C #define DEBUG in the code to turn it on.
6867 write (2,*) "sumene =",sumene
6871 write (2,*) xx,yy,zz
6872 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6873 de_dxx_num=(sumenep-sumene)/aincr
6875 write (2,*) "xx+ sumene from enesc=",sumenep
6878 write (2,*) xx,yy,zz
6879 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6880 de_dyy_num=(sumenep-sumene)/aincr
6882 write (2,*) "yy+ sumene from enesc=",sumenep
6885 write (2,*) xx,yy,zz
6886 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6887 de_dzz_num=(sumenep-sumene)/aincr
6889 write (2,*) "zz+ sumene from enesc=",sumenep
6890 costsave=cost2tab(i+1)
6891 sintsave=sint2tab(i+1)
6892 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6893 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6894 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6895 de_dt_num=(sumenep-sumene)/aincr
6896 write (2,*) " t+ sumene from enesc=",sumenep
6897 cost2tab(i+1)=costsave
6898 sint2tab(i+1)=sintsave
6899 C End of diagnostics section.
6902 C Compute the gradient of esc
6904 c zz=zz*dsign(1.0,dfloat(itype(i)))
6905 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6906 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6907 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6908 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6909 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6910 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6911 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6912 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6913 pom1=(sumene3*sint2tab(i+1)+sumene1)
6914 & *(pom_s1/dscp1+pom_s16*dscp1**4)
6915 pom2=(sumene4*cost2tab(i+1)+sumene2)
6916 & *(pom_s2/dscp2+pom_s26*dscp2**4)
6917 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6918 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6919 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6921 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6922 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6923 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6925 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6926 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6927 & +(pom1+pom2)*pom_dx
6929 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6932 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6933 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6934 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6936 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6937 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6938 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6939 & +x(59)*zz**2 +x(60)*xx*zz
6940 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6941 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6942 & +(pom1-pom2)*pom_dy
6944 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6947 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6948 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6949 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6950 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
6951 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
6952 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6953 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6954 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
6956 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6959 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6960 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6961 & +pom1*pom_dt1+pom2*pom_dt2
6963 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6968 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6969 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6970 cosfac2xx=cosfac2*xx
6971 sinfac2yy=sinfac2*yy
6973 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6975 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6977 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6978 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6979 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6980 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6981 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6982 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6983 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6984 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6985 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6986 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6990 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6991 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6992 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6993 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6996 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6997 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6998 dZZ_XYZ(k)=vbld_inv(i+nres)*
6999 & (z_prime(k)-zz*dC_norm(k,i+nres))
7001 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7002 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7006 dXX_Ctab(k,i)=dXX_Ci(k)
7007 dXX_C1tab(k,i)=dXX_Ci1(k)
7008 dYY_Ctab(k,i)=dYY_Ci(k)
7009 dYY_C1tab(k,i)=dYY_Ci1(k)
7010 dZZ_Ctab(k,i)=dZZ_Ci(k)
7011 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7012 dXX_XYZtab(k,i)=dXX_XYZ(k)
7013 dYY_XYZtab(k,i)=dYY_XYZ(k)
7014 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7018 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7019 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7020 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7021 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7022 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7024 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7025 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7026 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7027 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7028 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7029 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7030 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7031 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7033 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7034 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7036 C to check gradient call subroutine check_grad
7042 c------------------------------------------------------------------------------
7043 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7045 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7046 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7047 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7048 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7050 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7051 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7053 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7054 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7055 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7056 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7057 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7059 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7060 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7061 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7062 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7063 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7065 dsc_i = 0.743d0+x(61)
7067 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7068 & *(xx*cost2+yy*sint2))
7069 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7070 & *(xx*cost2-yy*sint2))
7071 s1=(1+x(63))/(0.1d0 + dscp1)
7072 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7073 s2=(1+x(65))/(0.1d0 + dscp2)
7074 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7075 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7076 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7081 c------------------------------------------------------------------------------
7082 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7084 C This procedure calculates two-body contact function g(rij) and its derivative:
7087 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7090 C where x=(rij-r0ij)/delta
7092 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7095 double precision rij,r0ij,eps0ij,fcont,fprimcont
7096 double precision x,x2,x4,delta
7100 if (x.lt.-1.0D0) then
7103 else if (x.le.1.0D0) then
7106 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7107 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7114 c------------------------------------------------------------------------------
7115 subroutine splinthet(theti,delta,ss,ssder)
7116 implicit real*8 (a-h,o-z)
7117 include 'DIMENSIONS'
7118 include 'COMMON.VAR'
7119 include 'COMMON.GEO'
7122 if (theti.gt.pipol) then
7123 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7125 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7130 c------------------------------------------------------------------------------
7131 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7133 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7134 double precision ksi,ksi2,ksi3,a1,a2,a3
7135 a1=fprim0*delta/(f1-f0)
7141 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7142 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7145 c------------------------------------------------------------------------------
7146 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7148 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7149 double precision ksi,ksi2,ksi3,a1,a2,a3
7154 a2=3*(f1x-f0x)-2*fprim0x*delta
7155 a3=fprim0x*delta-2*(f1x-f0x)
7156 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7159 C-----------------------------------------------------------------------------
7161 C-----------------------------------------------------------------------------
7162 subroutine etor(etors)
7163 implicit real*8 (a-h,o-z)
7164 include 'DIMENSIONS'
7165 include 'COMMON.VAR'
7166 include 'COMMON.GEO'
7167 include 'COMMON.LOCAL'
7168 include 'COMMON.TORSION'
7169 include 'COMMON.INTERACT'
7170 include 'COMMON.DERIV'
7171 include 'COMMON.CHAIN'
7172 include 'COMMON.NAMES'
7173 include 'COMMON.IOUNITS'
7174 include 'COMMON.FFIELD'
7175 include 'COMMON.TORCNSTR'
7176 include 'COMMON.CONTROL'
7178 C Set lprn=.true. for debugging
7182 do i=iphi_start,iphi_end
7184 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7185 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7186 itori=itortyp(itype(i-2))
7187 itori1=itortyp(itype(i-1))
7190 C Proline-Proline pair is a special case...
7191 if (itori.eq.3 .and. itori1.eq.3) then
7192 if (phii.gt.-dwapi3) then
7194 fac=1.0D0/(1.0D0-cosphi)
7195 etorsi=v1(1,3,3)*fac
7196 etorsi=etorsi+etorsi
7197 etors=etors+etorsi-v1(1,3,3)
7198 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7199 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7202 v1ij=v1(j+1,itori,itori1)
7203 v2ij=v2(j+1,itori,itori1)
7206 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7207 if (energy_dec) etors_ii=etors_ii+
7208 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7209 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7213 v1ij=v1(j,itori,itori1)
7214 v2ij=v2(j,itori,itori1)
7217 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7218 if (energy_dec) etors_ii=etors_ii+
7219 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7220 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7223 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7226 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7227 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7228 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7229 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7230 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7234 c------------------------------------------------------------------------------
7235 subroutine etor_d(etors_d)
7239 c----------------------------------------------------------------------------
7240 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7241 subroutine e_modeller(ehomology_constr)
7242 ehomology_constr=0.0d0
7243 write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7246 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7248 c------------------------------------------------------------------------------
7249 subroutine etor_d(etors_d)
7253 c----------------------------------------------------------------------------
7255 subroutine etor(etors)
7256 implicit real*8 (a-h,o-z)
7257 include 'DIMENSIONS'
7258 include 'COMMON.VAR'
7259 include 'COMMON.GEO'
7260 include 'COMMON.LOCAL'
7261 include 'COMMON.TORSION'
7262 include 'COMMON.INTERACT'
7263 include 'COMMON.DERIV'
7264 include 'COMMON.CHAIN'
7265 include 'COMMON.NAMES'
7266 include 'COMMON.IOUNITS'
7267 include 'COMMON.FFIELD'
7268 include 'COMMON.TORCNSTR'
7269 include 'COMMON.CONTROL'
7271 C Set lprn=.true. for debugging
7275 do i=iphi_start,iphi_end
7276 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7277 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7278 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7279 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7280 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7281 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7282 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7283 C For introducing the NH3+ and COO- group please check the etor_d for reference
7286 if (iabs(itype(i)).eq.20) then
7291 itori=itortyp(itype(i-2))
7292 itori1=itortyp(itype(i-1))
7295 C Regular cosine and sine terms
7296 do j=1,nterm(itori,itori1,iblock)
7297 v1ij=v1(j,itori,itori1,iblock)
7298 v2ij=v2(j,itori,itori1,iblock)
7301 etors=etors+v1ij*cosphi+v2ij*sinphi
7302 if (energy_dec) etors_ii=etors_ii+
7303 & v1ij*cosphi+v2ij*sinphi
7304 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7308 C E = SUM ----------------------------------- - v1
7309 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7311 cosphi=dcos(0.5d0*phii)
7312 sinphi=dsin(0.5d0*phii)
7313 do j=1,nlor(itori,itori1,iblock)
7314 vl1ij=vlor1(j,itori,itori1)
7315 vl2ij=vlor2(j,itori,itori1)
7316 vl3ij=vlor3(j,itori,itori1)
7317 pom=vl2ij*cosphi+vl3ij*sinphi
7318 pom1=1.0d0/(pom*pom+1.0d0)
7319 etors=etors+vl1ij*pom1
7320 if (energy_dec) etors_ii=etors_ii+
7323 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7325 C Subtract the constant term
7326 etors=etors-v0(itori,itori1,iblock)
7327 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7328 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7330 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7331 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7332 & (v1(j,itori,itori1,iblock),j=1,6),
7333 & (v2(j,itori,itori1,iblock),j=1,6)
7334 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7335 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7339 c----------------------------------------------------------------------------
7340 subroutine etor_d(etors_d)
7341 C 6/23/01 Compute double torsional energy
7342 implicit real*8 (a-h,o-z)
7343 include 'DIMENSIONS'
7344 include 'COMMON.VAR'
7345 include 'COMMON.GEO'
7346 include 'COMMON.LOCAL'
7347 include 'COMMON.TORSION'
7348 include 'COMMON.INTERACT'
7349 include 'COMMON.DERIV'
7350 include 'COMMON.CHAIN'
7351 include 'COMMON.NAMES'
7352 include 'COMMON.IOUNITS'
7353 include 'COMMON.FFIELD'
7354 include 'COMMON.TORCNSTR'
7356 C Set lprn=.true. for debugging
7360 c write(iout,*) "a tu??"
7361 do i=iphid_start,iphid_end
7362 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7363 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7364 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7365 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7366 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7367 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7368 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7369 & (itype(i+1).eq.ntyp1)) cycle
7370 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7371 itori=itortyp(itype(i-2))
7372 itori1=itortyp(itype(i-1))
7373 itori2=itortyp(itype(i))
7379 if (iabs(itype(i+1)).eq.20) iblock=2
7380 C Iblock=2 Proline type
7381 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7382 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7383 C if (itype(i+1).eq.ntyp1) iblock=3
7384 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7385 C IS or IS NOT need for this
7386 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7387 C is (itype(i-3).eq.ntyp1) ntblock=2
7388 C ntblock is N-terminal blocking group
7390 C Regular cosine and sine terms
7391 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7392 C Example of changes for NH3+ blocking group
7393 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7394 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7395 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7396 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7397 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7398 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7399 cosphi1=dcos(j*phii)
7400 sinphi1=dsin(j*phii)
7401 cosphi2=dcos(j*phii1)
7402 sinphi2=dsin(j*phii1)
7403 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7404 & v2cij*cosphi2+v2sij*sinphi2
7405 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7406 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7408 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7410 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7411 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7412 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7413 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7414 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7415 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7416 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7417 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7418 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7419 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7420 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7421 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7422 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7423 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7426 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7427 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7432 C----------------------------------------------------------------------------------
7433 C The rigorous attempt to derive energy function
7434 subroutine etor_kcc(etors)
7435 implicit real*8 (a-h,o-z)
7436 include 'DIMENSIONS'
7437 include 'COMMON.VAR'
7438 include 'COMMON.GEO'
7439 include 'COMMON.LOCAL'
7440 include 'COMMON.TORSION'
7441 include 'COMMON.INTERACT'
7442 include 'COMMON.DERIV'
7443 include 'COMMON.CHAIN'
7444 include 'COMMON.NAMES'
7445 include 'COMMON.IOUNITS'
7446 include 'COMMON.FFIELD'
7447 include 'COMMON.TORCNSTR'
7448 include 'COMMON.CONTROL'
7449 double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7451 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7452 C Set lprn=.true. for debugging
7455 C print *,"wchodze kcc"
7456 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7458 do i=iphi_start,iphi_end
7459 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7460 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7461 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7462 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7463 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7464 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7465 itori=itortyp(itype(i-2))
7466 itori1=itortyp(itype(i-1))
7471 C to avoid multiple devision by 2
7472 c theti22=0.5d0*theta(i)
7473 C theta 12 is the theta_1 /2
7474 C theta 22 is theta_2 /2
7475 c theti12=0.5d0*theta(i-1)
7476 C and appropriate sinus function
7477 sinthet1=dsin(theta(i-1))
7478 sinthet2=dsin(theta(i))
7479 costhet1=dcos(theta(i-1))
7480 costhet2=dcos(theta(i))
7481 C to speed up lets store its mutliplication
7482 sint1t2=sinthet2*sinthet1
7484 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7485 C +d_n*sin(n*gamma)) *
7486 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7487 C we have two sum 1) Non-Chebyshev which is with n and gamma
7488 nval=nterm_kcc_Tb(itori,itori1)
7494 c1(j)=c1(j-1)*costhet1
7495 c2(j)=c2(j-1)*costhet2
7498 do j=1,nterm_kcc(itori,itori1)
7502 sint1t2n=sint1t2n*sint1t2
7508 sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7509 gradvalct1=gradvalct1+
7510 & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7511 gradvalct2=gradvalct2+
7512 & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7515 gradvalct1=-gradvalct1*sinthet1
7516 gradvalct2=-gradvalct2*sinthet2
7522 sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7523 gradvalst1=gradvalst1+
7524 & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7525 gradvalst2=gradvalst2+
7526 & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7529 gradvalst1=-gradvalst1*sinthet1
7530 gradvalst2=-gradvalst2*sinthet2
7531 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7532 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7533 C glocig is the gradient local i site in gamma
7534 glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7535 C now gradient over theta_1
7536 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7537 & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7538 glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7539 & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7542 C derivative over gamma
7543 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7544 C derivative over theta1
7545 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7546 C now derivative over theta2
7547 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7549 write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7550 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7551 write (iout,*) "c1",(c1(k),k=0,nval),
7552 & " c2",(c2(k),k=0,nval)
7557 c---------------------------------------------------------------------------------------------
7558 subroutine etor_constr(edihcnstr)
7559 implicit real*8 (a-h,o-z)
7560 include 'DIMENSIONS'
7561 include 'COMMON.VAR'
7562 include 'COMMON.GEO'
7563 include 'COMMON.LOCAL'
7564 include 'COMMON.TORSION'
7565 include 'COMMON.INTERACT'
7566 include 'COMMON.DERIV'
7567 include 'COMMON.CHAIN'
7568 include 'COMMON.NAMES'
7569 include 'COMMON.IOUNITS'
7570 include 'COMMON.FFIELD'
7571 include 'COMMON.TORCNSTR'
7572 include 'COMMON.BOUNDS'
7573 include 'COMMON.CONTROL'
7574 ! 6/20/98 - dihedral angle constraints
7576 c do i=1,ndih_constr
7577 if (raw_psipred) then
7578 do i=idihconstr_start,idihconstr_end
7579 itori=idih_constr(i)
7581 gaudih_i=vpsipred(1,i)
7585 cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7586 dexpcos_i=dexp(-cos_i*cos_i)
7587 gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7588 gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7589 & *cos_i*dexpcos_i/s**2
7591 edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7592 gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7594 & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7595 & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7596 & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7597 & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7598 & -wdihc*dlog(gaudih_i)
7602 do i=idihconstr_start,idihconstr_end
7603 itori=idih_constr(i)
7605 difi=pinorm(phii-phi0(i))
7606 if (difi.gt.drange(i)) then
7608 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7609 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7610 else if (difi.lt.-drange(i)) then
7612 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7613 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7623 c----------------------------------------------------------------------------
7624 c MODELLER restraint function
7625 subroutine e_modeller(ehomology_constr)
7627 include 'DIMENSIONS'
7629 double precision ehomology_constr
7630 integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7631 integer katy, odleglosci, test7
7632 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7634 real*8 distance(max_template),distancek(max_template),
7635 & min_odl,godl(max_template),dih_diff(max_template)
7638 c FP - 30/10/2014 Temporary specifications for homology restraints
7640 double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7642 double precision, dimension (maxres) :: guscdiff,usc_diff
7643 double precision, dimension (max_template) ::
7644 & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7646 double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7647 & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7648 & betai,sum_sgodl,dij
7649 double precision dist,pinorm
7651 include 'COMMON.SBRIDGE'
7652 include 'COMMON.CHAIN'
7653 include 'COMMON.GEO'
7654 include 'COMMON.DERIV'
7655 include 'COMMON.LOCAL'
7656 include 'COMMON.INTERACT'
7657 include 'COMMON.VAR'
7658 include 'COMMON.IOUNITS'
7659 c include 'COMMON.MD'
7660 include 'COMMON.CONTROL'
7661 include 'COMMON.HOMOLOGY'
7662 include 'COMMON.QRESTR'
7664 c From subroutine Econstr_back
7666 include 'COMMON.NAMES'
7667 include 'COMMON.TIME1'
7672 distancek(i)=9999999.9
7678 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7680 C AL 5/2/14 - Introduce list of restraints
7681 c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7683 write(iout,*) "------- dist restrs start -------"
7685 do ii = link_start_homo,link_end_homo
7689 c write (iout,*) "dij(",i,j,") =",dij
7691 do k=1,constr_homology
7692 c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7693 if(.not.l_homo(k,ii)) then
7697 distance(k)=odl(k,ii)-dij
7698 c write (iout,*) "distance(",k,") =",distance(k)
7700 c For Gaussian-type Urestr
7702 distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7703 c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7704 c write (iout,*) "distancek(",k,") =",distancek(k)
7705 c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7707 c For Lorentzian-type Urestr
7709 if (waga_dist.lt.0.0d0) then
7710 sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7711 distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7712 & (distance(k)**2+sigma_odlir(k,ii)**2))
7716 c min_odl=minval(distancek)
7720 do kk=1,constr_homology
7721 if(l_homo(kk,ii)) then
7722 min_odl=distancek(kk)
7726 do kk=1,constr_homology
7727 if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7728 & min_odl=distancek(kk)
7732 c write (iout,* )"min_odl",min_odl
7734 write (iout,*) "ij dij",i,j,dij
7735 write (iout,*) "distance",(distance(k),k=1,constr_homology)
7736 write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7737 write (iout,* )"min_odl",min_odl
7742 if (waga_dist.ge.0.0d0) then
7748 do k=1,constr_homology
7749 c Nie wiem po co to liczycie jeszcze raz!
7750 c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7751 c & (2*(sigma_odl(i,j,k))**2))
7752 if(.not.l_homo(k,ii)) cycle
7753 if (waga_dist.ge.0.0d0) then
7755 c For Gaussian-type Urestr
7757 godl(k)=dexp(-distancek(k)+min_odl)
7758 odleg2=odleg2+godl(k)
7760 c For Lorentzian-type Urestr
7763 odleg2=odleg2+distancek(k)
7766 ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7767 ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7768 ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7769 ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7772 c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7773 c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7775 write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7776 write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7778 if (waga_dist.ge.0.0d0) then
7780 c For Gaussian-type Urestr
7782 odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7784 c For Lorentzian-type Urestr
7787 odleg=odleg+odleg2/constr_homology
7790 c write (iout,*) "odleg",odleg ! sum of -ln-s
7793 c For Gaussian-type Urestr
7795 if (waga_dist.ge.0.0d0) sum_godl=odleg2
7797 do k=1,constr_homology
7798 c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7799 c & *waga_dist)+min_odl
7800 c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7802 if(.not.l_homo(k,ii)) cycle
7803 if (waga_dist.ge.0.0d0) then
7804 c For Gaussian-type Urestr
7806 sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7808 c For Lorentzian-type Urestr
7811 sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7812 & sigma_odlir(k,ii)**2)**2)
7814 sum_sgodl=sum_sgodl+sgodl
7816 c sgodl2=sgodl2+sgodl
7817 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7818 c write(iout,*) "constr_homology=",constr_homology
7819 c write(iout,*) i, j, k, "TEST K"
7821 if (waga_dist.ge.0.0d0) then
7823 c For Gaussian-type Urestr
7825 grad_odl3=waga_homology(iset)*waga_dist
7826 & *sum_sgodl/(sum_godl*dij)
7828 c For Lorentzian-type Urestr
7831 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7832 c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7833 grad_odl3=-waga_homology(iset)*waga_dist*
7834 & sum_sgodl/(constr_homology*dij)
7837 c grad_odl3=sum_sgodl/(sum_godl*dij)
7840 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7841 c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7842 c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7844 ccc write(iout,*) godl, sgodl, grad_odl3
7846 c grad_odl=grad_odl+grad_odl3
7849 ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7850 ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7851 ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7852 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
7853 ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7854 ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7855 ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7856 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
7857 c if (i.eq.25.and.j.eq.27) then
7858 c write(iout,*) "jik",jik,"i",i,"j",j
7859 c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7860 c write(iout,*) "grad_odl3",grad_odl3
7861 c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7862 c write(iout,*) "ggodl",ggodl
7863 c write(iout,*) "ghpbc(",jik,i,")",
7864 c & ghpbc(jik,i),"ghpbc(",jik,j,")",
7868 ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7869 ccc & dLOG(odleg2),"-odleg=", -odleg
7871 enddo ! ii-loop for dist
7873 write(iout,*) "------- dist restrs end -------"
7874 c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7875 c & waga_d.eq.1.0d0) call sum_gradient
7877 c Pseudo-energy and gradient from dihedral-angle restraints from
7878 c homology templates
7879 c write (iout,*) "End of distance loop"
7882 c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7884 write(iout,*) "------- dih restrs start -------"
7885 do i=idihconstr_start_homo,idihconstr_end_homo
7886 write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7889 do i=idihconstr_start_homo,idihconstr_end_homo
7891 c betai=beta(i,i+1,i+2,i+3)
7893 c write (iout,*) "betai =",betai
7894 do k=1,constr_homology
7895 dih_diff(k)=pinorm(dih(k,i)-betai)
7896 cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7897 cd & ,sigma_dih(k,i)
7898 c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7899 c & -(6.28318-dih_diff(i,k))
7900 c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7901 c & 6.28318+dih_diff(i,k)
7903 kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7905 kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7907 c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7910 c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7913 c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7914 c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7916 write (iout,*) "i",i," betai",betai," kat2",kat2
7917 write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7919 if (kat2.le.1.0d-14) cycle
7920 kat=kat-dLOG(kat2/constr_homology)
7921 c write (iout,*) "kat",kat ! sum of -ln-s
7923 ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7924 ccc & dLOG(kat2), "-kat=", -kat
7926 c ----------------------------------------------------------------------
7928 c ----------------------------------------------------------------------
7932 do k=1,constr_homology
7934 sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
7936 sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd
7938 c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7939 sum_sgdih=sum_sgdih+sgdih
7941 c grad_dih3=sum_sgdih/sum_gdih
7942 grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7944 c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7945 ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7946 ccc & gloc(nphi+i-3,icg)
7947 gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7949 c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7951 ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7952 ccc & gloc(nphi+i-3,icg)
7954 enddo ! i-loop for dih
7956 write(iout,*) "------- dih restrs end -------"
7959 c Pseudo-energy and gradient for theta angle restraints from
7960 c homology templates
7961 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7965 c For constr_homology reference structures (FP)
7967 c Uconst_back_tot=0.0d0
7970 c Econstr_back legacy
7972 c do i=ithet_start,ithet_end
7975 c do i=loc_start,loc_end
7978 duscdiffx(j,i)=0.0d0
7983 c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7984 c write (iout,*) "waga_theta",waga_theta
7985 if (waga_theta.gt.0.0d0) then
7987 write (iout,*) "usampl",usampl
7988 write(iout,*) "------- theta restrs start -------"
7989 c do i=ithet_start,ithet_end
7990 c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7993 c write (iout,*) "maxres",maxres,"nres",nres
7995 do i=ithet_start,ithet_end
7998 c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8000 c Deviation of theta angles wrt constr_homology ref structures
8002 utheta_i=0.0d0 ! argument of Gaussian for single k
8003 gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8004 c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8005 c over residues in a fragment
8006 c write (iout,*) "theta(",i,")=",theta(i)
8007 do k=1,constr_homology
8009 c dtheta_i=theta(j)-thetaref(j,iref)
8010 c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8011 theta_diff(k)=thetatpl(k,i)-theta(i)
8012 cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8013 cd & ,sigma_theta(k,i)
8016 utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8017 c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8018 gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8019 gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk)
8020 c Gradient for single Gaussian restraint in subr Econstr_back
8021 c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8024 c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8025 c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8028 c Gradient for multiple Gaussian restraint
8029 sum_gtheta=gutheta_i
8031 do k=1,constr_homology
8032 c New generalized expr for multiple Gaussian from Econstr_back
8033 sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8035 c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8036 sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8038 c Final value of gradient using same var as in Econstr_back
8039 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8040 & +sum_sgtheta/sum_gtheta*waga_theta
8041 & *waga_homology(iset)
8042 c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8043 c & *waga_homology(iset)
8044 c dutheta(i)=sum_sgtheta/sum_gtheta
8046 c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8047 Eval=Eval-dLOG(gutheta_i/constr_homology)
8048 c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8049 c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8050 c Uconst_back=Uconst_back+utheta(i)
8051 enddo ! (i-loop for theta)
8053 write(iout,*) "------- theta restrs end -------"
8057 c Deviation of local SC geometry
8059 c Separation of two i-loops (instructed by AL - 11/3/2014)
8061 c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8062 c write (iout,*) "waga_d",waga_d
8065 write(iout,*) "------- SC restrs start -------"
8066 write (iout,*) "Initial duscdiff,duscdiffx"
8067 do i=loc_start,loc_end
8068 write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8069 & (duscdiffx(jik,i),jik=1,3)
8072 do i=loc_start,loc_end
8073 usc_diff_i=0.0d0 ! argument of Gaussian for single k
8074 guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8075 c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8076 c write(iout,*) "xxtab, yytab, zztab"
8077 c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8078 do k=1,constr_homology
8080 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8081 c Original sign inverted for calc of gradients (s. Econstr_back)
8082 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8083 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8084 c write(iout,*) "dxx, dyy, dzz"
8085 cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8087 usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
8088 c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8089 c uscdiffk(k)=usc_diff(i)
8090 guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8091 c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8092 c & " guscdiff2",guscdiff2(k)
8093 guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk)
8094 c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8095 c & xxref(j),yyref(j),zzref(j)
8100 c Generalized expression for multiple Gaussian acc to that for a single
8101 c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8103 c Original implementation
8104 c sum_guscdiff=guscdiff(i)
8106 c sum_sguscdiff=0.0d0
8107 c do k=1,constr_homology
8108 c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8109 c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8110 c sum_sguscdiff=sum_sguscdiff+sguscdiff
8113 c Implementation of new expressions for gradient (Jan. 2015)
8115 c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8116 do k=1,constr_homology
8118 c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8119 c before. Now the drivatives should be correct
8121 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8122 c Original sign inverted for calc of gradients (s. Econstr_back)
8123 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8124 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8126 c New implementation
8128 sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8129 & sigma_d(k,i) ! for the grad wrt r'
8130 c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8133 c New implementation
8134 sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8136 duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8137 & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8138 & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8139 duscdiff(jik,i)=duscdiff(jik,i)+
8140 & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8141 & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8142 duscdiffx(jik,i)=duscdiffx(jik,i)+
8143 & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8144 & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8147 write(iout,*) "jik",jik,"i",i
8148 write(iout,*) "dxx, dyy, dzz"
8149 write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8150 write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8151 c write(iout,*) "sum_sguscdiff",sum_sguscdiff
8152 cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8153 c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8154 c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8155 c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8156 c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8157 c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8158 c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8159 c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8160 c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8161 c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8162 c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8163 c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8169 c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
8170 c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8172 c write (iout,*) i," uscdiff",uscdiff(i)
8174 c Put together deviations from local geometry
8176 c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8177 c & wfrag_back(3,i,iset)*uscdiff(i)
8178 Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8179 c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8180 c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8181 c Uconst_back=Uconst_back+usc_diff(i)
8183 c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8185 c New implment: multiplied by sum_sguscdiff
8188 enddo ! (i-loop for dscdiff)
8193 write(iout,*) "------- SC restrs end -------"
8194 write (iout,*) "------ After SC loop in e_modeller ------"
8195 do i=loc_start,loc_end
8196 write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8197 write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8199 if (waga_theta.eq.1.0d0) then
8200 write (iout,*) "in e_modeller after SC restr end: dutheta"
8201 do i=ithet_start,ithet_end
8202 write (iout,*) i,dutheta(i)
8205 if (waga_d.eq.1.0d0) then
8206 write (iout,*) "e_modeller after SC loop: duscdiff/x"
8208 write (iout,*) i,(duscdiff(j,i),j=1,3)
8209 write (iout,*) i,(duscdiffx(j,i),j=1,3)
8214 c Total energy from homology restraints
8216 write (iout,*) "odleg",odleg," kat",kat
8219 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8221 c ehomology_constr=odleg+kat
8223 c For Lorentzian-type Urestr
8226 if (waga_dist.ge.0.0d0) then
8228 c For Gaussian-type Urestr
8230 ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8231 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8232 c write (iout,*) "ehomology_constr=",ehomology_constr
8235 c For Lorentzian-type Urestr
8237 ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8238 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8239 c write (iout,*) "ehomology_constr=",ehomology_constr
8242 write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8243 & "Eval",waga_theta,eval,
8244 & "Erot",waga_d,Erot
8245 write (iout,*) "ehomology_constr",ehomology_constr
8251 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8252 747 format(a12,i4,i4,i4,f8.3,f8.3)
8253 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8254 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8255 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8256 & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8258 c----------------------------------------------------------------------------
8259 C The rigorous attempt to derive energy function
8260 subroutine ebend_kcc(etheta)
8262 implicit real*8 (a-h,o-z)
8263 include 'DIMENSIONS'
8264 include 'COMMON.VAR'
8265 include 'COMMON.GEO'
8266 include 'COMMON.LOCAL'
8267 include 'COMMON.TORSION'
8268 include 'COMMON.INTERACT'
8269 include 'COMMON.DERIV'
8270 include 'COMMON.CHAIN'
8271 include 'COMMON.NAMES'
8272 include 'COMMON.IOUNITS'
8273 include 'COMMON.FFIELD'
8274 include 'COMMON.TORCNSTR'
8275 include 'COMMON.CONTROL'
8277 double precision thybt1(maxang_kcc)
8278 C Set lprn=.true. for debugging
8281 C print *,"wchodze kcc"
8282 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8284 do i=ithet_start,ithet_end
8285 c print *,i,itype(i-1),itype(i),itype(i-2)
8286 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8287 & .or.itype(i).eq.ntyp1) cycle
8288 iti=iabs(itortyp(itype(i-1)))
8289 sinthet=dsin(theta(i))
8290 costhet=dcos(theta(i))
8291 do j=1,nbend_kcc_Tb(iti)
8292 thybt1(j)=v1bend_chyb(j,iti)
8294 sumth1thyb=v1bend_chyb(0,iti)+
8295 & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8296 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8298 ihelp=nbend_kcc_Tb(iti)-1
8299 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8300 etheta=etheta+sumth1thyb
8301 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8302 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8306 c-------------------------------------------------------------------------------------
8307 subroutine etheta_constr(ethetacnstr)
8309 implicit real*8 (a-h,o-z)
8310 include 'DIMENSIONS'
8311 include 'COMMON.VAR'
8312 include 'COMMON.GEO'
8313 include 'COMMON.LOCAL'
8314 include 'COMMON.TORSION'
8315 include 'COMMON.INTERACT'
8316 include 'COMMON.DERIV'
8317 include 'COMMON.CHAIN'
8318 include 'COMMON.NAMES'
8319 include 'COMMON.IOUNITS'
8320 include 'COMMON.FFIELD'
8321 include 'COMMON.TORCNSTR'
8322 include 'COMMON.CONTROL'
8324 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8325 do i=ithetaconstr_start,ithetaconstr_end
8326 itheta=itheta_constr(i)
8327 thetiii=theta(itheta)
8328 difi=pinorm(thetiii-theta_constr0(i))
8329 if (difi.gt.theta_drange(i)) then
8330 difi=difi-theta_drange(i)
8331 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8332 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8333 & +for_thet_constr(i)*difi**3
8334 else if (difi.lt.-drange(i)) then
8336 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8337 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8338 & +for_thet_constr(i)*difi**3
8342 if (energy_dec) then
8343 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8344 & i,itheta,rad2deg*thetiii,
8345 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8346 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8347 & gloc(itheta+nphi-2,icg)
8352 c------------------------------------------------------------------------------
8353 subroutine eback_sc_corr(esccor)
8354 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8355 c conformational states; temporarily implemented as differences
8356 c between UNRES torsional potentials (dependent on three types of
8357 c residues) and the torsional potentials dependent on all 20 types
8358 c of residues computed from AM1 energy surfaces of terminally-blocked
8359 c amino-acid residues.
8360 implicit real*8 (a-h,o-z)
8361 include 'DIMENSIONS'
8362 include 'COMMON.VAR'
8363 include 'COMMON.GEO'
8364 include 'COMMON.LOCAL'
8365 include 'COMMON.TORSION'
8366 include 'COMMON.SCCOR'
8367 include 'COMMON.INTERACT'
8368 include 'COMMON.DERIV'
8369 include 'COMMON.CHAIN'
8370 include 'COMMON.NAMES'
8371 include 'COMMON.IOUNITS'
8372 include 'COMMON.FFIELD'
8373 include 'COMMON.CONTROL'
8375 C Set lprn=.true. for debugging
8378 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8380 do i=itau_start,itau_end
8381 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8383 isccori=isccortyp(itype(i-2))
8384 isccori1=isccortyp(itype(i-1))
8385 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8387 do intertyp=1,3 !intertyp
8388 cc Added 09 May 2012 (Adasko)
8389 cc Intertyp means interaction type of backbone mainchain correlation:
8390 c 1 = SC...Ca...Ca...Ca
8391 c 2 = Ca...Ca...Ca...SC
8392 c 3 = SC...Ca...Ca...SCi
8394 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8395 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8396 & (itype(i-1).eq.ntyp1)))
8397 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8398 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8399 & .or.(itype(i).eq.ntyp1)))
8400 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8401 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8402 & (itype(i-3).eq.ntyp1)))) cycle
8403 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8404 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8406 do j=1,nterm_sccor(isccori,isccori1)
8407 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8408 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8409 cosphi=dcos(j*tauangle(intertyp,i))
8410 sinphi=dsin(j*tauangle(intertyp,i))
8411 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8412 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8414 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8415 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8417 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8418 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8419 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8420 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8421 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8428 c----------------------------------------------------------------------------
8429 subroutine multibody(ecorr)
8430 C This subroutine calculates multi-body contributions to energy following
8431 C the idea of Skolnick et al. If side chains I and J make a contact and
8432 C at the same time side chains I+1 and J+1 make a contact, an extra
8433 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8434 implicit real*8 (a-h,o-z)
8435 include 'DIMENSIONS'
8436 include 'COMMON.IOUNITS'
8437 include 'COMMON.DERIV'
8438 include 'COMMON.INTERACT'
8439 include 'COMMON.CONTACTS'
8440 include 'COMMON.CONTMAT'
8441 include 'COMMON.CORRMAT'
8442 double precision gx(3),gx1(3)
8445 C Set lprn=.true. for debugging
8449 write (iout,'(a)') 'Contact function values:'
8451 write (iout,'(i2,20(1x,i2,f10.5))')
8452 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8467 num_conti=num_cont(i)
8468 num_conti1=num_cont(i1)
8473 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8474 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8475 cd & ' ishift=',ishift
8476 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8477 C The system gains extra energy.
8478 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8479 endif ! j1==j+-ishift
8488 c------------------------------------------------------------------------------
8489 double precision function esccorr(i,j,k,l,jj,kk)
8490 implicit real*8 (a-h,o-z)
8491 include 'DIMENSIONS'
8492 include 'COMMON.IOUNITS'
8493 include 'COMMON.DERIV'
8494 include 'COMMON.INTERACT'
8495 include 'COMMON.CONTACTS'
8496 include 'COMMON.CONTMAT'
8497 include 'COMMON.CORRMAT'
8498 include 'COMMON.SHIELD'
8499 double precision gx(3),gx1(3)
8504 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8505 C Calculate the multi-body contribution to energy.
8506 C Calculate multi-body contributions to the gradient.
8507 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8508 cd & k,l,(gacont(m,kk,k),m=1,3)
8510 gx(m) =ekl*gacont(m,jj,i)
8511 gx1(m)=eij*gacont(m,kk,k)
8512 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8513 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8514 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8515 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8519 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8524 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8530 c------------------------------------------------------------------------------
8531 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8532 C This subroutine calculates multi-body contributions to hydrogen-bonding
8533 implicit real*8 (a-h,o-z)
8534 include 'DIMENSIONS'
8535 include 'COMMON.IOUNITS'
8538 parameter (max_cont=maxconts)
8539 parameter (max_dim=26)
8540 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8541 double precision zapas(max_dim,maxconts,max_fg_procs),
8542 & zapas_recv(max_dim,maxconts,max_fg_procs)
8543 common /przechowalnia/ zapas
8544 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8545 & status_array(MPI_STATUS_SIZE,maxconts*2)
8547 include 'COMMON.SETUP'
8548 include 'COMMON.FFIELD'
8549 include 'COMMON.DERIV'
8550 include 'COMMON.INTERACT'
8551 include 'COMMON.CONTACTS'
8552 include 'COMMON.CONTMAT'
8553 include 'COMMON.CORRMAT'
8554 include 'COMMON.CONTROL'
8555 include 'COMMON.LOCAL'
8556 double precision gx(3),gx1(3),time00
8559 C Set lprn=.true. for debugging
8564 if (nfgtasks.le.1) goto 30
8566 write (iout,'(a)') 'Contact function values before RECEIVE:'
8568 write (iout,'(2i3,50(1x,i2,f5.2))')
8569 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8570 & j=1,num_cont_hb(i))
8574 do i=1,ntask_cont_from
8577 do i=1,ntask_cont_to
8580 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8582 C Make the list of contacts to send to send to other procesors
8583 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8585 do i=iturn3_start,iturn3_end
8586 c write (iout,*) "make contact list turn3",i," num_cont",
8588 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8590 do i=iturn4_start,iturn4_end
8591 c write (iout,*) "make contact list turn4",i," num_cont",
8593 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8597 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8599 do j=1,num_cont_hb(i)
8602 iproc=iint_sent_local(k,jjc,ii)
8603 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8604 if (iproc.gt.0) then
8605 ncont_sent(iproc)=ncont_sent(iproc)+1
8606 nn=ncont_sent(iproc)
8608 zapas(2,nn,iproc)=jjc
8609 zapas(3,nn,iproc)=facont_hb(j,i)
8610 zapas(4,nn,iproc)=ees0p(j,i)
8611 zapas(5,nn,iproc)=ees0m(j,i)
8612 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8613 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8614 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8615 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8616 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8617 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8618 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8619 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8620 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8621 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8622 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8623 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8624 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8625 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8626 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8627 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8628 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8629 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8630 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8631 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8632 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8639 & "Numbers of contacts to be sent to other processors",
8640 & (ncont_sent(i),i=1,ntask_cont_to)
8641 write (iout,*) "Contacts sent"
8642 do ii=1,ntask_cont_to
8644 iproc=itask_cont_to(ii)
8645 write (iout,*) nn," contacts to processor",iproc,
8646 & " of CONT_TO_COMM group"
8648 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8656 CorrelID1=nfgtasks+fg_rank+1
8658 C Receive the numbers of needed contacts from other processors
8659 do ii=1,ntask_cont_from
8660 iproc=itask_cont_from(ii)
8662 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8663 & FG_COMM,req(ireq),IERR)
8665 c write (iout,*) "IRECV ended"
8667 C Send the number of contacts needed by other processors
8668 do ii=1,ntask_cont_to
8669 iproc=itask_cont_to(ii)
8671 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8672 & FG_COMM,req(ireq),IERR)
8674 c write (iout,*) "ISEND ended"
8675 c write (iout,*) "number of requests (nn)",ireq
8678 & call MPI_Waitall(ireq,req,status_array,ierr)
8680 c & "Numbers of contacts to be received from other processors",
8681 c & (ncont_recv(i),i=1,ntask_cont_from)
8685 do ii=1,ntask_cont_from
8686 iproc=itask_cont_from(ii)
8688 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8689 c & " of CONT_TO_COMM group"
8693 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8694 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8695 c write (iout,*) "ireq,req",ireq,req(ireq)
8698 C Send the contacts to processors that need them
8699 do ii=1,ntask_cont_to
8700 iproc=itask_cont_to(ii)
8702 c write (iout,*) nn," contacts to processor",iproc,
8703 c & " of CONT_TO_COMM group"
8706 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8707 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8708 c write (iout,*) "ireq,req",ireq,req(ireq)
8710 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8714 c write (iout,*) "number of requests (contacts)",ireq
8715 c write (iout,*) "req",(req(i),i=1,4)
8718 & call MPI_Waitall(ireq,req,status_array,ierr)
8719 do iii=1,ntask_cont_from
8720 iproc=itask_cont_from(iii)
8723 write (iout,*) "Received",nn," contacts from processor",iproc,
8724 & " of CONT_FROM_COMM group"
8727 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8732 ii=zapas_recv(1,i,iii)
8733 c Flag the received contacts to prevent double-counting
8734 jj=-zapas_recv(2,i,iii)
8735 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8737 nnn=num_cont_hb(ii)+1
8740 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8741 ees0p(nnn,ii)=zapas_recv(4,i,iii)
8742 ees0m(nnn,ii)=zapas_recv(5,i,iii)
8743 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8744 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8745 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8746 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8747 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8748 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8749 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8750 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8751 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8752 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8753 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8754 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8755 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8756 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8757 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8758 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8759 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8760 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8761 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8762 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8763 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8767 write (iout,'(a)') 'Contact function values after receive:'
8769 write (iout,'(2i3,50(1x,i3,f5.2))')
8770 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8771 & j=1,num_cont_hb(i))
8778 write (iout,'(a)') 'Contact function values:'
8780 write (iout,'(2i3,50(1x,i3,f5.2))')
8781 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8782 & j=1,num_cont_hb(i))
8787 C Remove the loop below after debugging !!!
8794 C Calculate the local-electrostatic correlation terms
8795 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8797 num_conti=num_cont_hb(i)
8798 num_conti1=num_cont_hb(i+1)
8805 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8806 c & ' jj=',jj,' kk=',kk
8808 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8809 & .or. j.lt.0 .and. j1.gt.0) .and.
8810 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8811 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8812 C The system gains extra energy.
8813 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8814 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8815 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8817 else if (j1.eq.j) then
8818 C Contacts I-J and I-(J+1) occur simultaneously.
8819 C The system loses extra energy.
8820 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8825 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8826 c & ' jj=',jj,' kk=',kk
8828 C Contacts I-J and (I+1)-J occur simultaneously.
8829 C The system loses extra energy.
8830 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8837 c------------------------------------------------------------------------------
8838 subroutine add_hb_contact(ii,jj,itask)
8839 implicit real*8 (a-h,o-z)
8840 include "DIMENSIONS"
8841 include "COMMON.IOUNITS"
8844 parameter (max_cont=maxconts)
8845 parameter (max_dim=26)
8846 include "COMMON.CONTACTS"
8847 include 'COMMON.CONTMAT'
8848 include 'COMMON.CORRMAT'
8849 double precision zapas(max_dim,maxconts,max_fg_procs),
8850 & zapas_recv(max_dim,maxconts,max_fg_procs)
8851 common /przechowalnia/ zapas
8852 integer i,j,ii,jj,iproc,itask(4),nn
8853 c write (iout,*) "itask",itask
8856 if (iproc.gt.0) then
8857 do j=1,num_cont_hb(ii)
8859 c write (iout,*) "i",ii," j",jj," jjc",jjc
8861 ncont_sent(iproc)=ncont_sent(iproc)+1
8862 nn=ncont_sent(iproc)
8863 zapas(1,nn,iproc)=ii
8864 zapas(2,nn,iproc)=jjc
8865 zapas(3,nn,iproc)=facont_hb(j,ii)
8866 zapas(4,nn,iproc)=ees0p(j,ii)
8867 zapas(5,nn,iproc)=ees0m(j,ii)
8868 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8869 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8870 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8871 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8872 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8873 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8874 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8875 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8876 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8877 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8878 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8879 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8880 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8881 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8882 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8883 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8884 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8885 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8886 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8887 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8888 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8896 c------------------------------------------------------------------------------
8897 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8899 C This subroutine calculates multi-body contributions to hydrogen-bonding
8900 implicit real*8 (a-h,o-z)
8901 include 'DIMENSIONS'
8902 include 'COMMON.IOUNITS'
8905 parameter (max_cont=maxconts)
8906 parameter (max_dim=70)
8907 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8908 double precision zapas(max_dim,maxconts,max_fg_procs),
8909 & zapas_recv(max_dim,maxconts,max_fg_procs)
8910 common /przechowalnia/ zapas
8911 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8912 & status_array(MPI_STATUS_SIZE,maxconts*2)
8914 include 'COMMON.SETUP'
8915 include 'COMMON.FFIELD'
8916 include 'COMMON.DERIV'
8917 include 'COMMON.LOCAL'
8918 include 'COMMON.INTERACT'
8919 include 'COMMON.CONTACTS'
8920 include 'COMMON.CONTMAT'
8921 include 'COMMON.CORRMAT'
8922 include 'COMMON.CHAIN'
8923 include 'COMMON.CONTROL'
8924 include 'COMMON.SHIELD'
8925 double precision gx(3),gx1(3)
8926 integer num_cont_hb_old(maxres)
8928 double precision eello4,eello5,eelo6,eello_turn6
8929 external eello4,eello5,eello6,eello_turn6
8930 C Set lprn=.true. for debugging
8935 num_cont_hb_old(i)=num_cont_hb(i)
8939 if (nfgtasks.le.1) goto 30
8941 write (iout,'(a)') 'Contact function values before RECEIVE:'
8943 write (iout,'(2i3,50(1x,i2,f5.2))')
8944 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8945 & j=1,num_cont_hb(i))
8948 do i=1,ntask_cont_from
8951 do i=1,ntask_cont_to
8954 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8956 C Make the list of contacts to send to send to other procesors
8957 do i=iturn3_start,iturn3_end
8958 c write (iout,*) "make contact list turn3",i," num_cont",
8960 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8962 do i=iturn4_start,iturn4_end
8963 c write (iout,*) "make contact list turn4",i," num_cont",
8965 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8969 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8971 do j=1,num_cont_hb(i)
8974 iproc=iint_sent_local(k,jjc,ii)
8975 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8976 if (iproc.ne.0) then
8977 ncont_sent(iproc)=ncont_sent(iproc)+1
8978 nn=ncont_sent(iproc)
8980 zapas(2,nn,iproc)=jjc
8981 zapas(3,nn,iproc)=d_cont(j,i)
8985 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8990 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8998 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9009 & "Numbers of contacts to be sent to other processors",
9010 & (ncont_sent(i),i=1,ntask_cont_to)
9011 write (iout,*) "Contacts sent"
9012 do ii=1,ntask_cont_to
9014 iproc=itask_cont_to(ii)
9015 write (iout,*) nn," contacts to processor",iproc,
9016 & " of CONT_TO_COMM group"
9018 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9026 CorrelID1=nfgtasks+fg_rank+1
9028 C Receive the numbers of needed contacts from other processors
9029 do ii=1,ntask_cont_from
9030 iproc=itask_cont_from(ii)
9032 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9033 & FG_COMM,req(ireq),IERR)
9035 c write (iout,*) "IRECV ended"
9037 C Send the number of contacts needed by other processors
9038 do ii=1,ntask_cont_to
9039 iproc=itask_cont_to(ii)
9041 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9042 & FG_COMM,req(ireq),IERR)
9044 c write (iout,*) "ISEND ended"
9045 c write (iout,*) "number of requests (nn)",ireq
9048 & call MPI_Waitall(ireq,req,status_array,ierr)
9050 c & "Numbers of contacts to be received from other processors",
9051 c & (ncont_recv(i),i=1,ntask_cont_from)
9055 do ii=1,ntask_cont_from
9056 iproc=itask_cont_from(ii)
9058 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9059 c & " of CONT_TO_COMM group"
9063 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9064 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9065 c write (iout,*) "ireq,req",ireq,req(ireq)
9068 C Send the contacts to processors that need them
9069 do ii=1,ntask_cont_to
9070 iproc=itask_cont_to(ii)
9072 c write (iout,*) nn," contacts to processor",iproc,
9073 c & " of CONT_TO_COMM group"
9076 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9077 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9078 c write (iout,*) "ireq,req",ireq,req(ireq)
9080 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9084 c write (iout,*) "number of requests (contacts)",ireq
9085 c write (iout,*) "req",(req(i),i=1,4)
9088 & call MPI_Waitall(ireq,req,status_array,ierr)
9089 do iii=1,ntask_cont_from
9090 iproc=itask_cont_from(iii)
9093 write (iout,*) "Received",nn," contacts from processor",iproc,
9094 & " of CONT_FROM_COMM group"
9097 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9102 ii=zapas_recv(1,i,iii)
9103 c Flag the received contacts to prevent double-counting
9104 jj=-zapas_recv(2,i,iii)
9105 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9107 nnn=num_cont_hb(ii)+1
9110 d_cont(nnn,ii)=zapas_recv(3,i,iii)
9114 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9119 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9127 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9135 write (iout,'(a)') 'Contact function values after receive:'
9137 write (iout,'(2i3,50(1x,i3,5f6.3))')
9138 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9139 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9146 write (iout,'(a)') 'Contact function values:'
9148 write (iout,'(2i3,50(1x,i2,5f6.3))')
9149 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9150 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9156 C Remove the loop below after debugging !!!
9163 C Calculate the dipole-dipole interaction energies
9164 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9165 do i=iatel_s,iatel_e+1
9166 num_conti=num_cont_hb(i)
9175 C Calculate the local-electrostatic correlation terms
9176 c write (iout,*) "gradcorr5 in eello5 before loop"
9178 c write (iout,'(i5,3f10.5)')
9179 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9181 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9182 c write (iout,*) "corr loop i",i
9184 num_conti=num_cont_hb(i)
9185 num_conti1=num_cont_hb(i+1)
9192 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9193 c & ' jj=',jj,' kk=',kk
9194 c if (j1.eq.j+1 .or. j1.eq.j-1) then
9195 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9196 & .or. j.lt.0 .and. j1.gt.0) .and.
9197 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9198 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9199 C The system gains extra energy.
9201 sqd1=dsqrt(d_cont(jj,i))
9202 sqd2=dsqrt(d_cont(kk,i1))
9203 sred_geom = sqd1*sqd2
9204 IF (sred_geom.lt.cutoff_corr) THEN
9205 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9207 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9208 cd & ' jj=',jj,' kk=',kk
9209 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9210 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9212 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9213 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9216 cd write (iout,*) 'sred_geom=',sred_geom,
9217 cd & ' ekont=',ekont,' fprim=',fprimcont,
9218 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9219 cd write (iout,*) "g_contij",g_contij
9220 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9221 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9222 call calc_eello(i,jp,i+1,jp1,jj,kk)
9223 if (wcorr4.gt.0.0d0)
9224 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9225 CC & *fac_shield(i)**2*fac_shield(j)**2
9226 if (energy_dec.and.wcorr4.gt.0.0d0)
9227 1 write (iout,'(a6,4i5,0pf7.3)')
9228 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9229 c write (iout,*) "gradcorr5 before eello5"
9231 c write (iout,'(i5,3f10.5)')
9232 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9234 if (wcorr5.gt.0.0d0)
9235 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9236 c write (iout,*) "gradcorr5 after eello5"
9238 c write (iout,'(i5,3f10.5)')
9239 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9241 if (energy_dec.and.wcorr5.gt.0.0d0)
9242 1 write (iout,'(a6,4i5,0pf7.3)')
9243 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9244 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9245 cd write(2,*)'ijkl',i,jp,i+1,jp1
9246 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9247 & .or. wturn6.eq.0.0d0))then
9248 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9249 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9250 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9251 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9252 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9253 cd & 'ecorr6=',ecorr6
9254 cd write (iout,'(4e15.5)') sred_geom,
9255 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9256 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9257 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9258 else if (wturn6.gt.0.0d0
9259 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9260 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9261 eturn6=eturn6+eello_turn6(i,jj,kk)
9262 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9263 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9264 cd write (2,*) 'multibody_eello:eturn6',eturn6
9273 num_cont_hb(i)=num_cont_hb_old(i)
9275 c write (iout,*) "gradcorr5 in eello5"
9277 c write (iout,'(i5,3f10.5)')
9278 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9282 c------------------------------------------------------------------------------
9283 subroutine add_hb_contact_eello(ii,jj,itask)
9284 implicit real*8 (a-h,o-z)
9285 include "DIMENSIONS"
9286 include "COMMON.IOUNITS"
9289 parameter (max_cont=maxconts)
9290 parameter (max_dim=70)
9291 include "COMMON.CONTACTS"
9292 include 'COMMON.CONTMAT'
9293 include 'COMMON.CORRMAT'
9294 double precision zapas(max_dim,maxconts,max_fg_procs),
9295 & zapas_recv(max_dim,maxconts,max_fg_procs)
9296 common /przechowalnia/ zapas
9297 integer i,j,ii,jj,iproc,itask(4),nn
9298 c write (iout,*) "itask",itask
9301 if (iproc.gt.0) then
9302 do j=1,num_cont_hb(ii)
9304 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9306 ncont_sent(iproc)=ncont_sent(iproc)+1
9307 nn=ncont_sent(iproc)
9308 zapas(1,nn,iproc)=ii
9309 zapas(2,nn,iproc)=jjc
9310 zapas(3,nn,iproc)=d_cont(j,ii)
9314 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9319 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9327 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9339 c------------------------------------------------------------------------------
9340 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9341 implicit real*8 (a-h,o-z)
9342 include 'DIMENSIONS'
9343 include 'COMMON.IOUNITS'
9344 include 'COMMON.DERIV'
9345 include 'COMMON.INTERACT'
9346 include 'COMMON.CONTACTS'
9347 include 'COMMON.CONTMAT'
9348 include 'COMMON.CORRMAT'
9349 include 'COMMON.SHIELD'
9350 include 'COMMON.CONTROL'
9351 double precision gx(3),gx1(3)
9354 C print *,"wchodze",fac_shield(i),shield_mode
9362 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9364 C & fac_shield(i)**2*fac_shield(j)**2
9365 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9366 C Following 4 lines for diagnostics.
9371 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9372 c & 'Contacts ',i,j,
9373 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9374 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9376 C Calculate the multi-body contribution to energy.
9377 C ecorr=ecorr+ekont*ees
9378 C Calculate multi-body contributions to the gradient.
9379 coeffpees0pij=coeffp*ees0pij
9380 coeffmees0mij=coeffm*ees0mij
9381 coeffpees0pkl=coeffp*ees0pkl
9382 coeffmees0mkl=coeffm*ees0mkl
9384 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9385 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9386 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9387 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9388 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9389 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9390 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9391 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9392 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9393 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9394 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9395 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9396 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9397 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9398 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9399 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9400 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9401 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9402 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9403 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9404 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9405 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9406 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9407 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9408 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9413 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9414 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9415 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9416 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9421 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9422 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9423 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9424 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9427 c write (iout,*) "ehbcorr",ekont*ees
9428 C print *,ekont,ees,i,k
9430 C now gradient over shielding
9432 if (shield_mode.gt.0) then
9435 C print *,i,j,fac_shield(i),fac_shield(j),
9436 C &fac_shield(k),fac_shield(l)
9437 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9438 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9439 do ilist=1,ishield_list(i)
9440 iresshield=shield_list(ilist,i)
9442 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9444 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9446 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9447 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9451 do ilist=1,ishield_list(j)
9452 iresshield=shield_list(ilist,j)
9454 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9456 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9458 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9459 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9464 do ilist=1,ishield_list(k)
9465 iresshield=shield_list(ilist,k)
9467 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9469 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9471 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9472 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9476 do ilist=1,ishield_list(l)
9477 iresshield=shield_list(ilist,l)
9479 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9481 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9483 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9484 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9488 C print *,gshieldx(m,iresshield)
9490 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9491 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9492 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9493 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9494 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9495 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9496 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9497 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9499 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9500 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9501 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9502 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9503 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9504 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9505 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9506 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9514 C---------------------------------------------------------------------------
9515 subroutine dipole(i,j,jj)
9516 implicit real*8 (a-h,o-z)
9517 include 'DIMENSIONS'
9518 include 'COMMON.IOUNITS'
9519 include 'COMMON.CHAIN'
9520 include 'COMMON.FFIELD'
9521 include 'COMMON.DERIV'
9522 include 'COMMON.INTERACT'
9523 include 'COMMON.CONTACTS'
9524 include 'COMMON.CONTMAT'
9525 include 'COMMON.CORRMAT'
9526 include 'COMMON.TORSION'
9527 include 'COMMON.VAR'
9528 include 'COMMON.GEO'
9529 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9531 iti1 = itortyp(itype(i+1))
9532 if (j.lt.nres-1) then
9533 itj1 = itype2loc(itype(j+1))
9538 dipi(iii,1)=Ub2(iii,i)
9539 dipderi(iii)=Ub2der(iii,i)
9540 dipi(iii,2)=b1(iii,i+1)
9541 dipj(iii,1)=Ub2(iii,j)
9542 dipderj(iii)=Ub2der(iii,j)
9543 dipj(iii,2)=b1(iii,j+1)
9547 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9550 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9557 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9561 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9566 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9567 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9569 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9571 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9573 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9578 C---------------------------------------------------------------------------
9579 subroutine calc_eello(i,j,k,l,jj,kk)
9581 C This subroutine computes matrices and vectors needed to calculate
9582 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9584 implicit real*8 (a-h,o-z)
9585 include 'DIMENSIONS'
9586 include 'COMMON.IOUNITS'
9587 include 'COMMON.CHAIN'
9588 include 'COMMON.DERIV'
9589 include 'COMMON.INTERACT'
9590 include 'COMMON.CONTACTS'
9591 include 'COMMON.CONTMAT'
9592 include 'COMMON.CORRMAT'
9593 include 'COMMON.TORSION'
9594 include 'COMMON.VAR'
9595 include 'COMMON.GEO'
9596 include 'COMMON.FFIELD'
9597 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9598 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9601 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9602 cd & ' jj=',jj,' kk=',kk
9603 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9604 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9605 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9608 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9609 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9612 call transpose2(aa1(1,1),aa1t(1,1))
9613 call transpose2(aa2(1,1),aa2t(1,1))
9616 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9617 & aa1tder(1,1,lll,kkk))
9618 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9619 & aa2tder(1,1,lll,kkk))
9623 C parallel orientation of the two CA-CA-CA frames.
9625 iti=itype2loc(itype(i))
9629 itk1=itype2loc(itype(k+1))
9630 itj=itype2loc(itype(j))
9631 if (l.lt.nres-1) then
9632 itl1=itype2loc(itype(l+1))
9636 C A1 kernel(j+1) A2T
9638 cd write (iout,'(3f10.5,5x,3f10.5)')
9639 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9641 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9642 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9643 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9644 C Following matrices are needed only for 6-th order cumulants
9645 IF (wcorr6.gt.0.0d0) THEN
9646 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9647 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9648 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9649 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9650 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9651 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9652 & ADtEAderx(1,1,1,1,1,1))
9654 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9655 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9656 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9657 & ADtEA1derx(1,1,1,1,1,1))
9659 C End 6-th order cumulants
9662 cd write (2,*) 'In calc_eello6'
9664 cd write (2,*) 'iii=',iii
9666 cd write (2,*) 'kkk=',kkk
9668 cd write (2,'(3(2f10.5),5x)')
9669 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9674 call transpose2(EUgder(1,1,k),auxmat(1,1))
9675 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9676 call transpose2(EUg(1,1,k),auxmat(1,1))
9677 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9678 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9679 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9680 c in theta; to be sriten later.
9682 c call transpose2(gtEE(1,1,k),auxmat(1,1))
9683 c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9684 c call transpose2(EUg(1,1,k),auxmat(1,1))
9685 c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9690 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9691 & EAEAderx(1,1,lll,kkk,iii,1))
9695 C A1T kernel(i+1) A2
9696 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9697 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9698 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9699 C Following matrices are needed only for 6-th order cumulants
9700 IF (wcorr6.gt.0.0d0) THEN
9701 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9702 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9703 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9704 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9705 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9706 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9707 & ADtEAderx(1,1,1,1,1,2))
9708 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9709 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9710 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9711 & ADtEA1derx(1,1,1,1,1,2))
9713 C End 6-th order cumulants
9714 call transpose2(EUgder(1,1,l),auxmat(1,1))
9715 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9716 call transpose2(EUg(1,1,l),auxmat(1,1))
9717 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9718 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9722 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9723 & EAEAderx(1,1,lll,kkk,iii,2))
9728 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9729 C They are needed only when the fifth- or the sixth-order cumulants are
9731 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9732 call transpose2(AEA(1,1,1),auxmat(1,1))
9733 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9734 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9735 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9736 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9737 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9738 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9739 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9740 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9741 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9742 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9743 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9744 call transpose2(AEA(1,1,2),auxmat(1,1))
9745 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9746 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9747 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9748 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9749 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9750 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9751 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9752 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9753 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9754 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9755 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9756 C Calculate the Cartesian derivatives of the vectors.
9760 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9761 call matvec2(auxmat(1,1),b1(1,i),
9762 & AEAb1derx(1,lll,kkk,iii,1,1))
9763 call matvec2(auxmat(1,1),Ub2(1,i),
9764 & AEAb2derx(1,lll,kkk,iii,1,1))
9765 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9766 & AEAb1derx(1,lll,kkk,iii,2,1))
9767 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9768 & AEAb2derx(1,lll,kkk,iii,2,1))
9769 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9770 call matvec2(auxmat(1,1),b1(1,j),
9771 & AEAb1derx(1,lll,kkk,iii,1,2))
9772 call matvec2(auxmat(1,1),Ub2(1,j),
9773 & AEAb2derx(1,lll,kkk,iii,1,2))
9774 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9775 & AEAb1derx(1,lll,kkk,iii,2,2))
9776 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9777 & AEAb2derx(1,lll,kkk,iii,2,2))
9784 C Antiparallel orientation of the two CA-CA-CA frames.
9786 iti=itype2loc(itype(i))
9790 itk1=itype2loc(itype(k+1))
9791 itl=itype2loc(itype(l))
9792 itj=itype2loc(itype(j))
9793 if (j.lt.nres-1) then
9794 itj1=itype2loc(itype(j+1))
9798 C A2 kernel(j-1)T A1T
9799 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9800 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9801 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9802 C Following matrices are needed only for 6-th order cumulants
9803 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9804 & j.eq.i+4 .and. l.eq.i+3)) THEN
9805 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9806 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9807 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9808 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9809 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9810 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9811 & ADtEAderx(1,1,1,1,1,1))
9812 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9813 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9814 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9815 & ADtEA1derx(1,1,1,1,1,1))
9817 C End 6-th order cumulants
9818 call transpose2(EUgder(1,1,k),auxmat(1,1))
9819 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9820 call transpose2(EUg(1,1,k),auxmat(1,1))
9821 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9822 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9826 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9827 & EAEAderx(1,1,lll,kkk,iii,1))
9831 C A2T kernel(i+1)T A1
9832 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9833 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9834 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9835 C Following matrices are needed only for 6-th order cumulants
9836 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9837 & j.eq.i+4 .and. l.eq.i+3)) THEN
9838 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9839 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9840 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9841 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9842 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9843 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9844 & ADtEAderx(1,1,1,1,1,2))
9845 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9846 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9847 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9848 & ADtEA1derx(1,1,1,1,1,2))
9850 C End 6-th order cumulants
9851 call transpose2(EUgder(1,1,j),auxmat(1,1))
9852 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9853 call transpose2(EUg(1,1,j),auxmat(1,1))
9854 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9855 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9859 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9860 & EAEAderx(1,1,lll,kkk,iii,2))
9865 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9866 C They are needed only when the fifth- or the sixth-order cumulants are
9868 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9869 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9870 call transpose2(AEA(1,1,1),auxmat(1,1))
9871 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9872 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9873 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9874 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9875 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9876 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9877 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9878 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9879 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9880 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9881 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9882 call transpose2(AEA(1,1,2),auxmat(1,1))
9883 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9884 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9885 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9886 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9887 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9888 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9889 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9890 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9891 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9892 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9893 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9894 C Calculate the Cartesian derivatives of the vectors.
9898 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9899 call matvec2(auxmat(1,1),b1(1,i),
9900 & AEAb1derx(1,lll,kkk,iii,1,1))
9901 call matvec2(auxmat(1,1),Ub2(1,i),
9902 & AEAb2derx(1,lll,kkk,iii,1,1))
9903 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9904 & AEAb1derx(1,lll,kkk,iii,2,1))
9905 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9906 & AEAb2derx(1,lll,kkk,iii,2,1))
9907 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9908 call matvec2(auxmat(1,1),b1(1,l),
9909 & AEAb1derx(1,lll,kkk,iii,1,2))
9910 call matvec2(auxmat(1,1),Ub2(1,l),
9911 & AEAb2derx(1,lll,kkk,iii,1,2))
9912 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9913 & AEAb1derx(1,lll,kkk,iii,2,2))
9914 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9915 & AEAb2derx(1,lll,kkk,iii,2,2))
9924 C---------------------------------------------------------------------------
9925 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9926 & KK,KKderg,AKA,AKAderg,AKAderx)
9930 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9931 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9932 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9937 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9939 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9942 cd if (lprn) write (2,*) 'In kernel'
9944 cd if (lprn) write (2,*) 'kkk=',kkk
9946 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9947 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9949 cd write (2,*) 'lll=',lll
9950 cd write (2,*) 'iii=1'
9952 cd write (2,'(3(2f10.5),5x)')
9953 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9956 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9957 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9959 cd write (2,*) 'lll=',lll
9960 cd write (2,*) 'iii=2'
9962 cd write (2,'(3(2f10.5),5x)')
9963 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9970 C---------------------------------------------------------------------------
9971 double precision function eello4(i,j,k,l,jj,kk)
9972 implicit real*8 (a-h,o-z)
9973 include 'DIMENSIONS'
9974 include 'COMMON.IOUNITS'
9975 include 'COMMON.CHAIN'
9976 include 'COMMON.DERIV'
9977 include 'COMMON.INTERACT'
9978 include 'COMMON.CONTACTS'
9979 include 'COMMON.CONTMAT'
9980 include 'COMMON.CORRMAT'
9981 include 'COMMON.TORSION'
9982 include 'COMMON.VAR'
9983 include 'COMMON.GEO'
9984 double precision pizda(2,2),ggg1(3),ggg2(3)
9985 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9989 cd print *,'eello4:',i,j,k,l,jj,kk
9990 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
9991 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
9992 cold eij=facont_hb(jj,i)
9993 cold ekl=facont_hb(kk,k)
9995 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9996 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9997 gcorr_loc(k-1)=gcorr_loc(k-1)
9998 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10000 gcorr_loc(l-1)=gcorr_loc(l-1)
10001 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10002 C Al 4/16/16: Derivatives in theta, to be added later.
10004 c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10005 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10008 gcorr_loc(j-1)=gcorr_loc(j-1)
10009 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10011 c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10012 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10018 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10019 & -EAEAderx(2,2,lll,kkk,iii,1)
10020 cd derx(lll,kkk,iii)=0.0d0
10024 cd gcorr_loc(l-1)=0.0d0
10025 cd gcorr_loc(j-1)=0.0d0
10026 cd gcorr_loc(k-1)=0.0d0
10028 cd write (iout,*)'Contacts have occurred for peptide groups',
10029 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
10030 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10031 if (j.lt.nres-1) then
10038 if (l.lt.nres-1) then
10046 cgrad ggg1(ll)=eel4*g_contij(ll,1)
10047 cgrad ggg2(ll)=eel4*g_contij(ll,2)
10048 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10049 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10050 cgrad ghalf=0.5d0*ggg1(ll)
10051 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10052 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10053 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10054 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10055 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10056 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10057 cgrad ghalf=0.5d0*ggg2(ll)
10058 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10059 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10060 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10061 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10062 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10063 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10067 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10072 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10077 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10082 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10086 cd write (2,*) iii,gcorr_loc(iii)
10089 cd write (2,*) 'ekont',ekont
10090 cd write (iout,*) 'eello4',ekont*eel4
10093 C---------------------------------------------------------------------------
10094 double precision function eello5(i,j,k,l,jj,kk)
10095 implicit real*8 (a-h,o-z)
10096 include 'DIMENSIONS'
10097 include 'COMMON.IOUNITS'
10098 include 'COMMON.CHAIN'
10099 include 'COMMON.DERIV'
10100 include 'COMMON.INTERACT'
10101 include 'COMMON.CONTACTS'
10102 include 'COMMON.CONTMAT'
10103 include 'COMMON.CORRMAT'
10104 include 'COMMON.TORSION'
10105 include 'COMMON.VAR'
10106 include 'COMMON.GEO'
10107 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10108 double precision ggg1(3),ggg2(3)
10109 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10111 C Parallel chains C
10114 C /l\ / \ \ / \ / \ / C
10115 C / \ / \ \ / \ / \ / C
10116 C j| o |l1 | o | o| o | | o |o C
10117 C \ |/k\| |/ \| / |/ \| |/ \| C
10118 C \i/ \ / \ / / \ / \ C
10120 C (I) (II) (III) (IV) C
10122 C eello5_1 eello5_2 eello5_3 eello5_4 C
10124 C Antiparallel chains C
10127 C /j\ / \ \ / \ / \ / C
10128 C / \ / \ \ / \ / \ / C
10129 C j1| o |l | o | o| o | | o |o C
10130 C \ |/k\| |/ \| / |/ \| |/ \| C
10131 C \i/ \ / \ / / \ / \ C
10133 C (I) (II) (III) (IV) C
10135 C eello5_1 eello5_2 eello5_3 eello5_4 C
10137 C o denotes a local interaction, vertical lines an electrostatic interaction. C
10139 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10140 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10145 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
10147 itk=itype2loc(itype(k))
10148 itl=itype2loc(itype(l))
10149 itj=itype2loc(itype(j))
10154 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10155 cd & eel5_3_num,eel5_4_num)
10159 derx(lll,kkk,iii)=0.0d0
10163 cd eij=facont_hb(jj,i)
10164 cd ekl=facont_hb(kk,k)
10166 cd write (iout,*)'Contacts have occurred for peptide groups',
10167 cd & i,j,' fcont:',eij,' eij',' and ',k,l
10169 C Contribution from the graph I.
10170 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10171 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10172 call transpose2(EUg(1,1,k),auxmat(1,1))
10173 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10174 vv(1)=pizda(1,1)-pizda(2,2)
10175 vv(2)=pizda(1,2)+pizda(2,1)
10176 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10177 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10178 C Explicit gradient in virtual-dihedral angles.
10179 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10180 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10181 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10182 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10183 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10184 vv(1)=pizda(1,1)-pizda(2,2)
10185 vv(2)=pizda(1,2)+pizda(2,1)
10186 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10187 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10188 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10189 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10190 vv(1)=pizda(1,1)-pizda(2,2)
10191 vv(2)=pizda(1,2)+pizda(2,1)
10193 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10194 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10195 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10197 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10198 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10199 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10201 C Cartesian gradient
10205 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10207 vv(1)=pizda(1,1)-pizda(2,2)
10208 vv(2)=pizda(1,2)+pizda(2,1)
10209 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10210 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10211 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10217 C Contribution from graph II
10218 call transpose2(EE(1,1,k),auxmat(1,1))
10219 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10220 vv(1)=pizda(1,1)+pizda(2,2)
10221 vv(2)=pizda(2,1)-pizda(1,2)
10222 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10223 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10224 C Explicit gradient in virtual-dihedral angles.
10225 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10226 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10227 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10228 vv(1)=pizda(1,1)+pizda(2,2)
10229 vv(2)=pizda(2,1)-pizda(1,2)
10231 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10232 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10233 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10235 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10236 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10237 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10239 C Cartesian gradient
10243 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10245 vv(1)=pizda(1,1)+pizda(2,2)
10246 vv(2)=pizda(2,1)-pizda(1,2)
10247 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10248 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10249 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10257 C Parallel orientation
10258 C Contribution from graph III
10259 call transpose2(EUg(1,1,l),auxmat(1,1))
10260 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10261 vv(1)=pizda(1,1)-pizda(2,2)
10262 vv(2)=pizda(1,2)+pizda(2,1)
10263 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10264 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10265 C Explicit gradient in virtual-dihedral angles.
10266 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10267 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10268 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10269 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10270 vv(1)=pizda(1,1)-pizda(2,2)
10271 vv(2)=pizda(1,2)+pizda(2,1)
10272 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10273 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10274 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10275 call transpose2(EUgder(1,1,l),auxmat1(1,1))
10276 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10277 vv(1)=pizda(1,1)-pizda(2,2)
10278 vv(2)=pizda(1,2)+pizda(2,1)
10279 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10280 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10281 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10282 C Cartesian gradient
10286 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10288 vv(1)=pizda(1,1)-pizda(2,2)
10289 vv(2)=pizda(1,2)+pizda(2,1)
10290 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10291 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10292 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10297 C Contribution from graph IV
10299 call transpose2(EE(1,1,l),auxmat(1,1))
10300 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10301 vv(1)=pizda(1,1)+pizda(2,2)
10302 vv(2)=pizda(2,1)-pizda(1,2)
10303 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10304 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10305 C Explicit gradient in virtual-dihedral angles.
10306 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10307 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10308 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10309 vv(1)=pizda(1,1)+pizda(2,2)
10310 vv(2)=pizda(2,1)-pizda(1,2)
10311 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10312 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10313 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10314 C Cartesian gradient
10318 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10320 vv(1)=pizda(1,1)+pizda(2,2)
10321 vv(2)=pizda(2,1)-pizda(1,2)
10322 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10323 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10324 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10329 C Antiparallel orientation
10330 C Contribution from graph III
10332 call transpose2(EUg(1,1,j),auxmat(1,1))
10333 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10334 vv(1)=pizda(1,1)-pizda(2,2)
10335 vv(2)=pizda(1,2)+pizda(2,1)
10336 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10337 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10338 C Explicit gradient in virtual-dihedral angles.
10339 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10340 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10341 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10342 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10343 vv(1)=pizda(1,1)-pizda(2,2)
10344 vv(2)=pizda(1,2)+pizda(2,1)
10345 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10346 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10347 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10348 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10349 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10350 vv(1)=pizda(1,1)-pizda(2,2)
10351 vv(2)=pizda(1,2)+pizda(2,1)
10352 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10353 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10354 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10355 C Cartesian gradient
10359 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10361 vv(1)=pizda(1,1)-pizda(2,2)
10362 vv(2)=pizda(1,2)+pizda(2,1)
10363 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10364 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10365 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10370 C Contribution from graph IV
10372 call transpose2(EE(1,1,j),auxmat(1,1))
10373 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10374 vv(1)=pizda(1,1)+pizda(2,2)
10375 vv(2)=pizda(2,1)-pizda(1,2)
10376 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10377 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10378 C Explicit gradient in virtual-dihedral angles.
10379 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10380 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10381 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10382 vv(1)=pizda(1,1)+pizda(2,2)
10383 vv(2)=pizda(2,1)-pizda(1,2)
10384 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10385 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10386 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10387 C Cartesian gradient
10391 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10393 vv(1)=pizda(1,1)+pizda(2,2)
10394 vv(2)=pizda(2,1)-pizda(1,2)
10395 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10396 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10397 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10403 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10404 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10405 cd write (2,*) 'ijkl',i,j,k,l
10406 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10407 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10409 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10410 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10411 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10412 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10413 if (j.lt.nres-1) then
10420 if (l.lt.nres-1) then
10430 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10431 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10432 C summed up outside the subrouine as for the other subroutines
10433 C handling long-range interactions. The old code is commented out
10434 C with "cgrad" to keep track of changes.
10436 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10437 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10438 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10439 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10440 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10441 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10442 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10443 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10444 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10445 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10447 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10448 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10449 cgrad ghalf=0.5d0*ggg1(ll)
10451 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10452 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10453 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10454 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10455 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10456 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10457 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10458 cgrad ghalf=0.5d0*ggg2(ll)
10460 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10461 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10462 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10463 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10464 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10465 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10470 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10471 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10476 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10477 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10483 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10488 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10492 cd write (2,*) iii,g_corr5_loc(iii)
10495 cd write (2,*) 'ekont',ekont
10496 cd write (iout,*) 'eello5',ekont*eel5
10499 c--------------------------------------------------------------------------
10500 double precision function eello6(i,j,k,l,jj,kk)
10501 implicit real*8 (a-h,o-z)
10502 include 'DIMENSIONS'
10503 include 'COMMON.IOUNITS'
10504 include 'COMMON.CHAIN'
10505 include 'COMMON.DERIV'
10506 include 'COMMON.INTERACT'
10507 include 'COMMON.CONTACTS'
10508 include 'COMMON.CONTMAT'
10509 include 'COMMON.CORRMAT'
10510 include 'COMMON.TORSION'
10511 include 'COMMON.VAR'
10512 include 'COMMON.GEO'
10513 include 'COMMON.FFIELD'
10514 double precision ggg1(3),ggg2(3)
10515 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10520 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10528 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10529 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10533 derx(lll,kkk,iii)=0.0d0
10537 cd eij=facont_hb(jj,i)
10538 cd ekl=facont_hb(kk,k)
10544 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10545 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10546 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10547 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10548 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10549 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10551 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10552 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10553 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10554 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10555 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10556 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10560 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10562 C If turn contributions are considered, they will be handled separately.
10563 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10564 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10565 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10566 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10567 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10568 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10569 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10571 if (j.lt.nres-1) then
10578 if (l.lt.nres-1) then
10586 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10587 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10588 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10589 cgrad ghalf=0.5d0*ggg1(ll)
10591 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10592 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10593 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10594 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10595 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10596 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10597 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10598 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10599 cgrad ghalf=0.5d0*ggg2(ll)
10600 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10602 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10603 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10604 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10605 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10606 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10607 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10612 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10613 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10618 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10619 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10625 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10630 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10634 cd write (2,*) iii,g_corr6_loc(iii)
10637 cd write (2,*) 'ekont',ekont
10638 cd write (iout,*) 'eello6',ekont*eel6
10641 c--------------------------------------------------------------------------
10642 double precision function eello6_graph1(i,j,k,l,imat,swap)
10643 implicit real*8 (a-h,o-z)
10644 include 'DIMENSIONS'
10645 include 'COMMON.IOUNITS'
10646 include 'COMMON.CHAIN'
10647 include 'COMMON.DERIV'
10648 include 'COMMON.INTERACT'
10649 include 'COMMON.CONTACTS'
10650 include 'COMMON.CONTMAT'
10651 include 'COMMON.CORRMAT'
10652 include 'COMMON.TORSION'
10653 include 'COMMON.VAR'
10654 include 'COMMON.GEO'
10655 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10658 common /kutas/ lprn
10659 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10661 C Parallel Antiparallel C
10667 C \ j|/k\| / \ |/k\|l / C
10668 C \ / \ / \ / \ / C
10672 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10673 itk=itype2loc(itype(k))
10674 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10675 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10676 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10677 call transpose2(EUgC(1,1,k),auxmat(1,1))
10678 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10679 vv1(1)=pizda1(1,1)-pizda1(2,2)
10680 vv1(2)=pizda1(1,2)+pizda1(2,1)
10681 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10682 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10683 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10684 s5=scalar2(vv(1),Dtobr2(1,i))
10685 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10686 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10687 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10688 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10689 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10690 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10691 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10692 & +scalar2(vv(1),Dtobr2der(1,i)))
10693 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10694 vv1(1)=pizda1(1,1)-pizda1(2,2)
10695 vv1(2)=pizda1(1,2)+pizda1(2,1)
10696 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10697 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10699 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10700 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10701 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10702 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10703 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10705 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10706 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10707 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10708 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10709 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10711 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10712 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10713 vv1(1)=pizda1(1,1)-pizda1(2,2)
10714 vv1(2)=pizda1(1,2)+pizda1(2,1)
10715 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10716 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10717 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10718 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10727 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10728 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10729 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10730 call transpose2(EUgC(1,1,k),auxmat(1,1))
10731 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10733 vv1(1)=pizda1(1,1)-pizda1(2,2)
10734 vv1(2)=pizda1(1,2)+pizda1(2,1)
10735 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10736 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10737 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10738 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10739 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10740 s5=scalar2(vv(1),Dtobr2(1,i))
10741 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10747 c----------------------------------------------------------------------------
10748 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10749 implicit real*8 (a-h,o-z)
10750 include 'DIMENSIONS'
10751 include 'COMMON.IOUNITS'
10752 include 'COMMON.CHAIN'
10753 include 'COMMON.DERIV'
10754 include 'COMMON.INTERACT'
10755 include 'COMMON.CONTACTS'
10756 include 'COMMON.CONTMAT'
10757 include 'COMMON.CORRMAT'
10758 include 'COMMON.TORSION'
10759 include 'COMMON.VAR'
10760 include 'COMMON.GEO'
10762 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10763 & auxvec1(2),auxvec2(2),auxmat1(2,2)
10765 common /kutas/ lprn
10766 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10768 C Parallel Antiparallel C
10774 C \ j|/k\| \ |/k\|l C
10779 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10780 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10781 C AL 7/4/01 s1 would occur in the sixth-order moment,
10782 C but not in a cluster cumulant
10784 s1=dip(1,jj,i)*dip(1,kk,k)
10786 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10787 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10788 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10789 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10790 call transpose2(EUg(1,1,k),auxmat(1,1))
10791 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10792 vv(1)=pizda(1,1)-pizda(2,2)
10793 vv(2)=pizda(1,2)+pizda(2,1)
10794 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10795 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10797 eello6_graph2=-(s1+s2+s3+s4)
10799 eello6_graph2=-(s2+s3+s4)
10801 c eello6_graph2=-s3
10802 C Derivatives in gamma(i-1)
10805 s1=dipderg(1,jj,i)*dip(1,kk,k)
10807 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10808 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10809 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10810 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10812 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10814 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10816 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10818 C Derivatives in gamma(k-1)
10820 s1=dip(1,jj,i)*dipderg(1,kk,k)
10822 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10823 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10824 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10825 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10826 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10827 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10828 vv(1)=pizda(1,1)-pizda(2,2)
10829 vv(2)=pizda(1,2)+pizda(2,1)
10830 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10832 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10834 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10836 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10837 C Derivatives in gamma(j-1) or gamma(l-1)
10840 s1=dipderg(3,jj,i)*dip(1,kk,k)
10842 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10843 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10844 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10845 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10846 vv(1)=pizda(1,1)-pizda(2,2)
10847 vv(2)=pizda(1,2)+pizda(2,1)
10848 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10851 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10853 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10856 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10857 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10859 C Derivatives in gamma(l-1) or gamma(j-1)
10862 s1=dip(1,jj,i)*dipderg(3,kk,k)
10864 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10865 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10866 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10867 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10868 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10869 vv(1)=pizda(1,1)-pizda(2,2)
10870 vv(2)=pizda(1,2)+pizda(2,1)
10871 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10874 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10876 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10879 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10880 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10882 C Cartesian derivatives.
10884 write (2,*) 'In eello6_graph2'
10886 write (2,*) 'iii=',iii
10888 write (2,*) 'kkk=',kkk
10890 write (2,'(3(2f10.5),5x)')
10891 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10901 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10903 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10906 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10908 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10909 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10911 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10912 call transpose2(EUg(1,1,k),auxmat(1,1))
10913 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10915 vv(1)=pizda(1,1)-pizda(2,2)
10916 vv(2)=pizda(1,2)+pizda(2,1)
10917 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10918 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10920 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10922 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10925 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10927 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10934 c----------------------------------------------------------------------------
10935 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10936 implicit real*8 (a-h,o-z)
10937 include 'DIMENSIONS'
10938 include 'COMMON.IOUNITS'
10939 include 'COMMON.CHAIN'
10940 include 'COMMON.DERIV'
10941 include 'COMMON.INTERACT'
10942 include 'COMMON.CONTACTS'
10943 include 'COMMON.CONTMAT'
10944 include 'COMMON.CORRMAT'
10945 include 'COMMON.TORSION'
10946 include 'COMMON.VAR'
10947 include 'COMMON.GEO'
10948 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10950 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10952 C Parallel Antiparallel C
10957 C /| o |o o| o |\ C
10958 C j|/k\| / |/k\|l / C
10963 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10965 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10966 C energy moment and not to the cluster cumulant.
10967 iti=itortyp(itype(i))
10968 if (j.lt.nres-1) then
10969 itj1=itype2loc(itype(j+1))
10973 itk=itype2loc(itype(k))
10974 itk1=itype2loc(itype(k+1))
10975 if (l.lt.nres-1) then
10976 itl1=itype2loc(itype(l+1))
10981 s1=dip(4,jj,i)*dip(4,kk,k)
10983 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10984 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10985 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10986 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10987 call transpose2(EE(1,1,k),auxmat(1,1))
10988 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10989 vv(1)=pizda(1,1)+pizda(2,2)
10990 vv(2)=pizda(2,1)-pizda(1,2)
10991 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10992 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10993 cd & "sum",-(s2+s3+s4)
10995 eello6_graph3=-(s1+s2+s3+s4)
10997 eello6_graph3=-(s2+s3+s4)
10999 c eello6_graph3=-s4
11000 C Derivatives in gamma(k-1)
11001 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11002 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11003 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11004 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11005 C Derivatives in gamma(l-1)
11006 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11007 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11008 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11009 vv(1)=pizda(1,1)+pizda(2,2)
11010 vv(2)=pizda(2,1)-pizda(1,2)
11011 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11012 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11013 C Cartesian derivatives.
11019 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11021 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11024 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11026 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11027 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11029 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11030 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11032 vv(1)=pizda(1,1)+pizda(2,2)
11033 vv(2)=pizda(2,1)-pizda(1,2)
11034 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11036 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11038 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11041 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11043 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11045 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11051 c----------------------------------------------------------------------------
11052 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11053 implicit real*8 (a-h,o-z)
11054 include 'DIMENSIONS'
11055 include 'COMMON.IOUNITS'
11056 include 'COMMON.CHAIN'
11057 include 'COMMON.DERIV'
11058 include 'COMMON.INTERACT'
11059 include 'COMMON.CONTACTS'
11060 include 'COMMON.CONTMAT'
11061 include 'COMMON.CORRMAT'
11062 include 'COMMON.TORSION'
11063 include 'COMMON.VAR'
11064 include 'COMMON.GEO'
11065 include 'COMMON.FFIELD'
11066 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11067 & auxvec1(2),auxmat1(2,2)
11069 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11071 C Parallel Antiparallel C
11076 C /| o |o o| o |\ C
11077 C \ j|/k\| \ |/k\|l C
11082 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11084 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11085 C energy moment and not to the cluster cumulant.
11086 cd write (2,*) 'eello_graph4: wturn6',wturn6
11087 iti=itype2loc(itype(i))
11088 itj=itype2loc(itype(j))
11089 if (j.lt.nres-1) then
11090 itj1=itype2loc(itype(j+1))
11094 itk=itype2loc(itype(k))
11095 if (k.lt.nres-1) then
11096 itk1=itype2loc(itype(k+1))
11100 itl=itype2loc(itype(l))
11101 if (l.lt.nres-1) then
11102 itl1=itype2loc(itype(l+1))
11106 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11107 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11108 cd & ' itl',itl,' itl1',itl1
11110 if (imat.eq.1) then
11111 s1=dip(3,jj,i)*dip(3,kk,k)
11113 s1=dip(2,jj,j)*dip(2,kk,l)
11116 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11117 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11119 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11120 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11122 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11123 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11125 call transpose2(EUg(1,1,k),auxmat(1,1))
11126 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11127 vv(1)=pizda(1,1)-pizda(2,2)
11128 vv(2)=pizda(2,1)+pizda(1,2)
11129 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11130 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11132 eello6_graph4=-(s1+s2+s3+s4)
11134 eello6_graph4=-(s2+s3+s4)
11136 C Derivatives in gamma(i-1)
11139 if (imat.eq.1) then
11140 s1=dipderg(2,jj,i)*dip(3,kk,k)
11142 s1=dipderg(4,jj,j)*dip(2,kk,l)
11145 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11147 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11148 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11150 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11151 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11153 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11154 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11155 cd write (2,*) 'turn6 derivatives'
11157 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11159 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11163 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11165 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11169 C Derivatives in gamma(k-1)
11171 if (imat.eq.1) then
11172 s1=dip(3,jj,i)*dipderg(2,kk,k)
11174 s1=dip(2,jj,j)*dipderg(4,kk,l)
11177 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11178 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11180 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11181 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11183 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11184 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11186 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11187 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11188 vv(1)=pizda(1,1)-pizda(2,2)
11189 vv(2)=pizda(2,1)+pizda(1,2)
11190 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11191 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11193 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11195 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11199 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11201 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11204 C Derivatives in gamma(j-1) or gamma(l-1)
11205 if (l.eq.j+1 .and. l.gt.1) then
11206 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11207 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11208 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11209 vv(1)=pizda(1,1)-pizda(2,2)
11210 vv(2)=pizda(2,1)+pizda(1,2)
11211 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11212 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11213 else if (j.gt.1) then
11214 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11215 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11216 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11217 vv(1)=pizda(1,1)-pizda(2,2)
11218 vv(2)=pizda(2,1)+pizda(1,2)
11219 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11220 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11221 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11223 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11226 C Cartesian derivatives.
11232 if (imat.eq.1) then
11233 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11235 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11238 if (imat.eq.1) then
11239 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11241 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11245 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11247 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11249 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11250 & b1(1,j+1),auxvec(1))
11251 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11253 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11254 & b1(1,l+1),auxvec(1))
11255 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11257 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11259 vv(1)=pizda(1,1)-pizda(2,2)
11260 vv(2)=pizda(2,1)+pizda(1,2)
11261 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11263 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11265 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11268 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11271 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11274 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11276 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11278 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11282 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11284 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11287 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11289 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11297 c----------------------------------------------------------------------------
11298 double precision function eello_turn6(i,jj,kk)
11299 implicit real*8 (a-h,o-z)
11300 include 'DIMENSIONS'
11301 include 'COMMON.IOUNITS'
11302 include 'COMMON.CHAIN'
11303 include 'COMMON.DERIV'
11304 include 'COMMON.INTERACT'
11305 include 'COMMON.CONTACTS'
11306 include 'COMMON.CONTMAT'
11307 include 'COMMON.CORRMAT'
11308 include 'COMMON.TORSION'
11309 include 'COMMON.VAR'
11310 include 'COMMON.GEO'
11311 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11312 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11314 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11315 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11316 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11317 C the respective energy moment and not to the cluster cumulant.
11326 iti=itype2loc(itype(i))
11327 itk=itype2loc(itype(k))
11328 itk1=itype2loc(itype(k+1))
11329 itl=itype2loc(itype(l))
11330 itj=itype2loc(itype(j))
11331 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11332 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11333 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11338 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11340 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11344 derx_turn(lll,kkk,iii)=0.0d0
11351 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11353 cd write (2,*) 'eello6_5',eello6_5
11355 call transpose2(AEA(1,1,1),auxmat(1,1))
11356 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11357 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11358 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11360 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11361 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11362 s2 = scalar2(b1(1,k),vtemp1(1))
11364 call transpose2(AEA(1,1,2),atemp(1,1))
11365 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11366 call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11367 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11369 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11370 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11371 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11373 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11374 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11375 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11376 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11377 ss13 = scalar2(b1(1,k),vtemp4(1))
11378 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11380 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11386 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11387 C Derivatives in gamma(i+2)
11391 call transpose2(AEA(1,1,1),auxmatd(1,1))
11392 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11393 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11394 call transpose2(AEAderg(1,1,2),atempd(1,1))
11395 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11396 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11398 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11399 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11400 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11406 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11407 C Derivatives in gamma(i+3)
11409 call transpose2(AEA(1,1,1),auxmatd(1,1))
11410 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11411 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11412 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11414 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11415 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11416 s2d = scalar2(b1(1,k),vtemp1d(1))
11418 call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11419 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11421 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11423 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11424 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11425 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11433 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11434 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11436 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11437 & -0.5d0*ekont*(s2d+s12d)
11439 C Derivatives in gamma(i+4)
11440 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11441 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11442 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11444 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11445 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11446 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11454 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11456 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11458 C Derivatives in gamma(i+5)
11460 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11461 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11462 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11464 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11465 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11466 s2d = scalar2(b1(1,k),vtemp1d(1))
11468 call transpose2(AEA(1,1,2),atempd(1,1))
11469 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11470 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11472 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11473 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11475 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11476 ss13d = scalar2(b1(1,k),vtemp4d(1))
11477 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11485 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11486 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11488 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11489 & -0.5d0*ekont*(s2d+s12d)
11491 C Cartesian derivatives
11496 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11497 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11498 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11500 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11501 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11503 s2d = scalar2(b1(1,k),vtemp1d(1))
11505 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11506 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11507 s8d = -(atempd(1,1)+atempd(2,2))*
11508 & scalar2(cc(1,1,l),vtemp2(1))
11510 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11512 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11513 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11520 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11521 & - 0.5d0*(s1d+s2d)
11523 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11527 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11528 & - 0.5d0*(s8d+s12d)
11530 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11539 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11540 & achuj_tempd(1,1))
11541 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11542 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11543 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11544 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11545 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11547 ss13d = scalar2(b1(1,k),vtemp4d(1))
11548 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11549 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11553 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11554 cd & 16*eel_turn6_num
11556 if (j.lt.nres-1) then
11563 if (l.lt.nres-1) then
11571 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11572 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11573 cgrad ghalf=0.5d0*ggg1(ll)
11575 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11576 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11577 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11578 & +ekont*derx_turn(ll,2,1)
11579 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11580 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11581 & +ekont*derx_turn(ll,4,1)
11582 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11583 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11584 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11585 cgrad ghalf=0.5d0*ggg2(ll)
11587 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11588 & +ekont*derx_turn(ll,2,2)
11589 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11590 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11591 & +ekont*derx_turn(ll,4,2)
11592 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11593 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11594 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11599 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11604 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11610 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11615 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11619 cd write (2,*) iii,g_corr6_loc(iii)
11621 eello_turn6=ekont*eel_turn6
11622 cd write (2,*) 'ekont',ekont
11623 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11626 C-----------------------------------------------------------------------------
11628 double precision function scalar(u,v)
11629 !DIR$ INLINEALWAYS scalar
11631 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11634 double precision u(3),v(3)
11635 cd double precision sc
11643 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11646 crc-------------------------------------------------
11647 SUBROUTINE MATVEC2(A1,V1,V2)
11648 !DIR$ INLINEALWAYS MATVEC2
11650 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11652 implicit real*8 (a-h,o-z)
11653 include 'DIMENSIONS'
11654 DIMENSION A1(2,2),V1(2),V2(2)
11658 c 3 VI=VI+A1(I,K)*V1(K)
11662 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11663 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11668 C---------------------------------------
11669 SUBROUTINE MATMAT2(A1,A2,A3)
11671 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11673 implicit real*8 (a-h,o-z)
11674 include 'DIMENSIONS'
11675 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11676 c DIMENSION AI3(2,2)
11680 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11686 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11687 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11688 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11689 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11697 c-------------------------------------------------------------------------
11698 double precision function scalar2(u,v)
11699 !DIR$ INLINEALWAYS scalar2
11701 double precision u(2),v(2)
11702 double precision sc
11704 scalar2=u(1)*v(1)+u(2)*v(2)
11708 C-----------------------------------------------------------------------------
11710 subroutine transpose2(a,at)
11711 !DIR$ INLINEALWAYS transpose2
11713 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11716 double precision a(2,2),at(2,2)
11723 c--------------------------------------------------------------------------
11724 subroutine transpose(n,a,at)
11727 double precision a(n,n),at(n,n)
11735 C---------------------------------------------------------------------------
11736 subroutine prodmat3(a1,a2,kk,transp,prod)
11737 !DIR$ INLINEALWAYS prodmat3
11739 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11743 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11745 crc double precision auxmat(2,2),prod_(2,2)
11748 crc call transpose2(kk(1,1),auxmat(1,1))
11749 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11750 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11752 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11753 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11754 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11755 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11756 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11757 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11758 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11759 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11762 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11763 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11765 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11766 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11767 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11768 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11769 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11770 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11771 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11772 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11775 c call transpose2(a2(1,1),a2t(1,1))
11778 crc print *,((prod_(i,j),i=1,2),j=1,2)
11779 crc print *,((prod(i,j),i=1,2),j=1,2)
11783 CCC----------------------------------------------
11784 subroutine Eliptransfer(eliptran)
11785 implicit real*8 (a-h,o-z)
11786 include 'DIMENSIONS'
11787 include 'COMMON.GEO'
11788 include 'COMMON.VAR'
11789 include 'COMMON.LOCAL'
11790 include 'COMMON.CHAIN'
11791 include 'COMMON.DERIV'
11792 include 'COMMON.NAMES'
11793 include 'COMMON.INTERACT'
11794 include 'COMMON.IOUNITS'
11795 include 'COMMON.CALC'
11796 include 'COMMON.CONTROL'
11797 include 'COMMON.SPLITELE'
11798 include 'COMMON.SBRIDGE'
11799 C this is done by Adasko
11800 C print *,"wchodze"
11801 C structure of box:
11803 C--bordliptop-- buffore starts
11804 C--bufliptop--- here true lipid starts
11806 C--buflipbot--- lipid ends buffore starts
11807 C--bordlipbot--buffore ends
11809 do i=ilip_start,ilip_end
11811 if (itype(i).eq.ntyp1) cycle
11813 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11814 if (positi.le.0.0) positi=positi+boxzsize
11816 C first for peptide groups
11817 c for each residue check if it is in lipid or lipid water border area
11818 if ((positi.gt.bordlipbot)
11819 &.and.(positi.lt.bordliptop)) then
11820 C the energy transfer exist
11821 if (positi.lt.buflipbot) then
11822 C what fraction I am in
11824 & ((positi-bordlipbot)/lipbufthick)
11825 C lipbufthick is thickenes of lipid buffore
11826 sslip=sscalelip(fracinbuf)
11827 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11828 eliptran=eliptran+sslip*pepliptran
11829 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11830 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11831 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11833 C print *,"doing sccale for lower part"
11834 C print *,i,sslip,fracinbuf,ssgradlip
11835 elseif (positi.gt.bufliptop) then
11836 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11837 sslip=sscalelip(fracinbuf)
11838 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11839 eliptran=eliptran+sslip*pepliptran
11840 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11841 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11842 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11843 C print *, "doing sscalefor top part"
11844 C print *,i,sslip,fracinbuf,ssgradlip
11846 eliptran=eliptran+pepliptran
11847 C print *,"I am in true lipid"
11850 C eliptran=elpitran+0.0 ! I am in water
11853 C print *, "nic nie bylo w lipidzie?"
11854 C now multiply all by the peptide group transfer factor
11855 C eliptran=eliptran*pepliptran
11856 C now the same for side chains
11858 do i=ilip_start,ilip_end
11859 if (itype(i).eq.ntyp1) cycle
11860 positi=(mod(c(3,i+nres),boxzsize))
11861 if (positi.le.0) positi=positi+boxzsize
11862 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11863 c for each residue check if it is in lipid or lipid water border area
11864 C respos=mod(c(3,i+nres),boxzsize)
11865 C print *,positi,bordlipbot,buflipbot
11866 if ((positi.gt.bordlipbot)
11867 & .and.(positi.lt.bordliptop)) then
11868 C the energy transfer exist
11869 if (positi.lt.buflipbot) then
11871 & ((positi-bordlipbot)/lipbufthick)
11872 C lipbufthick is thickenes of lipid buffore
11873 sslip=sscalelip(fracinbuf)
11874 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11875 eliptran=eliptran+sslip*liptranene(itype(i))
11876 gliptranx(3,i)=gliptranx(3,i)
11877 &+ssgradlip*liptranene(itype(i))
11878 gliptranc(3,i-1)= gliptranc(3,i-1)
11879 &+ssgradlip*liptranene(itype(i))
11880 C print *,"doing sccale for lower part"
11881 elseif (positi.gt.bufliptop) then
11883 &((bordliptop-positi)/lipbufthick)
11884 sslip=sscalelip(fracinbuf)
11885 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11886 eliptran=eliptran+sslip*liptranene(itype(i))
11887 gliptranx(3,i)=gliptranx(3,i)
11888 &+ssgradlip*liptranene(itype(i))
11889 gliptranc(3,i-1)= gliptranc(3,i-1)
11890 &+ssgradlip*liptranene(itype(i))
11891 C print *, "doing sscalefor top part",sslip,fracinbuf
11893 eliptran=eliptran+liptranene(itype(i))
11894 C print *,"I am in true lipid"
11896 endif ! if in lipid or buffor
11898 C eliptran=elpitran+0.0 ! I am in water
11902 C---------------------------------------------------------
11903 C AFM soubroutine for constant force
11904 subroutine AFMforce(Eafmforce)
11905 implicit real*8 (a-h,o-z)
11906 include 'DIMENSIONS'
11907 include 'COMMON.GEO'
11908 include 'COMMON.VAR'
11909 include 'COMMON.LOCAL'
11910 include 'COMMON.CHAIN'
11911 include 'COMMON.DERIV'
11912 include 'COMMON.NAMES'
11913 include 'COMMON.INTERACT'
11914 include 'COMMON.IOUNITS'
11915 include 'COMMON.CALC'
11916 include 'COMMON.CONTROL'
11917 include 'COMMON.SPLITELE'
11918 include 'COMMON.SBRIDGE'
11923 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11924 dist=dist+diffafm(i)**2
11927 Eafmforce=-forceAFMconst*(dist-distafminit)
11929 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11930 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11932 C print *,'AFM',Eafmforce
11935 C---------------------------------------------------------
11936 C AFM subroutine with pseudoconstant velocity
11937 subroutine AFMvel(Eafmforce)
11938 implicit real*8 (a-h,o-z)
11939 include 'DIMENSIONS'
11940 include 'COMMON.GEO'
11941 include 'COMMON.VAR'
11942 include 'COMMON.LOCAL'
11943 include 'COMMON.CHAIN'
11944 include 'COMMON.DERIV'
11945 include 'COMMON.NAMES'
11946 include 'COMMON.INTERACT'
11947 include 'COMMON.IOUNITS'
11948 include 'COMMON.CALC'
11949 include 'COMMON.CONTROL'
11950 include 'COMMON.SPLITELE'
11951 include 'COMMON.SBRIDGE'
11953 C Only for check grad COMMENT if not used for checkgrad
11955 C--------------------------------------------------------
11956 C print *,"wchodze"
11960 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11961 dist=dist+diffafm(i)**2
11964 Eafmforce=0.5d0*forceAFMconst
11965 & *(distafminit+totTafm*velAFMconst-dist)**2
11966 C Eafmforce=-forceAFMconst*(dist-distafminit)
11968 gradafm(i,afmend-1)=-forceAFMconst*
11969 &(distafminit+totTafm*velAFMconst-dist)
11971 gradafm(i,afmbeg-1)=forceAFMconst*
11972 &(distafminit+totTafm*velAFMconst-dist)
11975 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11978 C-----------------------------------------------------------
11979 C first for shielding is setting of function of side-chains
11980 subroutine set_shield_fac
11981 implicit real*8 (a-h,o-z)
11982 include 'DIMENSIONS'
11983 include 'COMMON.CHAIN'
11984 include 'COMMON.DERIV'
11985 include 'COMMON.IOUNITS'
11986 include 'COMMON.SHIELD'
11987 include 'COMMON.INTERACT'
11988 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11989 double precision div77_81/0.974996043d0/,
11990 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11992 C the vector between center of side_chain and peptide group
11993 double precision pep_side(3),long,side_calf(3),
11994 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11995 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11996 C the line belowe needs to be changed for FGPROC>1
11998 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12000 Cif there two consequtive dummy atoms there is no peptide group between them
12001 C the line below has to be changed for FGPROC>1
12004 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12008 C first lets set vector conecting the ithe side-chain with kth side-chain
12009 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12010 C pep_side(j)=2.0d0
12011 C and vector conecting the side-chain with its proper calfa
12012 side_calf(j)=c(j,k+nres)-c(j,k)
12013 C side_calf(j)=2.0d0
12014 pept_group(j)=c(j,i)-c(j,i+1)
12015 C lets have their lenght
12016 dist_pep_side=pep_side(j)**2+dist_pep_side
12017 dist_side_calf=dist_side_calf+side_calf(j)**2
12018 dist_pept_group=dist_pept_group+pept_group(j)**2
12020 dist_pep_side=dsqrt(dist_pep_side)
12021 dist_pept_group=dsqrt(dist_pept_group)
12022 dist_side_calf=dsqrt(dist_side_calf)
12024 pep_side_norm(j)=pep_side(j)/dist_pep_side
12025 side_calf_norm(j)=dist_side_calf
12027 C now sscale fraction
12028 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12029 C print *,buff_shield,"buff"
12031 if (sh_frac_dist.le.0.0) cycle
12032 C If we reach here it means that this side chain reaches the shielding sphere
12033 C Lets add him to the list for gradient
12034 ishield_list(i)=ishield_list(i)+1
12035 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12036 C this list is essential otherwise problem would be O3
12037 shield_list(ishield_list(i),i)=k
12038 C Lets have the sscale value
12039 if (sh_frac_dist.gt.1.0) then
12040 scale_fac_dist=1.0d0
12042 sh_frac_dist_grad(j)=0.0d0
12045 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12046 & *(2.0*sh_frac_dist-3.0d0)
12047 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12048 & /dist_pep_side/buff_shield*0.5
12049 C remember for the final gradient multiply sh_frac_dist_grad(j)
12050 C for side_chain by factor -2 !
12052 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12053 C print *,"jestem",scale_fac_dist,fac_help_scale,
12054 C & sh_frac_dist_grad(j)
12057 C if ((i.eq.3).and.(k.eq.2)) then
12058 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12062 C this is what is now we have the distance scaling now volume...
12063 short=short_r_sidechain(itype(k))
12064 long=long_r_sidechain(itype(k))
12065 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12068 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12069 C costhet_fac=0.0d0
12071 costhet_grad(j)=costhet_fac*pep_side(j)
12073 C remember for the final gradient multiply costhet_grad(j)
12074 C for side_chain by factor -2 !
12075 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12076 C pep_side0pept_group is vector multiplication
12077 pep_side0pept_group=0.0
12079 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12081 cosalfa=(pep_side0pept_group/
12082 & (dist_pep_side*dist_side_calf))
12083 fac_alfa_sin=1.0-cosalfa**2
12084 fac_alfa_sin=dsqrt(fac_alfa_sin)
12085 rkprim=fac_alfa_sin*(long-short)+short
12087 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12088 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12091 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12092 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12093 &*(long-short)/fac_alfa_sin*cosalfa/
12094 &((dist_pep_side*dist_side_calf))*
12095 &((side_calf(j))-cosalfa*
12096 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12098 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12099 &*(long-short)/fac_alfa_sin*cosalfa
12100 &/((dist_pep_side*dist_side_calf))*
12102 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12105 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12108 C now the gradient...
12109 C grad_shield is gradient of Calfa for peptide groups
12110 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12112 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12113 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12115 grad_shield(j,i)=grad_shield(j,i)
12116 C gradient po skalowaniu
12117 & +(sh_frac_dist_grad(j)
12118 C gradient po costhet
12119 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12120 &-scale_fac_dist*(cosphi_grad_long(j))
12121 &/(1.0-cosphi) )*div77_81
12123 C grad_shield_side is Cbeta sidechain gradient
12124 grad_shield_side(j,ishield_list(i),i)=
12125 & (sh_frac_dist_grad(j)*(-2.0d0)
12126 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12127 & +scale_fac_dist*(cosphi_grad_long(j))
12128 & *2.0d0/(1.0-cosphi))
12129 & *div77_81*VofOverlap
12131 grad_shield_loc(j,ishield_list(i),i)=
12132 & scale_fac_dist*cosphi_grad_loc(j)
12133 & *2.0d0/(1.0-cosphi)
12134 & *div77_81*VofOverlap
12136 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12138 fac_shield(i)=VolumeTotal*div77_81+div4_81
12139 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12143 C--------------------------------------------------------------------------
12144 double precision function tschebyshev(m,n,x,y)
12146 include "DIMENSIONS"
12148 double precision x(n),y,yy(0:maxvar),aux
12149 c Tschebyshev polynomial. Note that the first term is omitted
12150 c m=0: the constant term is included
12151 c m=1: the constant term is not included
12155 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12164 C--------------------------------------------------------------------------
12165 double precision function gradtschebyshev(m,n,x,y)
12167 include "DIMENSIONS"
12169 double precision x(n+1),y,yy(0:maxvar),aux
12170 c Tschebyshev polynomial. Note that the first term is omitted
12171 c m=0: the constant term is included
12172 c m=1: the constant term is not included
12176 yy(i)=2*y*yy(i-1)-yy(i-2)
12180 aux=aux+x(i+1)*yy(i)*(i+1)
12181 C print *, x(i+1),yy(i),i
12183 gradtschebyshev=aux
12186 C------------------------------------------------------------------------
12187 C first for shielding is setting of function of side-chains
12188 subroutine set_shield_fac2
12189 implicit real*8 (a-h,o-z)
12190 include 'DIMENSIONS'
12191 include 'COMMON.CHAIN'
12192 include 'COMMON.DERIV'
12193 include 'COMMON.IOUNITS'
12194 include 'COMMON.SHIELD'
12195 include 'COMMON.INTERACT'
12196 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12197 double precision div77_81/0.974996043d0/,
12198 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12200 C the vector between center of side_chain and peptide group
12201 double precision pep_side(3),long,side_calf(3),
12202 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12203 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12204 C the line belowe needs to be changed for FGPROC>1
12206 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12208 Cif there two consequtive dummy atoms there is no peptide group between them
12209 C the line below has to be changed for FGPROC>1
12212 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12216 C first lets set vector conecting the ithe side-chain with kth side-chain
12217 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12218 C pep_side(j)=2.0d0
12219 C and vector conecting the side-chain with its proper calfa
12220 side_calf(j)=c(j,k+nres)-c(j,k)
12221 C side_calf(j)=2.0d0
12222 pept_group(j)=c(j,i)-c(j,i+1)
12223 C lets have their lenght
12224 dist_pep_side=pep_side(j)**2+dist_pep_side
12225 dist_side_calf=dist_side_calf+side_calf(j)**2
12226 dist_pept_group=dist_pept_group+pept_group(j)**2
12228 dist_pep_side=dsqrt(dist_pep_side)
12229 dist_pept_group=dsqrt(dist_pept_group)
12230 dist_side_calf=dsqrt(dist_side_calf)
12232 pep_side_norm(j)=pep_side(j)/dist_pep_side
12233 side_calf_norm(j)=dist_side_calf
12235 C now sscale fraction
12236 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12237 C print *,buff_shield,"buff"
12239 if (sh_frac_dist.le.0.0) cycle
12240 C If we reach here it means that this side chain reaches the shielding sphere
12241 C Lets add him to the list for gradient
12242 ishield_list(i)=ishield_list(i)+1
12243 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12244 C this list is essential otherwise problem would be O3
12245 shield_list(ishield_list(i),i)=k
12246 C Lets have the sscale value
12247 if (sh_frac_dist.gt.1.0) then
12248 scale_fac_dist=1.0d0
12250 sh_frac_dist_grad(j)=0.0d0
12253 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12254 & *(2.0d0*sh_frac_dist-3.0d0)
12255 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12256 & /dist_pep_side/buff_shield*0.5d0
12257 C remember for the final gradient multiply sh_frac_dist_grad(j)
12258 C for side_chain by factor -2 !
12260 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12261 C sh_frac_dist_grad(j)=0.0d0
12262 C scale_fac_dist=1.0d0
12263 C print *,"jestem",scale_fac_dist,fac_help_scale,
12264 C & sh_frac_dist_grad(j)
12267 C this is what is now we have the distance scaling now volume...
12268 short=short_r_sidechain(itype(k))
12269 long=long_r_sidechain(itype(k))
12270 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12271 sinthet=short/dist_pep_side*costhet
12275 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12276 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12277 C & -short/dist_pep_side**2/costhet)
12278 C costhet_fac=0.0d0
12280 costhet_grad(j)=costhet_fac*pep_side(j)
12282 C remember for the final gradient multiply costhet_grad(j)
12283 C for side_chain by factor -2 !
12284 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12285 C pep_side0pept_group is vector multiplication
12286 pep_side0pept_group=0.0d0
12288 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12290 cosalfa=(pep_side0pept_group/
12291 & (dist_pep_side*dist_side_calf))
12292 fac_alfa_sin=1.0d0-cosalfa**2
12293 fac_alfa_sin=dsqrt(fac_alfa_sin)
12294 rkprim=fac_alfa_sin*(long-short)+short
12298 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12300 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12301 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12302 & dist_pep_side**2)
12305 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12306 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12307 &*(long-short)/fac_alfa_sin*cosalfa/
12308 &((dist_pep_side*dist_side_calf))*
12309 &((side_calf(j))-cosalfa*
12310 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12311 C cosphi_grad_long(j)=0.0d0
12312 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12313 &*(long-short)/fac_alfa_sin*cosalfa
12314 &/((dist_pep_side*dist_side_calf))*
12316 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12317 C cosphi_grad_loc(j)=0.0d0
12319 C print *,sinphi,sinthet
12320 c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12321 c & VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12322 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12325 C now the gradient...
12327 grad_shield(j,i)=grad_shield(j,i)
12328 C gradient po skalowaniu
12329 & +(sh_frac_dist_grad(j)*VofOverlap
12330 C gradient po costhet
12331 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12332 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12333 & sinphi/sinthet*costhet*costhet_grad(j)
12334 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12336 C grad_shield_side is Cbeta sidechain gradient
12337 grad_shield_side(j,ishield_list(i),i)=
12338 & (sh_frac_dist_grad(j)*(-2.0d0)
12340 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12341 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12342 & sinphi/sinthet*costhet*costhet_grad(j)
12343 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12346 grad_shield_loc(j,ishield_list(i),i)=
12347 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12348 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12349 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12353 c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12355 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12357 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12358 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12359 c & " wshield",wshield
12360 c write(2,*) "TU",rpp(1,1),short,long,buff_shield
12364 C-----------------------------------------------------------------------
12365 C-----------------------------------------------------------
12366 C This subroutine is to mimic the histone like structure but as well can be
12367 C utilizet to nanostructures (infinit) small modification has to be used to
12368 C make it finite (z gradient at the ends has to be changes as well as the x,y
12369 C gradient has to be modified at the ends
12370 C The energy function is Kihara potential
12371 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12372 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12373 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12374 C simple Kihara potential
12375 subroutine calctube(Etube)
12376 implicit real*8 (a-h,o-z)
12377 include 'DIMENSIONS'
12378 include 'COMMON.GEO'
12379 include 'COMMON.VAR'
12380 include 'COMMON.LOCAL'
12381 include 'COMMON.CHAIN'
12382 include 'COMMON.DERIV'
12383 include 'COMMON.NAMES'
12384 include 'COMMON.INTERACT'
12385 include 'COMMON.IOUNITS'
12386 include 'COMMON.CALC'
12387 include 'COMMON.CONTROL'
12388 include 'COMMON.SPLITELE'
12389 include 'COMMON.SBRIDGE'
12390 double precision tub_r,vectube(3),enetube(maxres*2)
12395 C first we calculate the distance from tube center
12396 C first sugare-phosphate group for NARES this would be peptide group
12399 C lets ommit dummy atoms for now
12400 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12401 C now calculate distance from center of tube and direction vectors
12402 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12403 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12404 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12405 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12406 vectube(1)=vectube(1)-tubecenter(1)
12407 vectube(2)=vectube(2)-tubecenter(2)
12409 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12410 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12412 C as the tube is infinity we do not calculate the Z-vector use of Z
12415 C now calculte the distance
12416 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12417 C now normalize vector
12418 vectube(1)=vectube(1)/tub_r
12419 vectube(2)=vectube(2)/tub_r
12420 C calculte rdiffrence between r and r0
12423 rdiff6=rdiff**6.0d0
12424 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12425 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12426 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12427 C print *,rdiff,rdiff6,pep_aa_tube
12428 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12429 C now we calculate gradient
12430 fac=(-12.0d0*pep_aa_tube/rdiff6+
12431 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12432 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12435 C now direction of gg_tube vector
12437 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12438 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12441 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12443 C Lets not jump over memory as we use many times iti
12445 C lets ommit dummy atoms for now
12447 C in UNRES uncomment the line below as GLY has no side-chain...
12450 vectube(1)=c(1,i+nres)
12451 vectube(1)=mod(vectube(1),boxxsize)
12452 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12453 vectube(2)=c(2,i+nres)
12454 vectube(2)=mod(vectube(2),boxxsize)
12455 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12457 vectube(1)=vectube(1)-tubecenter(1)
12458 vectube(2)=vectube(2)-tubecenter(2)
12460 C as the tube is infinity we do not calculate the Z-vector use of Z
12463 C now calculte the distance
12464 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12465 C now normalize vector
12466 vectube(1)=vectube(1)/tub_r
12467 vectube(2)=vectube(2)/tub_r
12468 C calculte rdiffrence between r and r0
12471 rdiff6=rdiff**6.0d0
12472 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12473 sc_aa_tube=sc_aa_tube_par(iti)
12474 sc_bb_tube=sc_bb_tube_par(iti)
12475 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12476 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12477 C now we calculate gradient
12478 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12479 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12480 C now direction of gg_tube vector
12482 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12483 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12487 Etube=Etube+enetube(i)
12489 C print *,"ETUBE", etube
12492 C TO DO 1) add to total energy
12493 C 2) add to gradient summation
12494 C 3) add reading parameters (AND of course oppening of PARAM file)
12495 C 4) add reading the center of tube
12497 C 6) add to zerograd
12499 C-----------------------------------------------------------------------
12500 C-----------------------------------------------------------
12501 C This subroutine is to mimic the histone like structure but as well can be
12502 C utilizet to nanostructures (infinit) small modification has to be used to
12503 C make it finite (z gradient at the ends has to be changes as well as the x,y
12504 C gradient has to be modified at the ends
12505 C The energy function is Kihara potential
12506 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12507 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12508 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12509 C simple Kihara potential
12510 subroutine calctube2(Etube)
12511 implicit real*8 (a-h,o-z)
12512 include 'DIMENSIONS'
12513 include 'COMMON.GEO'
12514 include 'COMMON.VAR'
12515 include 'COMMON.LOCAL'
12516 include 'COMMON.CHAIN'
12517 include 'COMMON.DERIV'
12518 include 'COMMON.NAMES'
12519 include 'COMMON.INTERACT'
12520 include 'COMMON.IOUNITS'
12521 include 'COMMON.CALC'
12522 include 'COMMON.CONTROL'
12523 include 'COMMON.SPLITELE'
12524 include 'COMMON.SBRIDGE'
12525 double precision tub_r,vectube(3),enetube(maxres*2)
12530 C first we calculate the distance from tube center
12531 C first sugare-phosphate group for NARES this would be peptide group
12534 C lets ommit dummy atoms for now
12535 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12536 C now calculate distance from center of tube and direction vectors
12537 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12538 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12539 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12540 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12541 vectube(1)=vectube(1)-tubecenter(1)
12542 vectube(2)=vectube(2)-tubecenter(2)
12544 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12545 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12547 C as the tube is infinity we do not calculate the Z-vector use of Z
12550 C now calculte the distance
12551 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12552 C now normalize vector
12553 vectube(1)=vectube(1)/tub_r
12554 vectube(2)=vectube(2)/tub_r
12555 C calculte rdiffrence between r and r0
12558 rdiff6=rdiff**6.0d0
12559 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12560 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12561 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12562 C print *,rdiff,rdiff6,pep_aa_tube
12563 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12564 C now we calculate gradient
12565 fac=(-12.0d0*pep_aa_tube/rdiff6+
12566 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12567 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12570 C now direction of gg_tube vector
12572 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12573 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12576 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12578 C Lets not jump over memory as we use many times iti
12580 C lets ommit dummy atoms for now
12582 C in UNRES uncomment the line below as GLY has no side-chain...
12585 vectube(1)=c(1,i+nres)
12586 vectube(1)=mod(vectube(1),boxxsize)
12587 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12588 vectube(2)=c(2,i+nres)
12589 vectube(2)=mod(vectube(2),boxxsize)
12590 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12592 vectube(1)=vectube(1)-tubecenter(1)
12593 vectube(2)=vectube(2)-tubecenter(2)
12594 C THIS FRAGMENT MAKES TUBE FINITE
12595 positi=(mod(c(3,i+nres),boxzsize))
12596 if (positi.le.0) positi=positi+boxzsize
12597 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12598 c for each residue check if it is in lipid or lipid water border area
12599 C respos=mod(c(3,i+nres),boxzsize)
12600 print *,positi,bordtubebot,buftubebot,bordtubetop
12601 if ((positi.gt.bordtubebot)
12602 & .and.(positi.lt.bordtubetop)) then
12603 C the energy transfer exist
12604 if (positi.lt.buftubebot) then
12606 & ((positi-bordtubebot)/tubebufthick)
12607 C lipbufthick is thickenes of lipid buffore
12608 sstube=sscalelip(fracinbuf)
12609 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12610 print *,ssgradtube, sstube,tubetranene(itype(i))
12611 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12612 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12613 &+ssgradtube*tubetranene(itype(i))
12614 gg_tube(3,i-1)= gg_tube(3,i-1)
12615 &+ssgradtube*tubetranene(itype(i))
12616 C print *,"doing sccale for lower part"
12617 elseif (positi.gt.buftubetop) then
12619 &((bordtubetop-positi)/tubebufthick)
12620 sstube=sscalelip(fracinbuf)
12621 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12622 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12623 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12624 C &+ssgradtube*tubetranene(itype(i))
12625 C gg_tube(3,i-1)= gg_tube(3,i-1)
12626 C &+ssgradtube*tubetranene(itype(i))
12627 C print *, "doing sscalefor top part",sslip,fracinbuf
12631 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12632 C print *,"I am in true lipid"
12638 endif ! if in lipid or buffor
12639 CEND OF FINITE FRAGMENT
12640 C as the tube is infinity we do not calculate the Z-vector use of Z
12643 C now calculte the distance
12644 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12645 C now normalize vector
12646 vectube(1)=vectube(1)/tub_r
12647 vectube(2)=vectube(2)/tub_r
12648 C calculte rdiffrence between r and r0
12651 rdiff6=rdiff**6.0d0
12652 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12653 sc_aa_tube=sc_aa_tube_par(iti)
12654 sc_bb_tube=sc_bb_tube_par(iti)
12655 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12656 & *sstube+enetube(i+nres)
12657 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12658 C now we calculate gradient
12659 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12660 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12661 C now direction of gg_tube vector
12663 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12664 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12666 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12667 &+ssgradtube*enetube(i+nres)/sstube
12668 gg_tube(3,i-1)= gg_tube(3,i-1)
12669 &+ssgradtube*enetube(i+nres)/sstube
12673 Etube=Etube+enetube(i)
12675 C print *,"ETUBE", etube
12678 C TO DO 1) add to total energy
12679 C 2) add to gradient summation
12680 C 3) add reading parameters (AND of course oppening of PARAM file)
12681 C 4) add reading the center of tube
12683 C 6) add to zerograd
12684 c----------------------------------------------------------------------------
12685 subroutine e_saxs(Esaxs_constr)
12687 include 'DIMENSIONS'
12690 include "COMMON.SETUP"
12693 include 'COMMON.SBRIDGE'
12694 include 'COMMON.CHAIN'
12695 include 'COMMON.GEO'
12696 include 'COMMON.DERIV'
12697 include 'COMMON.LOCAL'
12698 include 'COMMON.INTERACT'
12699 include 'COMMON.VAR'
12700 include 'COMMON.IOUNITS'
12701 c include 'COMMON.MD'
12704 include 'COMMON.LANGEVIN.lang0.5diag'
12706 include 'COMMON.LANGEVIN.lang0'
12709 include 'COMMON.LANGEVIN'
12711 include 'COMMON.CONTROL'
12712 include 'COMMON.SAXS'
12713 include 'COMMON.NAMES'
12714 include 'COMMON.TIME1'
12715 include 'COMMON.FFIELD'
12717 double precision Esaxs_constr
12718 integer i,iint,j,k,l
12719 double precision PgradC(maxSAXS,3,maxres),
12720 & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12722 double precision PgradC_(maxSAXS,3,maxres),
12723 & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12725 double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12726 & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12727 & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12728 & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12729 double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12730 double precision dist,mygauss,mygaussder
12732 integer llicz,lllicz
12733 double precision time01
12734 c SAXS restraint penalty function
12736 write(iout,*) "------- SAXS penalty function start -------"
12737 write (iout,*) "nsaxs",nsaxs
12738 write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12739 write (iout,*) "Psaxs"
12741 write (iout,'(i5,e15.5)') i, Psaxs(i)
12747 Esaxs_constr = 0.0d0
12752 PgradC(k,l,j)=0.0d0
12753 PgradX(k,l,j)=0.0d0
12758 do i=iatsc_s,iatsc_e
12759 if (itype(i).eq.ntyp1) cycle
12760 do iint=1,nint_gr(i)
12761 do j=istart(i,iint),iend(i,iint)
12762 if (itype(j).eq.ntyp1) cycle
12765 dijCASC=dist(i,j+nres)
12766 dijSCCA=dist(i+nres,j)
12767 dijSCSC=dist(i+nres,j+nres)
12768 sigma2CACA=2.0d0/(pstok**2)
12769 sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12770 sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12771 sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12774 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12775 if (itype(j).ne.10) then
12776 expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12780 if (itype(i).ne.10) then
12781 expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12785 if (itype(i).ne.10 .and. itype(j).ne.10) then
12786 expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12790 Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12792 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12794 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12795 CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12796 SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12797 SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12800 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12801 PgradC(k,l,i) = PgradC(k,l,i)-aux
12802 PgradC(k,l,j) = PgradC(k,l,j)+aux
12804 if (itype(j).ne.10) then
12805 aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12806 PgradC(k,l,i) = PgradC(k,l,i)-aux
12807 PgradC(k,l,j) = PgradC(k,l,j)+aux
12808 PgradX(k,l,j) = PgradX(k,l,j)+aux
12811 if (itype(i).ne.10) then
12812 aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12813 PgradX(k,l,i) = PgradX(k,l,i)-aux
12814 PgradC(k,l,i) = PgradC(k,l,i)-aux
12815 PgradC(k,l,j) = PgradC(k,l,j)+aux
12818 if (itype(i).ne.10 .and. itype(j).ne.10) then
12819 aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12820 PgradC(k,l,i) = PgradC(k,l,i)-aux
12821 PgradC(k,l,j) = PgradC(k,l,j)+aux
12822 PgradX(k,l,i) = PgradX(k,l,i)-aux
12823 PgradX(k,l,j) = PgradX(k,l,j)+aux
12829 sigma2CACA=scal_rad**2*0.25d0/
12830 & (restok(itype(j))**2+restok(itype(i))**2)
12831 c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12832 c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12834 sigmaCACA=dsqrt(sigma2CACA)
12835 threesig=3.0d0/sigmaCACA
12839 if (dabs(dijCACA-dk).ge.threesig) cycle
12842 aux = sigmaCACA*(dijCACA-dk)
12843 expCACA = mygauss(aux)
12844 c if (expcaca.eq.0.0d0) cycle
12845 Pcalc(k) = Pcalc(k)+expCACA
12846 CACAgrad = -sigmaCACA*mygaussder(aux)
12847 c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12849 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12850 PgradC(k,l,i) = PgradC(k,l,i)-aux
12851 PgradC(k,l,j) = PgradC(k,l,j)+aux
12854 c write (iout,*) "i",i," j",j," llicz",llicz
12856 IF (saxs_cutoff.eq.0) THEN
12859 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12860 Pcalc(k) = Pcalc(k)+expCACA
12861 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12863 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12864 PgradC(k,l,i) = PgradC(k,l,i)-aux
12865 PgradC(k,l,j) = PgradC(k,l,j)+aux
12869 rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12872 c write (2,*) "ijk",i,j,k
12873 sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12874 if (sss2.eq.0.0d0) cycle
12875 ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12876 if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12877 & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12878 & 1.0d0/dsqrt(sigma2CACA),rrr,dk,
12880 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
12881 Pcalc(k) = Pcalc(k)+expCACA
12883 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12885 CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
12886 & ssgrad2*expCACA/sss2
12889 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12890 PgradC(k,l,i) = PgradC(k,l,i)+aux
12891 PgradC(k,l,j) = PgradC(k,l,j)-aux
12901 c time_SAXS=time_SAXS+MPI_Wtime()-time01
12903 c write (iout,*) "lllicz",lllicz
12905 c time01=MPI_Wtime()
12908 if (nfgtasks.gt.1) then
12909 call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
12910 & MPI_SUM,FG_COMM,IERR)
12911 c if (fg_rank.eq.king) then
12913 Pcalc(k) = Pcalc_(k)
12916 c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
12917 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12918 c if (fg_rank.eq.king) then
12922 c PgradC(k,l,i) = PgradC_(k,l,i)
12928 c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
12929 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12930 c if (fg_rank.eq.king) then
12934 c PgradX(k,l,i) = PgradX_(k,l,i)
12944 Cnorm = Cnorm + Pcalc(k)
12947 if (fg_rank.eq.king) then
12949 Esaxs_constr = dlog(Cnorm)-wsaxs0
12951 if (Pcalc(k).gt.0.0d0)
12952 & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
12954 write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
12958 write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
12973 & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
12974 auxC1 = auxC1+PgradC(k,l,i)
12976 auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
12977 auxX1 = auxX1+PgradX(k,l,i)
12980 gsaxsC(l,i) = auxC - auxC1/Cnorm
12982 gsaxsX(l,i) = auxX - auxX1/Cnorm
12984 c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
12985 c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
12986 c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
12987 c * " gradX",wsaxs*gsaxsX(l,i)
12991 time_SAXS=time_SAXS+MPI_Wtime()-time01
12994 write (iout,*) "gsaxsc"
12996 write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13004 c----------------------------------------------------------------------------
13005 subroutine e_saxsC(Esaxs_constr)
13007 include 'DIMENSIONS'
13010 include "COMMON.SETUP"
13013 include 'COMMON.SBRIDGE'
13014 include 'COMMON.CHAIN'
13015 include 'COMMON.GEO'
13016 include 'COMMON.DERIV'
13017 include 'COMMON.LOCAL'
13018 include 'COMMON.INTERACT'
13019 include 'COMMON.VAR'
13020 include 'COMMON.IOUNITS'
13021 c include 'COMMON.MD'
13024 include 'COMMON.LANGEVIN.lang0.5diag'
13026 include 'COMMON.LANGEVIN.lang0'
13029 include 'COMMON.LANGEVIN'
13031 include 'COMMON.CONTROL'
13032 include 'COMMON.SAXS'
13033 include 'COMMON.NAMES'
13034 include 'COMMON.TIME1'
13035 include 'COMMON.FFIELD'
13037 double precision Esaxs_constr
13038 integer i,iint,j,k,l
13039 double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13041 double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13043 double precision dk,dijCASPH,dijSCSPH,
13044 & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13045 & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13047 c SAXS restraint penalty function
13049 write(iout,*) "------- SAXS penalty function start -------"
13050 write (iout,*) "nsaxs",nsaxs
13053 print *,MyRank,"C",i,(C(j,i),j=1,3)
13056 print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13059 Esaxs_constr = 0.0d0
13061 do j=isaxs_start,isaxs_end
13070 if (itype(i).eq.ntyp1) cycle
13074 dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13076 if (itype(i).ne.10) then
13078 dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13081 sigma2CA=2.0d0/pstok**2
13082 sigma2SC=4.0d0/restok(itype(i))**2
13083 expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13084 expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13085 Pcalc = Pcalc+expCASPH+expSCSPH
13087 write(*,*) "processor i j Pcalc",
13088 & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13090 CASPHgrad = sigma2CA*expCASPH
13091 SCSPHgrad = sigma2SC*expSCSPH
13093 aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13094 PgradX(l,i) = PgradX(l,i) + aux
13095 PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13100 gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13101 gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13104 logPtot = logPtot - dlog(Pcalc)
13105 c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13106 c & " logPtot",logPtot
13109 if (nfgtasks.gt.1) then
13110 c write (iout,*) "logPtot before reduction",logPtot
13111 call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13112 & MPI_SUM,king,FG_COMM,IERR)
13114 c write (iout,*) "logPtot after reduction",logPtot
13115 call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13116 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13117 if (fg_rank.eq.king) then
13120 gsaxsC(l,i) = gsaxsC_(l,i)
13124 call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13125 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13126 if (fg_rank.eq.king) then
13129 gsaxsX(l,i) = gsaxsX_(l,i)
13135 Esaxs_constr = logPtot
13138 c----------------------------------------------------------------------------
13139 double precision function sscale2(r,r_cut,r0,rlamb)
13141 double precision r,gamm,r_cut,r0,rlamb,rr
13143 c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13144 c write (2,*) "rr",rr
13145 if(rr.lt.r_cut-rlamb) then
13147 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13148 gamm=(rr-(r_cut-rlamb))/rlamb
13149 sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13155 C-----------------------------------------------------------------------
13156 double precision function sscalgrad2(r,r_cut,r0,rlamb)
13158 double precision r,gamm,r_cut,r0,rlamb,rr
13160 if(rr.lt.r_cut-rlamb) then
13162 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13163 gamm=(rr-(r_cut-rlamb))/rlamb
13165 sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13167 sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13174 c------------------------------------------------------------------------
13175 double precision function boxshift(x,boxsize)
13177 double precision x,boxsize
13178 double precision xtemp
13179 xtemp=dmod(x,boxsize)
13180 if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13181 boxshift=xtemp-boxsize
13182 else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13183 boxshift=xtemp+boxsize
13189 c--------------------------------------------------------------------------
13190 subroutine closest_img(xi,yi,zi,xj,yj,zj)
13191 include 'DIMENSIONS'
13192 include 'COMMON.CHAIN'
13193 integer xshift,yshift,zshift,subchap
13194 double precision dist_init,xj_safe,yj_safe,zj_safe,
13195 & xj_temp,yj_temp,zj_temp,dist_temp
13199 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13204 xj=xj_safe+xshift*boxxsize
13205 yj=yj_safe+yshift*boxysize
13206 zj=zj_safe+zshift*boxzsize
13207 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13208 if(dist_temp.lt.dist_init) then
13209 dist_init=dist_temp
13218 if (subchap.eq.1) then
13229 c--------------------------------------------------------------------------
13230 subroutine to_box(xi,yi,zi)
13232 include 'DIMENSIONS'
13233 include 'COMMON.CHAIN'
13234 double precision xi,yi,zi
13235 xi=dmod(xi,boxxsize)
13236 if (xi.lt.0.0d0) xi=xi+boxxsize
13237 yi=dmod(yi,boxysize)
13238 if (yi.lt.0.0d0) yi=yi+boxysize
13239 zi=dmod(zi,boxzsize)
13240 if (zi.lt.0.0d0) zi=zi+boxzsize
13243 c--------------------------------------------------------------------------
13244 subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13246 include 'DIMENSIONS'
13247 include 'COMMON.CHAIN'
13248 double precision xi,yi,zi,sslipi,ssgradlipi
13249 double precision fracinbuf
13250 double precision sscalelip,sscagradlip
13252 if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13253 C the energy transfer exist
13254 if (zi.lt.buflipbot) then
13255 C what fraction I am in
13256 fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13257 C lipbufthick is thickenes of lipid buffore
13258 sslipi=sscalelip(fracinbuf)
13259 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13260 elseif (zi.gt.bufliptop) then
13261 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13262 sslipi=sscalelip(fracinbuf)
13263 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick