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
2311 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2312 & *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2313 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2314 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2315 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2316 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2320 C Calculate angular part of the gradient.
2321 c call sc_grad_scale(sss)
2327 C-----------------------------------------------------------------------------
2328 subroutine sc_angular
2329 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2330 C om12. Called by ebp, egb, and egbv.
2332 include 'COMMON.CALC'
2333 include 'COMMON.IOUNITS'
2337 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2338 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2339 om12=dxi*dxj+dyi*dyj+dzi*dzj
2341 C Calculate eps1(om12) and its derivative in om12
2342 faceps1=1.0D0-om12*chiom12
2343 faceps1_inv=1.0D0/faceps1
2344 eps1=dsqrt(faceps1_inv)
2345 C Following variable is eps1*deps1/dom12
2346 eps1_om12=faceps1_inv*chiom12
2351 c write (iout,*) "om12",om12," eps1",eps1
2352 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2357 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2358 sigsq=1.0D0-facsig*faceps1_inv
2359 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2360 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2361 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2367 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2368 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2370 C Calculate eps2 and its derivatives in om1, om2, and om12.
2373 chipom12=chip12*om12
2374 facp=1.0D0-om12*chipom12
2376 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2377 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2378 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2379 C Following variable is the square root of eps2
2380 eps2rt=1.0D0-facp1*facp_inv
2381 C Following three variables are the derivatives of the square root of eps
2382 C in om1, om2, and om12.
2383 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2384 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2385 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2386 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2387 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2388 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2389 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2390 c & " eps2rt_om12",eps2rt_om12
2391 C Calculate whole angle-dependent part of epsilon and contributions
2392 C to its derivatives
2395 C----------------------------------------------------------------------------
2397 implicit real*8 (a-h,o-z)
2398 include 'DIMENSIONS'
2399 include 'COMMON.CHAIN'
2400 include 'COMMON.DERIV'
2401 include 'COMMON.CALC'
2402 include 'COMMON.IOUNITS'
2403 double precision dcosom1(3),dcosom2(3)
2404 cc print *,'sss=',sss
2405 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2406 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2407 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2408 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2412 c eom12=evdwij*eps1_om12
2414 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2415 c & " sigder",sigder
2416 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2417 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2419 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2420 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2423 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2425 c write (iout,*) "gg",(gg(k),k=1,3)
2427 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2428 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2429 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2430 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2431 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2432 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2433 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2434 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2435 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2436 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2439 C Calculate the components of the gradient in DC and X
2443 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2447 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2448 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2452 C-----------------------------------------------------------------------
2453 subroutine e_softsphere(evdw)
2455 C This subroutine calculates the interaction energy of nonbonded side chains
2456 C assuming the LJ potential of interaction.
2458 implicit real*8 (a-h,o-z)
2459 include 'DIMENSIONS'
2460 parameter (accur=1.0d-10)
2461 include 'COMMON.GEO'
2462 include 'COMMON.VAR'
2463 include 'COMMON.LOCAL'
2464 include 'COMMON.CHAIN'
2465 include 'COMMON.DERIV'
2466 include 'COMMON.INTERACT'
2467 include 'COMMON.TORSION'
2468 include 'COMMON.SBRIDGE'
2469 include 'COMMON.NAMES'
2470 include 'COMMON.IOUNITS'
2471 c include 'COMMON.CONTACTS'
2473 double precision boxshift
2474 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2476 c do i=iatsc_s,iatsc_e
2477 do ikont=g_listscsc_start,g_listscsc_end
2478 i=newcontlisti(ikont)
2479 j=newcontlistj(ikont)
2480 itypi=iabs(itype(i))
2481 if (itypi.eq.ntyp1) cycle
2482 itypi1=iabs(itype(i+1))
2486 call to_box(xi,yi,zi)
2488 C Calculate SC interaction energy.
2490 c do iint=1,nint_gr(i)
2491 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2492 cd & 'iend=',iend(i,iint)
2493 c do j=istart(i,iint),iend(i,iint)
2494 itypj=iabs(itype(j))
2495 if (itypj.eq.ntyp1) cycle
2496 xj=boxshift(c(1,nres+j)-xi,boxxsize)
2497 yj=boxshift(c(2,nres+j)-yi,boxysize)
2498 zj=boxshift(c(3,nres+j)-zi,boxzsize)
2499 rij=xj*xj+yj*yj+zj*zj
2500 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2501 r0ij=r0(itypi,itypj)
2503 c print *,i,j,r0ij,dsqrt(rij)
2504 if (rij.lt.r0ijsq) then
2505 evdwij=0.25d0*(rij-r0ijsq)**2
2513 C Calculate the components of the gradient in DC and X
2519 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2520 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2521 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2522 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2526 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2534 C--------------------------------------------------------------------------
2535 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2538 C Soft-sphere potential of p-p interaction
2540 implicit real*8 (a-h,o-z)
2541 include 'DIMENSIONS'
2542 include 'COMMON.CONTROL'
2543 include 'COMMON.IOUNITS'
2544 include 'COMMON.GEO'
2545 include 'COMMON.VAR'
2546 include 'COMMON.LOCAL'
2547 include 'COMMON.CHAIN'
2548 include 'COMMON.DERIV'
2549 include 'COMMON.INTERACT'
2550 c include 'COMMON.CONTACTS'
2551 include 'COMMON.TORSION'
2552 include 'COMMON.VECTORS'
2553 include 'COMMON.FFIELD'
2555 double precision boxshift
2556 C write(iout,*) 'In EELEC_soft_sphere'
2563 do i=iatel_s,iatel_e
2564 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2568 xmedi=c(1,i)+0.5d0*dxi
2569 ymedi=c(2,i)+0.5d0*dyi
2570 zmedi=c(3,i)+0.5d0*dzi
2571 call to_box(xmedi,ymedi,zmedi)
2573 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2574 do j=ielstart(i),ielend(i)
2575 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2579 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2580 r0ij=rpp(iteli,itelj)
2588 call to_box(xj,yj,zj)
2589 xj=boxshift(xj-xmedi,boxxsize)
2590 yj=boxshift(yj-ymedi,boxysize)
2591 zj=boxshift(zj-zmedi,boxzsize)
2592 rij=xj*xj+yj*yj+zj*zj
2593 sss=sscale(sqrt(rij),r_cut_int)
2594 sssgrad=sscagrad(sqrt(rij),r_cut_int)
2595 if (rij.lt.r0ijsq) then
2596 evdw1ij=0.25d0*(rij-r0ijsq)**2
2602 evdw1=evdw1+evdw1ij*sss
2604 C Calculate contributions to the Cartesian gradient.
2606 ggg(1)=fac*xj*sssgrad
2607 ggg(2)=fac*yj*sssgrad
2608 ggg(3)=fac*zj*sssgrad
2610 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2611 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2614 * Loop over residues i+1 thru j-1.
2618 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2623 cgrad do i=nnt,nct-1
2625 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2627 cgrad do j=i+1,nct-1
2629 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2635 c------------------------------------------------------------------------------
2636 subroutine vec_and_deriv
2637 implicit real*8 (a-h,o-z)
2638 include 'DIMENSIONS'
2642 include 'COMMON.IOUNITS'
2643 include 'COMMON.GEO'
2644 include 'COMMON.VAR'
2645 include 'COMMON.LOCAL'
2646 include 'COMMON.CHAIN'
2647 include 'COMMON.VECTORS'
2648 include 'COMMON.SETUP'
2649 include 'COMMON.TIME1'
2650 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2651 C Compute the local reference systems. For reference system (i), the
2652 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2653 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2655 do i=ivec_start,ivec_end
2659 if (i.eq.nres-1) then
2660 C Case of the last full residue
2661 C Compute the Z-axis
2662 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2663 costh=dcos(pi-theta(nres))
2664 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2668 C Compute the derivatives of uz
2670 uzder(2,1,1)=-dc_norm(3,i-1)
2671 uzder(3,1,1)= dc_norm(2,i-1)
2672 uzder(1,2,1)= dc_norm(3,i-1)
2674 uzder(3,2,1)=-dc_norm(1,i-1)
2675 uzder(1,3,1)=-dc_norm(2,i-1)
2676 uzder(2,3,1)= dc_norm(1,i-1)
2679 uzder(2,1,2)= dc_norm(3,i)
2680 uzder(3,1,2)=-dc_norm(2,i)
2681 uzder(1,2,2)=-dc_norm(3,i)
2683 uzder(3,2,2)= dc_norm(1,i)
2684 uzder(1,3,2)= dc_norm(2,i)
2685 uzder(2,3,2)=-dc_norm(1,i)
2687 C Compute the Y-axis
2690 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2692 C Compute the derivatives of uy
2695 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2696 & -dc_norm(k,i)*dc_norm(j,i-1)
2697 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2699 uyder(j,j,1)=uyder(j,j,1)-costh
2700 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2705 uygrad(l,k,j,i)=uyder(l,k,j)
2706 uzgrad(l,k,j,i)=uzder(l,k,j)
2710 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2711 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2712 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2713 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2716 C Compute the Z-axis
2717 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2718 costh=dcos(pi-theta(i+2))
2719 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2723 C Compute the derivatives of uz
2725 uzder(2,1,1)=-dc_norm(3,i+1)
2726 uzder(3,1,1)= dc_norm(2,i+1)
2727 uzder(1,2,1)= dc_norm(3,i+1)
2729 uzder(3,2,1)=-dc_norm(1,i+1)
2730 uzder(1,3,1)=-dc_norm(2,i+1)
2731 uzder(2,3,1)= dc_norm(1,i+1)
2734 uzder(2,1,2)= dc_norm(3,i)
2735 uzder(3,1,2)=-dc_norm(2,i)
2736 uzder(1,2,2)=-dc_norm(3,i)
2738 uzder(3,2,2)= dc_norm(1,i)
2739 uzder(1,3,2)= dc_norm(2,i)
2740 uzder(2,3,2)=-dc_norm(1,i)
2742 C Compute the Y-axis
2745 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2747 C Compute the derivatives of uy
2750 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2751 & -dc_norm(k,i)*dc_norm(j,i+1)
2752 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2754 uyder(j,j,1)=uyder(j,j,1)-costh
2755 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2760 uygrad(l,k,j,i)=uyder(l,k,j)
2761 uzgrad(l,k,j,i)=uzder(l,k,j)
2765 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2766 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2767 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2768 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2772 vbld_inv_temp(1)=vbld_inv(i+1)
2773 if (i.lt.nres-1) then
2774 vbld_inv_temp(2)=vbld_inv(i+2)
2776 vbld_inv_temp(2)=vbld_inv(i)
2781 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2782 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2787 #if defined(PARVEC) && defined(MPI)
2788 if (nfgtasks1.gt.1) then
2790 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2791 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2792 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2793 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2794 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2796 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2797 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2799 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2800 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2801 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2802 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2803 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2804 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2805 time_gather=time_gather+MPI_Wtime()-time00
2809 if (fg_rank.eq.0) then
2810 write (iout,*) "Arrays UY and UZ"
2812 write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2819 C--------------------------------------------------------------------------
2820 subroutine set_matrices
2821 implicit real*8 (a-h,o-z)
2822 include 'DIMENSIONS'
2825 include "COMMON.SETUP"
2827 integer status(MPI_STATUS_SIZE)
2829 include 'COMMON.IOUNITS'
2830 include 'COMMON.GEO'
2831 include 'COMMON.VAR'
2832 include 'COMMON.LOCAL'
2833 include 'COMMON.CHAIN'
2834 include 'COMMON.DERIV'
2835 include 'COMMON.INTERACT'
2836 include 'COMMON.CORRMAT'
2837 include 'COMMON.TORSION'
2838 include 'COMMON.VECTORS'
2839 include 'COMMON.FFIELD'
2840 double precision auxvec(2),auxmat(2,2)
2842 C Compute the virtual-bond-torsional-angle dependent quantities needed
2843 C to calculate the el-loc multibody terms of various order.
2845 c write(iout,*) 'nphi=',nphi,nres
2846 c write(iout,*) "itype2loc",itype2loc
2848 do i=ivec_start+2,ivec_end+2
2853 c write (iout,*) "i",i,i-2," ii",ii
2855 innt=chain_border(1,ii)
2856 inct=chain_border(2,ii)
2857 c write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2858 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
2859 if (i.gt. innt+2 .and. i.lt.inct+2) then
2860 iti = itype2loc(itype(i-2))
2864 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2865 if (i.gt. innt+1 .and. i.lt.inct+1) then
2866 iti1 = itype2loc(itype(i-1))
2870 c write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
2871 c & " iti1",itype(i-1),iti1
2873 cost1=dcos(theta(i-1))
2874 sint1=dsin(theta(i-1))
2876 sint1cub=sint1sq*sint1
2877 sint1cost1=2*sint1*cost1
2878 c write (iout,*) "bnew1",i,iti
2879 c write (iout,*) (bnew1(k,1,iti),k=1,3)
2880 c write (iout,*) (bnew1(k,2,iti),k=1,3)
2881 c write (iout,*) "bnew2",i,iti
2882 c write (iout,*) (bnew2(k,1,iti),k=1,3)
2883 c write (iout,*) (bnew2(k,2,iti),k=1,3)
2885 b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2887 gtb1(k,i-2)=cost1*b1k-sint1sq*
2888 & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2889 b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2891 gtb2(k,i-2)=cost1*b2k-sint1sq*
2892 & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2895 aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2896 cc(1,k,i-2)=sint1sq*aux
2897 gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2898 & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2899 aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2900 dd(1,k,i-2)=sint1sq*aux
2901 gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2902 & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2904 cc(2,1,i-2)=cc(1,2,i-2)
2905 cc(2,2,i-2)=-cc(1,1,i-2)
2906 gtcc(2,1,i-2)=gtcc(1,2,i-2)
2907 gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2908 dd(2,1,i-2)=dd(1,2,i-2)
2909 dd(2,2,i-2)=-dd(1,1,i-2)
2910 gtdd(2,1,i-2)=gtdd(1,2,i-2)
2911 gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2914 aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2915 EE(l,k,i-2)=sint1sq*aux
2916 gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2919 EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2920 EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2921 EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2922 EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2923 gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2924 gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2925 gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2926 c b1tilde(1,i-2)=b1(1,i-2)
2927 c b1tilde(2,i-2)=-b1(2,i-2)
2928 c b2tilde(1,i-2)=b2(1,i-2)
2929 c b2tilde(2,i-2)=-b2(2,i-2)
2931 write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2932 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
2933 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
2934 write (iout,*) 'theta=', theta(i-1)
2937 if (i.gt. innt+2 .and. i.lt.inct+2) then
2938 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
2939 iti = itype2loc(itype(i-2))
2943 c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2944 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2945 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2946 iti1 = itype2loc(itype(i-1))
2956 CC(k,l,i-2)=ccold(k,l,iti)
2957 DD(k,l,i-2)=ddold(k,l,iti)
2958 EE(k,l,i-2)=eeold(k,l,iti)
2963 b1tilde(1,i-2)= b1(1,i-2)
2964 b1tilde(2,i-2)=-b1(2,i-2)
2965 b2tilde(1,i-2)= b2(1,i-2)
2966 b2tilde(2,i-2)=-b2(2,i-2)
2968 Ctilde(1,1,i-2)= CC(1,1,i-2)
2969 Ctilde(1,2,i-2)= CC(1,2,i-2)
2970 Ctilde(2,1,i-2)=-CC(2,1,i-2)
2971 Ctilde(2,2,i-2)=-CC(2,2,i-2)
2973 Dtilde(1,1,i-2)= DD(1,1,i-2)
2974 Dtilde(1,2,i-2)= DD(1,2,i-2)
2975 Dtilde(2,1,i-2)=-DD(2,1,i-2)
2976 Dtilde(2,2,i-2)=-DD(2,2,i-2)
2978 write(iout,*) "i",i," iti",iti
2979 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
2980 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
2985 do i=ivec_start+2,ivec_end+2
2989 c if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
2990 if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3028 obrot_der(1,i-2)=-sin1
3029 obrot_der(2,i-2)= cos1
3030 Ugder(1,1,i-2)= sin1
3031 Ugder(1,2,i-2)=-cos1
3032 Ugder(2,1,i-2)=-cos1
3033 Ugder(2,2,i-2)=-sin1
3036 obrot2_der(1,i-2)=-dwasin2
3037 obrot2_der(2,i-2)= dwacos2
3038 Ug2der(1,1,i-2)= dwasin2
3039 Ug2der(1,2,i-2)=-dwacos2
3040 Ug2der(2,1,i-2)=-dwacos2
3041 Ug2der(2,2,i-2)=-dwasin2
3043 obrot_der(1,i-2)=0.0d0
3044 obrot_der(2,i-2)=0.0d0
3045 Ugder(1,1,i-2)=0.0d0
3046 Ugder(1,2,i-2)=0.0d0
3047 Ugder(2,1,i-2)=0.0d0
3048 Ugder(2,2,i-2)=0.0d0
3049 obrot2_der(1,i-2)=0.0d0
3050 obrot2_der(2,i-2)=0.0d0
3051 Ug2der(1,1,i-2)=0.0d0
3052 Ug2der(1,2,i-2)=0.0d0
3053 Ug2der(2,1,i-2)=0.0d0
3054 Ug2der(2,2,i-2)=0.0d0
3056 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3057 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3058 if (i.gt.nnt+2 .and.i.lt.nct+2) then
3059 iti = itype2loc(itype(i-2))
3063 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3064 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3065 iti1 = itype2loc(itype(i-1))
3069 cd write (iout,*) '*******i',i,' iti1',iti
3070 cd write (iout,*) 'b1',b1(:,iti)
3071 cd write (iout,*) 'b2',b2(:,iti)
3072 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3073 c if (i .gt. iatel_s+2) then
3074 if (i .gt. nnt+2) then
3075 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3077 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3078 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3080 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3081 c & EE(1,2,iti),EE(2,2,i)
3082 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3083 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3084 c write(iout,*) "Macierz EUG",
3085 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3088 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3090 call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3091 call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3092 call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3093 call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3094 call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3106 DtUg2(l,k,i-2)=0.0d0
3110 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3111 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3113 muder(k,i-2)=Ub2der(k,i-2)
3115 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3116 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3117 if (itype(i-1).le.ntyp) then
3118 iti1 = itype2loc(itype(i-1))
3126 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3127 c mu(k,i-2)=b1(k,i-1)
3128 c mu(k,i-2)=Ub2(k,i-2)
3131 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3132 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3133 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3134 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3135 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3136 & ((ee(l,k,i-2),l=1,2),k=1,2)
3138 cd write (iout,*) 'mu1',mu1(:,i-2)
3139 cd write (iout,*) 'mu2',mu2(:,i-2)
3140 cd write (iout,*) 'mu',i-2,mu(:,i-2)
3142 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3144 call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3145 call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3146 call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3147 call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3148 call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3149 C Vectors and matrices dependent on a single virtual-bond dihedral.
3150 call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3151 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3152 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3153 call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3154 call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3155 call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3156 call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3157 call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3158 call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3163 C Matrices dependent on two consecutive virtual-bond dihedrals.
3164 C The order of matrices is from left to right.
3165 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3167 c do i=max0(ivec_start,2),ivec_end
3169 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3170 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3171 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3172 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3173 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3174 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3175 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3176 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3180 #if defined(MPI) && defined(PARMAT)
3182 c if (fg_rank.eq.0) then
3183 write (iout,*) "Arrays UG and UGDER before GATHER"
3185 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3186 & ((ug(l,k,i),l=1,2),k=1,2),
3187 & ((ugder(l,k,i),l=1,2),k=1,2)
3189 write (iout,*) "Arrays UG2 and UG2DER"
3191 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3192 & ((ug2(l,k,i),l=1,2),k=1,2),
3193 & ((ug2der(l,k,i),l=1,2),k=1,2)
3195 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3197 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3198 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3199 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3201 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3203 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3204 & costab(i),sintab(i),costab2(i),sintab2(i)
3206 write (iout,*) "Array MUDER"
3208 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3212 if (nfgtasks.gt.1) then
3214 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3215 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3216 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3218 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3219 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3221 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3222 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3224 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3225 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3227 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3228 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3230 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3231 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3233 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3234 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3236 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3237 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3238 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3239 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3240 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3241 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3242 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3243 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3244 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3245 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3246 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3247 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3249 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3251 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3252 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3254 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3255 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3257 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3258 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3260 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3261 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3263 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3264 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3266 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3267 & ivec_count(fg_rank1),
3268 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3270 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3271 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3273 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3274 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3276 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3277 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3279 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3280 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3282 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3283 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3285 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3286 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3288 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3289 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3291 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3292 & ivec_count(fg_rank1),
3293 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3295 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3296 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3298 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3299 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3301 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3302 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3304 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3305 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3307 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3308 & ivec_count(fg_rank1),
3309 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3311 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3312 & ivec_count(fg_rank1),
3313 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3315 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3316 & ivec_count(fg_rank1),
3317 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3318 & MPI_MAT2,FG_COMM1,IERR)
3319 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3320 & ivec_count(fg_rank1),
3321 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3322 & MPI_MAT2,FG_COMM1,IERR)
3326 c Passes matrix info through the ring
3329 if (irecv.lt.0) irecv=nfgtasks1-1
3332 if (inext.ge.nfgtasks1) inext=0
3334 c write (iout,*) "isend",isend," irecv",irecv
3336 lensend=lentyp(isend)
3337 lenrecv=lentyp(irecv)
3338 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3339 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3340 c & MPI_ROTAT1(lensend),inext,2200+isend,
3341 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3342 c & iprev,2200+irecv,FG_COMM,status,IERR)
3343 c write (iout,*) "Gather ROTAT1"
3345 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3346 c & MPI_ROTAT2(lensend),inext,3300+isend,
3347 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3348 c & iprev,3300+irecv,FG_COMM,status,IERR)
3349 c write (iout,*) "Gather ROTAT2"
3351 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3352 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3353 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3354 & iprev,4400+irecv,FG_COMM,status,IERR)
3355 c write (iout,*) "Gather ROTAT_OLD"
3357 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3358 & MPI_PRECOMP11(lensend),inext,5500+isend,
3359 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3360 & iprev,5500+irecv,FG_COMM,status,IERR)
3361 c write (iout,*) "Gather PRECOMP11"
3363 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3364 & MPI_PRECOMP12(lensend),inext,6600+isend,
3365 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3366 & iprev,6600+irecv,FG_COMM,status,IERR)
3367 c write (iout,*) "Gather PRECOMP12"
3370 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3372 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3373 & MPI_ROTAT2(lensend),inext,7700+isend,
3374 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3375 & iprev,7700+irecv,FG_COMM,status,IERR)
3376 c write (iout,*) "Gather PRECOMP21"
3378 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3379 & MPI_PRECOMP22(lensend),inext,8800+isend,
3380 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3381 & iprev,8800+irecv,FG_COMM,status,IERR)
3382 c write (iout,*) "Gather PRECOMP22"
3384 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3385 & MPI_PRECOMP23(lensend),inext,9900+isend,
3386 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3387 & MPI_PRECOMP23(lenrecv),
3388 & iprev,9900+irecv,FG_COMM,status,IERR)
3390 c write (iout,*) "Gather PRECOMP23"
3395 if (irecv.lt.0) irecv=nfgtasks1-1
3398 time_gather=time_gather+MPI_Wtime()-time00
3401 c if (fg_rank.eq.0) then
3402 write (iout,*) "Arrays UG and UGDER"
3404 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3405 & ((ug(l,k,i),l=1,2),k=1,2),
3406 & ((ugder(l,k,i),l=1,2),k=1,2)
3408 write (iout,*) "Arrays UG2 and UG2DER"
3410 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3411 & ((ug2(l,k,i),l=1,2),k=1,2),
3412 & ((ug2der(l,k,i),l=1,2),k=1,2)
3414 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3416 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3417 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3418 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3420 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3422 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3423 & costab(i),sintab(i),costab2(i),sintab2(i)
3425 write (iout,*) "Array MUDER"
3427 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3433 cd iti = itype2loc(itype(i))
3436 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3437 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3442 C-----------------------------------------------------------------------------
3443 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3445 C This subroutine calculates the average interaction energy and its gradient
3446 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3447 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3448 C The potential depends both on the distance of peptide-group centers and on
3449 C the orientation of the CA-CA virtual bonds.
3451 implicit real*8 (a-h,o-z)
3455 include 'DIMENSIONS'
3456 include 'COMMON.CONTROL'
3457 include 'COMMON.SETUP'
3458 include 'COMMON.IOUNITS'
3459 include 'COMMON.GEO'
3460 include 'COMMON.VAR'
3461 include 'COMMON.LOCAL'
3462 include 'COMMON.CHAIN'
3463 include 'COMMON.DERIV'
3464 include 'COMMON.INTERACT'
3466 include 'COMMON.CONTACTS'
3467 include 'COMMON.CONTMAT'
3469 include 'COMMON.CORRMAT'
3470 include 'COMMON.TORSION'
3471 include 'COMMON.VECTORS'
3472 include 'COMMON.FFIELD'
3473 include 'COMMON.TIME1'
3474 include 'COMMON.SPLITELE'
3475 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3476 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3477 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3478 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3479 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3480 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3482 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3484 double precision scal_el /1.0d0/
3486 double precision scal_el /0.5d0/
3489 C 13-go grudnia roku pamietnego...
3490 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3491 & 0.0d0,1.0d0,0.0d0,
3492 & 0.0d0,0.0d0,1.0d0/
3493 cd write(iout,*) 'In EELEC'
3495 cd write(iout,*) 'Type',i
3496 cd write(iout,*) 'B1',B1(:,i)
3497 cd write(iout,*) 'B2',B2(:,i)
3498 cd write(iout,*) 'CC',CC(:,:,i)
3499 cd write(iout,*) 'DD',DD(:,:,i)
3500 cd write(iout,*) 'EE',EE(:,:,i)
3502 cd call check_vecgrad
3504 if (icheckgrad.eq.1) then
3506 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3508 dc_norm(k,i)=dc(k,i)*fac
3510 c write (iout,*) 'i',i,' fac',fac
3513 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3514 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3515 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3516 c call vec_and_deriv
3522 time_mat=time_mat+MPI_Wtime()-time01
3526 cd write (iout,*) 'i=',i
3528 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3531 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3532 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3547 cd print '(a)','Enter EELEC'
3548 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3550 gel_loc_loc(i)=0.0d0
3555 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3557 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3559 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3560 do i=iturn3_start,iturn3_end
3562 C write(iout,*) "tu jest i",i
3563 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3564 C changes suggested by Ana to avoid out of bounds
3565 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3566 c & .or.((i+4).gt.nres)
3567 c & .or.((i-1).le.0)
3568 C end of changes by Ana
3569 & .or. itype(i+2).eq.ntyp1
3570 & .or. itype(i+3).eq.ntyp1) cycle
3571 C Adam: Instructions below will switch off existing interactions
3573 c if(itype(i-1).eq.ntyp1)cycle
3575 c if(i.LT.nres-3)then
3576 c if (itype(i+4).eq.ntyp1) cycle
3581 dx_normi=dc_norm(1,i)
3582 dy_normi=dc_norm(2,i)
3583 dz_normi=dc_norm(3,i)
3584 xmedi=c(1,i)+0.5d0*dxi
3585 ymedi=c(2,i)+0.5d0*dyi
3586 zmedi=c(3,i)+0.5d0*dzi
3587 call to_box(xmedi,ymedi,zmedi)
3589 call eelecij(i,i+2,ees,evdw1,eel_loc)
3590 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3592 num_cont_hb(i)=num_conti
3595 do i=iturn4_start,iturn4_end
3597 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3598 C changes suggested by Ana to avoid out of bounds
3599 c & .or.((i+5).gt.nres)
3600 c & .or.((i-1).le.0)
3601 C end of changes suggested by Ana
3602 & .or. itype(i+3).eq.ntyp1
3603 & .or. itype(i+4).eq.ntyp1
3604 c & .or. itype(i+5).eq.ntyp1
3605 c & .or. itype(i).eq.ntyp1
3606 c & .or. itype(i-1).eq.ntyp1
3611 dx_normi=dc_norm(1,i)
3612 dy_normi=dc_norm(2,i)
3613 dz_normi=dc_norm(3,i)
3614 xmedi=c(1,i)+0.5d0*dxi
3615 ymedi=c(2,i)+0.5d0*dyi
3616 zmedi=c(3,i)+0.5d0*dzi
3617 C Return atom into box, boxxsize is size of box in x dimension
3619 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3620 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3621 C Condition for being inside the proper box
3622 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3623 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3627 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3628 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3629 C Condition for being inside the proper box
3630 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3631 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3635 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3636 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3637 C Condition for being inside the proper box
3638 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3639 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3642 call to_box(xmedi,ymedi,zmedi)
3644 num_conti=num_cont_hb(i)
3646 c write(iout,*) "JESTEM W PETLI"
3647 call eelecij(i,i+3,ees,evdw1,eel_loc)
3648 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3649 & call eturn4(i,eello_turn4)
3651 num_cont_hb(i)=num_conti
3654 C Loop over all neighbouring boxes
3659 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3662 c do i=iatel_s,iatel_e
3663 do ikont=g_listpp_start,g_listpp_end
3664 i=newcontlistppi(ikont)
3665 j=newcontlistppj(ikont)
3668 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3669 C changes suggested by Ana to avoid out of bounds
3670 c & .or.((i+2).gt.nres)
3671 c & .or.((i-1).le.0)
3672 C end of changes by Ana
3673 c & .or. itype(i+2).eq.ntyp1
3674 c & .or. itype(i-1).eq.ntyp1
3679 dx_normi=dc_norm(1,i)
3680 dy_normi=dc_norm(2,i)
3681 dz_normi=dc_norm(3,i)
3682 xmedi=c(1,i)+0.5d0*dxi
3683 ymedi=c(2,i)+0.5d0*dyi
3684 zmedi=c(3,i)+0.5d0*dzi
3685 call to_box(xmedi,ymedi,zmedi)
3686 C xmedi=xmedi+xshift*boxxsize
3687 C ymedi=ymedi+yshift*boxysize
3688 C zmedi=zmedi+zshift*boxzsize
3690 C Return tom into box, boxxsize is size of box in x dimension
3692 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3693 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3694 C Condition for being inside the proper box
3695 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3696 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3700 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3701 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3702 C Condition for being inside the proper box
3703 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3704 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3708 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3709 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3710 cC Condition for being inside the proper box
3711 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3712 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3716 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3718 num_conti=num_cont_hb(i)
3721 c do j=ielstart(i),ielend(i)
3723 C write (iout,*) i,j
3725 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3726 C changes suggested by Ana to avoid out of bounds
3727 c & .or.((j+2).gt.nres)
3728 c & .or.((j-1).le.0)
3729 C end of changes by Ana
3730 c & .or.itype(j+2).eq.ntyp1
3731 c & .or.itype(j-1).eq.ntyp1
3733 call eelecij(i,j,ees,evdw1,eel_loc)
3736 num_cont_hb(i)=num_conti
3743 c write (iout,*) "Number of loop steps in EELEC:",ind
3745 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3746 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3748 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3749 ccc eel_loc=eel_loc+eello_turn3
3750 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3753 C-------------------------------------------------------------------------------
3754 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3756 include 'DIMENSIONS'
3760 include 'COMMON.CONTROL'
3761 include 'COMMON.IOUNITS'
3762 include 'COMMON.GEO'
3763 include 'COMMON.VAR'
3764 include 'COMMON.LOCAL'
3765 include 'COMMON.CHAIN'
3766 include 'COMMON.DERIV'
3767 include 'COMMON.INTERACT'
3769 include 'COMMON.CONTACTS'
3770 include 'COMMON.CONTMAT'
3772 include 'COMMON.CORRMAT'
3773 include 'COMMON.TORSION'
3774 include 'COMMON.VECTORS'
3775 include 'COMMON.FFIELD'
3776 include 'COMMON.TIME1'
3777 include 'COMMON.SPLITELE'
3778 include 'COMMON.SHIELD'
3779 double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3780 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3781 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3782 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3783 & gmuij2(4),gmuji2(4)
3784 double precision dxi,dyi,dzi
3785 double precision dx_normi,dy_normi,dz_normi,aux
3786 integer j1,j2,lll,num_conti
3787 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3788 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3790 integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3791 double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3792 double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3793 double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3794 & rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3795 & evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3796 & ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3797 & a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3798 & ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3799 & ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3800 & ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3801 double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3802 double precision xmedi,ymedi,zmedi
3803 double precision sscale,sscagrad,scalar
3804 double precision boxshift
3805 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3807 double precision scal_el /1.0d0/
3809 double precision scal_el /0.5d0/
3812 C 13-go grudnia roku pamietnego...
3813 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3814 & 0.0d0,1.0d0,0.0d0,
3815 & 0.0d0,0.0d0,1.0d0/
3816 c time00=MPI_Wtime()
3817 cd write (iout,*) "eelecij",i,j
3821 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3822 aaa=app(iteli,itelj)
3823 bbb=bpp(iteli,itelj)
3824 ael6i=ael6(iteli,itelj)
3825 ael3i=ael3(iteli,itelj)
3829 dx_normj=dc_norm(1,j)
3830 dy_normj=dc_norm(2,j)
3831 dz_normj=dc_norm(3,j)
3832 C xj=c(1,j)+0.5D0*dxj-xmedi
3833 C yj=c(2,j)+0.5D0*dyj-ymedi
3834 C zj=c(3,j)+0.5D0*dzj-zmedi
3838 call to_box(xj,yj,zj)
3839 xj=boxshift(xj-xmedi,boxxsize)
3840 yj=boxshift(yj-ymedi,boxysize)
3841 zj=boxshift(zj-zmedi,boxzsize)
3842 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3844 rij=xj*xj+yj*yj+zj*zj
3846 sss=sscale(dsqrt(rij),r_cut_int)
3847 if (sss.eq.0.0d0) return
3848 sssgrad=sscagrad(dsqrt(rij),r_cut_int)
3849 c if (sss.gt.0.0d0) then
3855 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3856 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3857 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3858 fac=cosa-3.0D0*cosb*cosg
3860 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3861 if (j.eq.i+2) ev1=scal_el*ev1
3866 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3870 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3871 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3872 if (shield_mode.gt.0) then
3875 el1=el1*fac_shield(i)**2*fac_shield(j)**2
3876 el2=el2*fac_shield(i)**2*fac_shield(j)**2
3885 evdw1=evdw1+evdwij*sss
3886 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3887 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3888 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
3889 cd & xmedi,ymedi,zmedi,xj,yj,zj
3891 if (energy_dec) then
3892 write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
3893 & 'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
3894 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3895 & fac_shield(i),fac_shield(j)
3899 C Calculate contributions to the Cartesian gradient.
3902 facvdw=-6*rrmij*(ev1+evdwij)*sss
3903 facel=-3*rrmij*(el1+eesij)
3910 * Radial derivatives. First process both termini of the fragment (i,j)
3912 aux=facel*sss+rmij*sssgrad*eesij
3916 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3917 & (shield_mode.gt.0)) then
3919 do ilist=1,ishield_list(i)
3920 iresshield=shield_list(ilist,i)
3922 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3924 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3926 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3927 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3928 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3929 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3930 C if (iresshield.gt.i) then
3931 C do ishi=i+1,iresshield-1
3932 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3933 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3937 C do ishi=iresshield,i
3938 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3939 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3945 do ilist=1,ishield_list(j)
3946 iresshield=shield_list(ilist,j)
3948 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3950 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3952 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
3953 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3955 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3956 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3957 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3958 C if (iresshield.gt.j) then
3959 C do ishi=j+1,iresshield-1
3960 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3961 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3965 C do ishi=iresshield,j
3966 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3967 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3974 gshieldc(k,i)=gshieldc(k,i)+
3975 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3976 gshieldc(k,j)=gshieldc(k,j)+
3977 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3978 gshieldc(k,i-1)=gshieldc(k,i-1)+
3979 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
3980 gshieldc(k,j-1)=gshieldc(k,j-1)+
3981 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
3986 c ghalf=0.5D0*ggg(k)
3987 c gelc(k,i)=gelc(k,i)+ghalf
3988 c gelc(k,j)=gelc(k,j)+ghalf
3990 c 9/28/08 AL Gradient compotents will be summed only at the end
3991 C print *,"before", gelc_long(1,i), gelc_long(1,j)
3993 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3994 C & +grad_shield(k,j)*eesij/fac_shield(j)
3995 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3996 C & +grad_shield(k,i)*eesij/fac_shield(i)
3997 C gelc_long(k,i-1)=gelc_long(k,i-1)
3998 C & +grad_shield(k,i)*eesij/fac_shield(i)
3999 C gelc_long(k,j-1)=gelc_long(k,j-1)
4000 C & +grad_shield(k,j)*eesij/fac_shield(j)
4002 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4005 * Loop over residues i+1 thru j-1.
4009 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4012 facvdw=facvdw+sssgrad*rmij*evdwij
4017 c ghalf=0.5D0*ggg(k)
4018 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4019 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4021 c 9/28/08 AL Gradient compotents will be summed only at the end
4023 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4024 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4027 * Loop over residues i+1 thru j-1.
4031 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4039 fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4040 & +(evdwij+eesij)*sssgrad*rrmij
4045 * Radial derivatives. First process both termini of the fragment (i,j)
4048 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4050 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4052 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4054 c ghalf=0.5D0*ggg(k)
4055 c gelc(k,i)=gelc(k,i)+ghalf
4056 c gelc(k,j)=gelc(k,j)+ghalf
4058 c 9/28/08 AL Gradient compotents will be summed only at the end
4060 gelc_long(k,j)=gelc(k,j)+ggg(k)
4061 gelc_long(k,i)=gelc(k,i)-ggg(k)
4064 * Loop over residues i+1 thru j-1.
4068 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4071 c 9/28/08 AL Gradient compotents will be summed only at the end
4072 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4073 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4074 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4076 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4077 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4083 ecosa=2.0D0*fac3*fac1+fac4
4086 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4087 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4089 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4090 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4092 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4093 cd & (dcosg(k),k=1,3)
4095 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4096 & fac_shield(i)**2*fac_shield(j)**2*sss
4099 c ghalf=0.5D0*ggg(k)
4100 c gelc(k,i)=gelc(k,i)+ghalf
4101 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4102 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4103 c gelc(k,j)=gelc(k,j)+ghalf
4104 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4105 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4109 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4112 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4115 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4116 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4117 & *fac_shield(i)**2*fac_shield(j)**2
4119 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4120 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4121 & *fac_shield(i)**2*fac_shield(j)**2
4122 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4123 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4125 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4129 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4130 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4131 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4133 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4134 C energy of a peptide unit is assumed in the form of a second-order
4135 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4136 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4137 C are computed for EVERY pair of non-contiguous peptide groups.
4140 if (j.lt.nres-1) then
4152 muij(kkk)=mu(k,i)*mu(l,j)
4153 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4155 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4156 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4157 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4158 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4159 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4160 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4165 write (iout,*) 'EELEC: i',i,' j',j
4166 write (iout,*) 'j',j,' j1',j1,' j2',j2
4167 write(iout,*) 'muij',muij
4169 ury=scalar(uy(1,i),erij)
4170 urz=scalar(uz(1,i),erij)
4171 vry=scalar(uy(1,j),erij)
4172 vrz=scalar(uz(1,j),erij)
4173 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4174 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4175 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4176 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4177 fac=dsqrt(-ael6i)*r3ij
4179 write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4180 write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4181 & "uyvz",scalar(uy(1,i),uz(1,j)),
4182 & "uzvy",scalar(uz(1,i),uy(1,j)),
4183 & "uzvz",scalar(uz(1,i),uz(1,j))
4184 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4185 write (iout,*) "fac",fac
4192 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4195 cd write (iout,'(4i5,4f10.5)')
4196 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4197 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4198 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4199 cd & uy(:,j),uz(:,j)
4200 cd write (iout,'(4f10.5)')
4201 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4202 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4203 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4204 cd write (iout,'(9f10.5/)')
4205 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4206 C Derivatives of the elements of A in virtual-bond vectors
4207 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4209 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4210 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4211 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4212 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4213 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4214 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4215 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4216 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4217 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4218 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4219 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4220 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4222 C Compute radial contributions to the gradient
4240 C Add the contributions coming from er
4243 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4244 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4245 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4246 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4249 C Derivatives in DC(i)
4250 cgrad ghalf1=0.5d0*agg(k,1)
4251 cgrad ghalf2=0.5d0*agg(k,2)
4252 cgrad ghalf3=0.5d0*agg(k,3)
4253 cgrad ghalf4=0.5d0*agg(k,4)
4254 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4255 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4256 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4257 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4258 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4259 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4260 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4261 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4262 C Derivatives in DC(i+1)
4263 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4264 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4265 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4266 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4267 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4268 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4269 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4270 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4271 C Derivatives in DC(j)
4272 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4273 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4274 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4275 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4276 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4277 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4278 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4279 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4280 C Derivatives in DC(j+1) or DC(nres-1)
4281 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4282 & -3.0d0*vryg(k,3)*ury)
4283 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4284 & -3.0d0*vrzg(k,3)*ury)
4285 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4286 & -3.0d0*vryg(k,3)*urz)
4287 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4288 & -3.0d0*vrzg(k,3)*urz)
4289 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4291 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4304 aggi(k,l)=-aggi(k,l)
4305 aggi1(k,l)=-aggi1(k,l)
4306 aggj(k,l)=-aggj(k,l)
4307 aggj1(k,l)=-aggj1(k,l)
4310 if (j.lt.nres-1) then
4316 aggi(k,l)=-aggi(k,l)
4317 aggi1(k,l)=-aggi1(k,l)
4318 aggj(k,l)=-aggj(k,l)
4319 aggj1(k,l)=-aggj1(k,l)
4330 aggi(k,l)=-aggi(k,l)
4331 aggi1(k,l)=-aggi1(k,l)
4332 aggj(k,l)=-aggj(k,l)
4333 aggj1(k,l)=-aggj1(k,l)
4338 IF (wel_loc.gt.0.0d0) THEN
4339 C Contribution to the local-electrostatic energy coming from the i-j pair
4340 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4343 write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4345 write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4346 & " wel_loc",wel_loc
4348 if (shield_mode.eq.0) then
4355 eel_loc_ij=eel_loc_ij
4356 & *fac_shield(i)*fac_shield(j)*sss
4357 c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4358 c & 'eelloc',i,j,eel_loc_ij
4359 C Now derivative over eel_loc
4360 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4361 & (shield_mode.gt.0)) then
4364 do ilist=1,ishield_list(i)
4365 iresshield=shield_list(ilist,i)
4367 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4370 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4372 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4373 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4377 do ilist=1,ishield_list(j)
4378 iresshield=shield_list(ilist,j)
4380 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4383 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4385 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4386 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4393 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4394 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4395 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4396 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4397 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4398 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4399 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4400 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4405 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4406 c & ' eel_loc_ij',eel_loc_ij
4407 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4408 C Calculate patrial derivative for theta angle
4410 geel_loc_ij=(a22*gmuij1(1)
4414 & *fac_shield(i)*fac_shield(j)*sss
4415 c write(iout,*) "derivative over thatai"
4416 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4418 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4419 & geel_loc_ij*wel_loc
4420 c write(iout,*) "derivative over thatai-1"
4421 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4428 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4429 & geel_loc_ij*wel_loc
4430 & *fac_shield(i)*fac_shield(j)*sss
4432 c Derivative over j residue
4433 geel_loc_ji=a22*gmuji1(1)
4437 c write(iout,*) "derivative over thataj"
4438 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4441 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4442 & geel_loc_ji*wel_loc
4443 & *fac_shield(i)*fac_shield(j)*sss
4450 c write(iout,*) "derivative over thataj-1"
4451 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4453 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4454 & geel_loc_ji*wel_loc
4455 & *fac_shield(i)*fac_shield(j)*sss
4457 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4459 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4460 & 'eelloc',i,j,eel_loc_ij
4461 c if (eel_loc_ij.ne.0)
4462 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4463 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4465 eel_loc=eel_loc+eel_loc_ij
4466 C Partial derivatives in virtual-bond dihedral angles gamma
4468 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4469 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4470 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4471 & *fac_shield(i)*fac_shield(j)*sss
4473 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4474 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4475 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4476 & *fac_shield(i)*fac_shield(j)*sss
4477 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4478 aux=eel_loc_ij/sss*sssgrad*rmij
4483 ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4484 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4485 & *fac_shield(i)*fac_shield(j)*sss
4486 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4487 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4488 cgrad ghalf=0.5d0*ggg(l)
4489 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4490 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4494 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4497 C Remaining derivatives of eello
4499 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4500 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4501 & *fac_shield(i)*fac_shield(j)*sss
4503 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4504 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4505 & *fac_shield(i)*fac_shield(j)*sss
4507 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4508 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4509 & *fac_shield(i)*fac_shield(j)*sss
4511 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4512 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4513 & *fac_shield(i)*fac_shield(j)*sss
4517 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4518 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4520 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4521 & .and. num_conti.le.maxconts) then
4522 c write (iout,*) i,j," entered corr"
4524 C Calculate the contact function. The ith column of the array JCONT will
4525 C contain the numbers of atoms that make contacts with the atom I (of numbers
4526 C greater than I). The arrays FACONT and GACONT will contain the values of
4527 C the contact function and its derivative.
4528 c r0ij=1.02D0*rpp(iteli,itelj)
4529 c r0ij=1.11D0*rpp(iteli,itelj)
4530 r0ij=2.20D0*rpp(iteli,itelj)
4531 c r0ij=1.55D0*rpp(iteli,itelj)
4532 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4533 if (fcont.gt.0.0D0) then
4534 num_conti=num_conti+1
4535 if (num_conti.gt.maxconts) then
4536 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4537 & ' will skip next contacts for this conf.'
4539 jcont_hb(num_conti,i)=j
4540 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4541 cd & " jcont_hb",jcont_hb(num_conti,i)
4542 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4543 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4544 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4546 d_cont(num_conti,i)=rij
4547 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4548 C --- Electrostatic-interaction matrix ---
4549 a_chuj(1,1,num_conti,i)=a22
4550 a_chuj(1,2,num_conti,i)=a23
4551 a_chuj(2,1,num_conti,i)=a32
4552 a_chuj(2,2,num_conti,i)=a33
4553 C --- Gradient of rij
4555 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4562 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4563 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4564 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4565 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4566 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4571 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4572 C Calculate contact energies
4574 wij=cosa-3.0D0*cosb*cosg
4577 c fac3=dsqrt(-ael6i)/r0ij**3
4578 fac3=dsqrt(-ael6i)*r3ij
4579 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4580 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4581 if (ees0tmp.gt.0) then
4582 ees0pij=dsqrt(ees0tmp)
4586 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4587 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4588 if (ees0tmp.gt.0) then
4589 ees0mij=dsqrt(ees0tmp)
4594 if (shield_mode.eq.0) then
4598 ees0plist(num_conti,i)=j
4599 C fac_shield(i)=0.4d0
4600 C fac_shield(j)=0.6d0
4602 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4603 & *fac_shield(i)*fac_shield(j)*sss
4604 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4605 & *fac_shield(i)*fac_shield(j)*sss
4606 C Diagnostics. Comment out or remove after debugging!
4607 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4608 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4609 c ees0m(num_conti,i)=0.0D0
4611 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4612 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4613 C Angular derivatives of the contact function
4614 ees0pij1=fac3/ees0pij
4615 ees0mij1=fac3/ees0mij
4616 fac3p=-3.0D0*fac3*rrmij
4617 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4618 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4620 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4621 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4622 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4623 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4624 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4625 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4626 ecosap=ecosa1+ecosa2
4627 ecosbp=ecosb1+ecosb2
4628 ecosgp=ecosg1+ecosg2
4629 ecosam=ecosa1-ecosa2
4630 ecosbm=ecosb1-ecosb2
4631 ecosgm=ecosg1-ecosg2
4640 facont_hb(num_conti,i)=fcont
4641 fprimcont=fprimcont/rij
4642 cd facont_hb(num_conti,i)=1.0D0
4643 C Following line is for diagnostics.
4646 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4647 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4650 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4651 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4653 gggp(1)=gggp(1)+ees0pijp*xj
4654 & +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4655 gggp(2)=gggp(2)+ees0pijp*yj
4656 & +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4657 gggp(3)=gggp(3)+ees0pijp*zj
4658 & +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4659 gggm(1)=gggm(1)+ees0mijp*xj
4660 & +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4661 gggm(2)=gggm(2)+ees0mijp*yj
4662 & +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4663 gggm(3)=gggm(3)+ees0mijp*zj
4664 & +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4665 C Derivatives due to the contact function
4666 gacont_hbr(1,num_conti,i)=fprimcont*xj
4667 gacont_hbr(2,num_conti,i)=fprimcont*yj
4668 gacont_hbr(3,num_conti,i)=fprimcont*zj
4671 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4672 c following the change of gradient-summation algorithm.
4674 cgrad ghalfp=0.5D0*gggp(k)
4675 cgrad ghalfm=0.5D0*gggm(k)
4676 gacontp_hb1(k,num_conti,i)=!ghalfp
4677 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4678 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4679 & *fac_shield(i)*fac_shield(j)*sss
4681 gacontp_hb2(k,num_conti,i)=!ghalfp
4682 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4683 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4684 & *fac_shield(i)*fac_shield(j)*sss
4686 gacontp_hb3(k,num_conti,i)=gggp(k)
4687 & *fac_shield(i)*fac_shield(j)*sss
4689 gacontm_hb1(k,num_conti,i)=!ghalfm
4690 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4691 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4692 & *fac_shield(i)*fac_shield(j)*sss
4694 gacontm_hb2(k,num_conti,i)=!ghalfm
4695 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4696 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4697 & *fac_shield(i)*fac_shield(j)*sss
4699 gacontm_hb3(k,num_conti,i)=gggm(k)
4700 & *fac_shield(i)*fac_shield(j)*sss
4703 C Diagnostics. Comment out or remove after debugging!
4705 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4706 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4707 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4708 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4709 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4710 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4713 endif ! num_conti.le.maxconts
4717 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4720 ghalf=0.5d0*agg(l,k)
4721 aggi(l,k)=aggi(l,k)+ghalf
4722 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4723 aggj(l,k)=aggj(l,k)+ghalf
4726 if (j.eq.nres-1 .and. i.lt.j-2) then
4729 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4734 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4737 C-----------------------------------------------------------------------------
4738 subroutine eturn3(i,eello_turn3)
4739 C Third- and fourth-order contributions from turns
4740 implicit real*8 (a-h,o-z)
4741 include 'DIMENSIONS'
4742 include 'COMMON.IOUNITS'
4743 include 'COMMON.GEO'
4744 include 'COMMON.VAR'
4745 include 'COMMON.LOCAL'
4746 include 'COMMON.CHAIN'
4747 include 'COMMON.DERIV'
4748 include 'COMMON.INTERACT'
4749 include 'COMMON.CORRMAT'
4750 include 'COMMON.TORSION'
4751 include 'COMMON.VECTORS'
4752 include 'COMMON.FFIELD'
4753 include 'COMMON.CONTROL'
4754 include 'COMMON.SHIELD'
4756 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4757 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4758 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4759 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4760 & auxgmat2(2,2),auxgmatt2(2,2)
4761 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4762 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4763 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4764 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4767 c write (iout,*) "eturn3",i,j,j1,j2
4772 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4774 C Third-order contributions
4781 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4782 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4783 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4784 c auxalary matices for theta gradient
4785 c auxalary matrix for i+1 and constant i+2
4786 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4787 c auxalary matrix for i+2 and constant i+1
4788 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4789 call transpose2(auxmat(1,1),auxmat1(1,1))
4790 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4791 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4792 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4793 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4794 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4795 if (shield_mode.eq.0) then
4802 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4803 & *fac_shield(i)*fac_shield(j)
4804 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4805 & *fac_shield(i)*fac_shield(j)
4806 if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4809 C Derivatives in theta
4810 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4811 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4812 & *fac_shield(i)*fac_shield(j)
4813 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4814 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4815 & *fac_shield(i)*fac_shield(j)
4818 C Derivatives in shield mode
4819 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4820 & (shield_mode.gt.0)) then
4823 do ilist=1,ishield_list(i)
4824 iresshield=shield_list(ilist,i)
4826 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4828 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4830 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4831 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4835 do ilist=1,ishield_list(j)
4836 iresshield=shield_list(ilist,j)
4838 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4840 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4842 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4843 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4850 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4851 & grad_shield(k,i)*eello_t3/fac_shield(i)
4852 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4853 & grad_shield(k,j)*eello_t3/fac_shield(j)
4854 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4855 & grad_shield(k,i)*eello_t3/fac_shield(i)
4856 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4857 & grad_shield(k,j)*eello_t3/fac_shield(j)
4861 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4862 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
4863 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
4864 cd & ' eello_turn3_num',4*eello_turn3_num
4865 C Derivatives in gamma(i)
4866 call matmat2(EUgder(1,1,i+1),EUg(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)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4870 & *fac_shield(i)*fac_shield(j)
4871 C Derivatives in gamma(i+1)
4872 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4873 call transpose2(auxmat2(1,1),auxmat3(1,1))
4874 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4875 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4876 & +0.5d0*(pizda(1,1)+pizda(2,2))
4877 & *fac_shield(i)*fac_shield(j)
4878 C Cartesian derivatives
4880 c ghalf1=0.5d0*agg(l,1)
4881 c ghalf2=0.5d0*agg(l,2)
4882 c ghalf3=0.5d0*agg(l,3)
4883 c ghalf4=0.5d0*agg(l,4)
4884 a_temp(1,1)=aggi(l,1)!+ghalf1
4885 a_temp(1,2)=aggi(l,2)!+ghalf2
4886 a_temp(2,1)=aggi(l,3)!+ghalf3
4887 a_temp(2,2)=aggi(l,4)!+ghalf4
4888 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4889 gcorr3_turn(l,i)=gcorr3_turn(l,i)
4890 & +0.5d0*(pizda(1,1)+pizda(2,2))
4891 & *fac_shield(i)*fac_shield(j)
4893 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4894 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4895 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4896 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4897 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4898 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4899 & +0.5d0*(pizda(1,1)+pizda(2,2))
4900 & *fac_shield(i)*fac_shield(j)
4901 a_temp(1,1)=aggj(l,1)!+ghalf1
4902 a_temp(1,2)=aggj(l,2)!+ghalf2
4903 a_temp(2,1)=aggj(l,3)!+ghalf3
4904 a_temp(2,2)=aggj(l,4)!+ghalf4
4905 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4906 gcorr3_turn(l,j)=gcorr3_turn(l,j)
4907 & +0.5d0*(pizda(1,1)+pizda(2,2))
4908 & *fac_shield(i)*fac_shield(j)
4909 a_temp(1,1)=aggj1(l,1)
4910 a_temp(1,2)=aggj1(l,2)
4911 a_temp(2,1)=aggj1(l,3)
4912 a_temp(2,2)=aggj1(l,4)
4913 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4914 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4915 & +0.5d0*(pizda(1,1)+pizda(2,2))
4916 & *fac_shield(i)*fac_shield(j)
4920 C-------------------------------------------------------------------------------
4921 subroutine eturn4(i,eello_turn4)
4922 C Third- and fourth-order contributions from turns
4923 implicit real*8 (a-h,o-z)
4924 include 'DIMENSIONS'
4925 include 'COMMON.IOUNITS'
4926 include 'COMMON.GEO'
4927 include 'COMMON.VAR'
4928 include 'COMMON.LOCAL'
4929 include 'COMMON.CHAIN'
4930 include 'COMMON.DERIV'
4931 include 'COMMON.INTERACT'
4932 include 'COMMON.CORRMAT'
4933 include 'COMMON.TORSION'
4934 include 'COMMON.VECTORS'
4935 include 'COMMON.FFIELD'
4936 include 'COMMON.CONTROL'
4937 include 'COMMON.SHIELD'
4939 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4940 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4941 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4942 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4943 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
4944 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4945 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4946 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4947 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4948 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4949 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4952 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4954 C Fourth-order contributions
4962 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4963 cd call checkint_turn4(i,a_temp,eello_turn4_num)
4964 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4965 c write(iout,*)"WCHODZE W PROGRAM"
4970 iti1=itype2loc(itype(i+1))
4971 iti2=itype2loc(itype(i+2))
4972 iti3=itype2loc(itype(i+3))
4973 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4974 call transpose2(EUg(1,1,i+1),e1t(1,1))
4975 call transpose2(Eug(1,1,i+2),e2t(1,1))
4976 call transpose2(Eug(1,1,i+3),e3t(1,1))
4977 C Ematrix derivative in theta
4978 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4979 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4980 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4981 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4982 c eta1 in derivative theta
4983 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4984 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4985 c auxgvec is derivative of Ub2 so i+3 theta
4986 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4987 c auxalary matrix of E i+1
4988 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4991 s1=scalar2(b1(1,i+2),auxvec(1))
4992 c derivative of theta i+2 with constant i+3
4993 gs23=scalar2(gtb1(1,i+2),auxvec(1))
4994 c derivative of theta i+2 with constant i+2
4995 gs32=scalar2(b1(1,i+2),auxgvec(1))
4996 c derivative of E matix in theta of i+1
4997 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4999 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5000 c ea31 in derivative theta
5001 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5002 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5003 c auxilary matrix auxgvec of Ub2 with constant E matirx
5004 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5005 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5006 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5010 s2=scalar2(b1(1,i+1),auxvec(1))
5011 c derivative of theta i+1 with constant i+3
5012 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5013 c derivative of theta i+2 with constant i+1
5014 gs21=scalar2(b1(1,i+1),auxgvec(1))
5015 c derivative of theta i+3 with constant i+1
5016 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5017 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5019 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5020 c two derivatives over diffetent matrices
5021 c gtae3e2 is derivative over i+3
5022 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5023 c ae3gte2 is derivative over i+2
5024 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5025 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5026 c three possible derivative over theta E matices
5028 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5030 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5032 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5033 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5035 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5036 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5037 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5038 if (shield_mode.eq.0) then
5045 eello_turn4=eello_turn4-(s1+s2+s3)
5046 & *fac_shield(i)*fac_shield(j)
5047 eello_t4=-(s1+s2+s3)
5048 & *fac_shield(i)*fac_shield(j)
5049 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5050 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5051 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5052 C Now derivative over shield:
5053 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5054 & (shield_mode.gt.0)) then
5057 do ilist=1,ishield_list(i)
5058 iresshield=shield_list(ilist,i)
5060 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5062 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5064 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5065 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5069 do ilist=1,ishield_list(j)
5070 iresshield=shield_list(ilist,j)
5072 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5074 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5076 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5077 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5084 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5085 & grad_shield(k,i)*eello_t4/fac_shield(i)
5086 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5087 & grad_shield(k,j)*eello_t4/fac_shield(j)
5088 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5089 & grad_shield(k,i)*eello_t4/fac_shield(i)
5090 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5091 & grad_shield(k,j)*eello_t4/fac_shield(j)
5100 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5101 cd & ' eello_turn4_num',8*eello_turn4_num
5103 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5104 & -(gs13+gsE13+gsEE1)*wturn4
5105 & *fac_shield(i)*fac_shield(j)
5106 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5107 & -(gs23+gs21+gsEE2)*wturn4
5108 & *fac_shield(i)*fac_shield(j)
5110 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5111 & -(gs32+gsE31+gsEE3)*wturn4
5112 & *fac_shield(i)*fac_shield(j)
5114 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5117 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5118 & 'eturn4',i,j,-(s1+s2+s3)
5119 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5120 c & ' eello_turn4_num',8*eello_turn4_num
5121 C Derivatives in gamma(i)
5122 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5123 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5124 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5125 s1=scalar2(b1(1,i+2),auxvec(1))
5126 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5127 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5128 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5129 & *fac_shield(i)*fac_shield(j)
5130 C Derivatives in gamma(i+1)
5131 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5132 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5133 s2=scalar2(b1(1,i+1),auxvec(1))
5134 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5135 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5136 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5137 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5138 & *fac_shield(i)*fac_shield(j)
5139 C Derivatives in gamma(i+2)
5140 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5141 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5142 s1=scalar2(b1(1,i+2),auxvec(1))
5143 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5144 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5145 s2=scalar2(b1(1,i+1),auxvec(1))
5146 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5147 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5148 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5149 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5150 & *fac_shield(i)*fac_shield(j)
5151 C Cartesian derivatives
5152 C Derivatives of this turn contributions in DC(i+2)
5153 if (j.lt.nres-1) then
5155 a_temp(1,1)=agg(l,1)
5156 a_temp(1,2)=agg(l,2)
5157 a_temp(2,1)=agg(l,3)
5158 a_temp(2,2)=agg(l,4)
5159 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5160 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5161 s1=scalar2(b1(1,i+2),auxvec(1))
5162 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5163 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5164 s2=scalar2(b1(1,i+1),auxvec(1))
5165 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5166 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5167 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5169 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5170 & *fac_shield(i)*fac_shield(j)
5173 C Remaining derivatives of this turn contribution
5175 a_temp(1,1)=aggi(l,1)
5176 a_temp(1,2)=aggi(l,2)
5177 a_temp(2,1)=aggi(l,3)
5178 a_temp(2,2)=aggi(l,4)
5179 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5180 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5181 s1=scalar2(b1(1,i+2),auxvec(1))
5182 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5183 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5184 s2=scalar2(b1(1,i+1),auxvec(1))
5185 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5186 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5187 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5188 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5189 & *fac_shield(i)*fac_shield(j)
5190 a_temp(1,1)=aggi1(l,1)
5191 a_temp(1,2)=aggi1(l,2)
5192 a_temp(2,1)=aggi1(l,3)
5193 a_temp(2,2)=aggi1(l,4)
5194 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5195 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5196 s1=scalar2(b1(1,i+2),auxvec(1))
5197 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5198 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5199 s2=scalar2(b1(1,i+1),auxvec(1))
5200 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5201 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5202 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5203 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5204 & *fac_shield(i)*fac_shield(j)
5205 a_temp(1,1)=aggj(l,1)
5206 a_temp(1,2)=aggj(l,2)
5207 a_temp(2,1)=aggj(l,3)
5208 a_temp(2,2)=aggj(l,4)
5209 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5210 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5211 s1=scalar2(b1(1,i+2),auxvec(1))
5212 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5213 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5214 s2=scalar2(b1(1,i+1),auxvec(1))
5215 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5216 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5217 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5218 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5219 & *fac_shield(i)*fac_shield(j)
5220 a_temp(1,1)=aggj1(l,1)
5221 a_temp(1,2)=aggj1(l,2)
5222 a_temp(2,1)=aggj1(l,3)
5223 a_temp(2,2)=aggj1(l,4)
5224 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5225 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5226 s1=scalar2(b1(1,i+2),auxvec(1))
5227 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5228 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5229 s2=scalar2(b1(1,i+1),auxvec(1))
5230 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5231 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5232 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5233 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5234 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5235 & *fac_shield(i)*fac_shield(j)
5239 C-----------------------------------------------------------------------------
5240 subroutine vecpr(u,v,w)
5241 implicit real*8(a-h,o-z)
5242 dimension u(3),v(3),w(3)
5243 w(1)=u(2)*v(3)-u(3)*v(2)
5244 w(2)=-u(1)*v(3)+u(3)*v(1)
5245 w(3)=u(1)*v(2)-u(2)*v(1)
5248 C-----------------------------------------------------------------------------
5249 subroutine unormderiv(u,ugrad,unorm,ungrad)
5250 C This subroutine computes the derivatives of a normalized vector u, given
5251 C the derivatives computed without normalization conditions, ugrad. Returns
5254 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5255 double precision vec(3)
5256 double precision scalar
5258 c write (2,*) 'ugrad',ugrad
5261 vec(i)=scalar(ugrad(1,i),u(1))
5263 c write (2,*) 'vec',vec
5266 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5269 c write (2,*) 'ungrad',ungrad
5272 C-----------------------------------------------------------------------------
5273 subroutine escp_soft_sphere(evdw2,evdw2_14)
5275 C This subroutine calculates the excluded-volume interaction energy between
5276 C peptide-group centers and side chains and its gradient in virtual-bond and
5277 C side-chain vectors.
5279 implicit real*8 (a-h,o-z)
5280 include 'DIMENSIONS'
5281 include 'COMMON.GEO'
5282 include 'COMMON.VAR'
5283 include 'COMMON.LOCAL'
5284 include 'COMMON.CHAIN'
5285 include 'COMMON.DERIV'
5286 include 'COMMON.INTERACT'
5287 include 'COMMON.FFIELD'
5288 include 'COMMON.IOUNITS'
5289 include 'COMMON.CONTROL'
5291 double precision boxshift
5295 cd print '(a)','Enter ESCP'
5296 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5300 c do i=iatscp_s,iatscp_e
5301 do ikont=g_listscp_start,g_listscp_end
5302 i=newcontlistscpi(ikont)
5303 j=newcontlistscpj(ikont)
5304 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5306 xi=0.5D0*(c(1,i)+c(1,i+1))
5307 yi=0.5D0*(c(2,i)+c(2,i+1))
5308 zi=0.5D0*(c(3,i)+c(3,i+1))
5309 C Return atom into box, boxxsize is size of box in x dimension
5311 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5312 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5313 C Condition for being inside the proper box
5314 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5315 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5319 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5320 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5321 C Condition for being inside the proper box
5322 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5323 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5327 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5328 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5329 cC Condition for being inside the proper box
5330 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5331 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5334 call to_box(xi,yi,zi)
5335 C xi=xi+xshift*boxxsize
5336 C yi=yi+yshift*boxysize
5337 C zi=zi+zshift*boxzsize
5338 c do iint=1,nscp_gr(i)
5340 c do j=iscpstart(i,iint),iscpend(i,iint)
5341 if (itype(j).eq.ntyp1) cycle
5342 itypj=iabs(itype(j))
5343 C Uncomment following three lines for SC-p interactions
5347 C Uncomment following three lines for Ca-p interactions
5351 call to_box(xj,yj,zj)
5352 xj=boxshift(xj-xi,boxxsize)
5353 yj=boxshift(yj-yi,boxysize)
5354 zj=boxshift(zj-zi,boxzsize)
5358 rij=xj*xj+yj*yj+zj*zj
5362 if (rij.lt.r0ijsq) then
5363 evdwij=0.25d0*(rij-r0ijsq)**2
5371 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5377 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5378 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5389 C-----------------------------------------------------------------------------
5390 subroutine escp(evdw2,evdw2_14)
5392 C This subroutine calculates the excluded-volume interaction energy between
5393 C peptide-group centers and side chains and its gradient in virtual-bond and
5394 C side-chain vectors.
5397 include 'DIMENSIONS'
5398 include 'COMMON.GEO'
5399 include 'COMMON.VAR'
5400 include 'COMMON.LOCAL'
5401 include 'COMMON.CHAIN'
5402 include 'COMMON.DERIV'
5403 include 'COMMON.INTERACT'
5404 include 'COMMON.FFIELD'
5405 include 'COMMON.IOUNITS'
5406 include 'COMMON.CONTROL'
5407 include 'COMMON.SPLITELE'
5408 double precision ggg(3)
5409 integer i,iint,j,k,iteli,itypj,subchap,ikont
5410 double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5412 double precision evdw2,evdw2_14,evdwij
5413 double precision sscale,sscagrad
5414 double precision boxshift
5417 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5418 cd print '(a)','Enter ESCP'
5419 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5423 if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5424 c do i=iatscp_s,iatscp_e
5425 do ikont=g_listscp_start,g_listscp_end
5426 i=newcontlistscpi(ikont)
5427 j=newcontlistscpj(ikont)
5428 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5430 xi=0.5D0*(c(1,i)+c(1,i+1))
5431 yi=0.5D0*(c(2,i)+c(2,i+1))
5432 zi=0.5D0*(c(3,i)+c(3,i+1))
5433 call to_box(xi,yi,zi)
5434 c do iint=1,nscp_gr(i)
5436 c do j=iscpstart(i,iint),iscpend(i,iint)
5437 itypj=iabs(itype(j))
5438 if (itypj.eq.ntyp1) cycle
5439 C Uncomment following three lines for SC-p interactions
5443 C Uncomment following three lines for Ca-p interactions
5447 call to_box(xj,yj,zj)
5448 xj=boxshift(xj-xi,boxxsize)
5449 yj=boxshift(yj-yi,boxysize)
5450 zj=boxshift(zj-zi,boxzsize)
5451 c print *,xj,yj,zj,'polozenie j'
5452 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5454 sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5455 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5456 c if (sss.eq.0) print *,'czasem jest OK'
5457 if (sss.le.0.0d0) cycle
5458 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5460 e1=fac*fac*aad(itypj,iteli)
5461 e2=fac*bad(itypj,iteli)
5462 if (iabs(j-i) .le. 2) then
5465 evdw2_14=evdw2_14+(e1+e2)*sss
5468 evdw2=evdw2+evdwij*sss
5469 if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5470 & 'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5471 & evdwij,iteli,itypj,fac,aad(itypj,iteli),
5474 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5476 fac=-(evdwij+e1)*rrij*sss
5477 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5481 cgrad if (j.lt.i) then
5482 cd write (iout,*) 'j<i'
5483 C Uncomment following three lines for SC-p interactions
5485 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5488 cd write (iout,*) 'j>i'
5490 cgrad ggg(k)=-ggg(k)
5491 C Uncomment following line for SC-p interactions
5492 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5493 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5497 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5499 cgrad kstart=min0(i+1,j)
5500 cgrad kend=max0(i-1,j-1)
5501 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5502 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5503 cgrad do k=kstart,kend
5505 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5509 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5510 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5512 c endif !endif for sscale cutoff
5522 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5523 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5524 gradx_scp(j,i)=expon*gradx_scp(j,i)
5527 C******************************************************************************
5531 C To save time the factor EXPON has been extracted from ALL components
5532 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5535 C******************************************************************************
5538 C--------------------------------------------------------------------------
5539 subroutine edis(ehpb)
5541 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5543 implicit real*8 (a-h,o-z)
5544 include 'DIMENSIONS'
5545 include 'COMMON.SBRIDGE'
5546 include 'COMMON.CHAIN'
5547 include 'COMMON.DERIV'
5548 include 'COMMON.VAR'
5549 include 'COMMON.INTERACT'
5550 include 'COMMON.IOUNITS'
5551 include 'COMMON.CONTROL'
5552 dimension ggg(3),ggg_peak(3,1000)
5557 c 8/21/18 AL: added explicit restraints on reference coords
5558 c write (iout,*) "restr_on_coord",restr_on_coord
5559 if (restr_on_coord) then
5563 if (itype(i).eq.ntyp1) cycle
5565 ecoor=ecoor+(c(j,i)-cref(j,i))**2
5566 ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5568 if (itype(i).ne.10) then
5570 ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5571 ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5574 if (energy_dec) write (iout,*)
5575 & "i",i," bfac",bfac(i)," ecoor",ecoor
5576 ehpb=ehpb+0.5d0*bfac(i)*ecoor
5580 C write (iout,*) ,"link_end",link_end,constr_dist
5581 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5582 c write(iout,*)'link_start=',link_start,' link_end=',link_end,
5583 c & " constr_dist",constr_dist," link_start_peak",link_start_peak,
5584 c & " link_end_peak",link_end_peak
5585 if (link_end.eq.0.and.link_end_peak.eq.0) return
5586 do i=link_start_peak,link_end_peak
5588 c print *,"i",i," link_end_peak",link_end_peak," ipeak",
5589 c & ipeak(1,i),ipeak(2,i)
5590 do ip=ipeak(1,i),ipeak(2,i)
5595 C iii and jjj point to the residues for which the distance is assigned.
5596 c if (ii.gt.nres) then
5603 if (ii.gt.nres) then
5608 if (jj.gt.nres) then
5613 aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5614 aux=dexp(-scal_peak*aux)
5615 ehpb_peak=ehpb_peak+aux
5616 fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5617 & forcon_peak(ip))*aux/dd
5619 ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5621 if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5622 & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5623 & forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5625 c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5626 ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5627 do ip=ipeak(1,i),ipeak(2,i)
5630 ggg(j)=ggg_peak(j,iip)/ehpb_peak
5634 C iii and jjj point to the residues for which the distance is assigned.
5635 c if (ii.gt.nres) then
5642 if (ii.gt.nres) then
5647 if (jj.gt.nres) then
5654 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5659 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5663 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5664 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5668 do i=link_start,link_end
5669 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5670 C CA-CA distance used in regularization of structure.
5673 C iii and jjj point to the residues for which the distance is assigned.
5674 if (ii.gt.nres) then
5679 if (jj.gt.nres) then
5684 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5685 c & dhpb(i),dhpb1(i),forcon(i)
5686 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5687 C distance and angle dependent SS bond potential.
5688 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5689 C & iabs(itype(jjj)).eq.1) then
5690 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5691 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5692 if (.not.dyn_ss .and. i.le.nss) then
5693 C 15/02/13 CC dynamic SSbond - additional check
5694 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5695 & iabs(itype(jjj)).eq.1) then
5696 call ssbond_ene(iii,jjj,eij)
5699 cd write (iout,*) "eij",eij
5700 cd & ' waga=',waga,' fac=',fac
5701 ! else if (ii.gt.nres .and. jj.gt.nres) then
5703 C Calculate the distance between the two points and its difference from the
5706 if (irestr_type(i).eq.11) then
5707 ehpb=ehpb+fordepth(i)!**4.0d0
5708 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5709 fac=fordepth(i)!**4.0d0
5710 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5711 if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5712 & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5713 & ehpb,irestr_type(i)
5714 else if (irestr_type(i).eq.10) then
5715 c AL 6//19/2018 cross-link restraints
5716 xdis = 0.5d0*(dd/forcon(i))**2
5717 expdis = dexp(-xdis)
5718 c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5719 aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5720 c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5721 c & " wboltzd",wboltzd
5722 ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5723 c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5724 fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5725 & *expdis/(aux*forcon(i)**2)
5726 if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5727 & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5728 & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5729 else if (irestr_type(i).eq.2) then
5730 c Quartic restraints
5731 ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5732 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5733 & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5734 & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5735 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5737 c Quadratic restraints
5739 C Get the force constant corresponding to this distance.
5741 C Calculate the contribution to energy.
5742 ehpb=ehpb+0.5d0*waga*rdis*rdis
5743 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5744 & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5745 & 0.5d0*waga*rdis*rdis,irestr_type(i)
5747 C Evaluate gradient.
5751 c Calculate Cartesian gradient
5753 ggg(j)=fac*(c(j,jj)-c(j,ii))
5755 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5756 C If this is a SC-SC distance, we need to calculate the contributions to the
5757 C Cartesian gradient in the SC vectors (ghpbx).
5760 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5765 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5769 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5770 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5776 C--------------------------------------------------------------------------
5777 subroutine ssbond_ene(i,j,eij)
5779 C Calculate the distance and angle dependent SS-bond potential energy
5780 C using a free-energy function derived based on RHF/6-31G** ab initio
5781 C calculations of diethyl disulfide.
5783 C A. Liwo and U. Kozlowska, 11/24/03
5785 implicit real*8 (a-h,o-z)
5786 include 'DIMENSIONS'
5787 include 'COMMON.SBRIDGE'
5788 include 'COMMON.CHAIN'
5789 include 'COMMON.DERIV'
5790 include 'COMMON.LOCAL'
5791 include 'COMMON.INTERACT'
5792 include 'COMMON.VAR'
5793 include 'COMMON.IOUNITS'
5794 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5795 itypi=iabs(itype(i))
5799 dxi=dc_norm(1,nres+i)
5800 dyi=dc_norm(2,nres+i)
5801 dzi=dc_norm(3,nres+i)
5802 c dsci_inv=dsc_inv(itypi)
5803 dsci_inv=vbld_inv(nres+i)
5804 itypj=iabs(itype(j))
5805 c dscj_inv=dsc_inv(itypj)
5806 dscj_inv=vbld_inv(nres+j)
5810 dxj=dc_norm(1,nres+j)
5811 dyj=dc_norm(2,nres+j)
5812 dzj=dc_norm(3,nres+j)
5813 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5818 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5819 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5820 om12=dxi*dxj+dyi*dyj+dzi*dzj
5822 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5823 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5829 deltat12=om2-om1+2.0d0
5831 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5832 & +akct*deltad*deltat12
5833 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5834 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5835 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5836 c & " deltat12",deltat12," eij",eij
5837 ed=2*akcm*deltad+akct*deltat12
5839 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5840 eom1=-2*akth*deltat1-pom1-om2*pom2
5841 eom2= 2*akth*deltat2+pom1-om1*pom2
5844 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5845 ghpbx(k,i)=ghpbx(k,i)-ggk
5846 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5847 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5848 ghpbx(k,j)=ghpbx(k,j)+ggk
5849 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5850 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5851 ghpbc(k,i)=ghpbc(k,i)-ggk
5852 ghpbc(k,j)=ghpbc(k,j)+ggk
5855 C Calculate the components of the gradient in DC and X
5859 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
5864 C--------------------------------------------------------------------------
5865 subroutine ebond(estr)
5867 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5869 implicit real*8 (a-h,o-z)
5870 include 'DIMENSIONS'
5871 include 'COMMON.LOCAL'
5872 include 'COMMON.GEO'
5873 include 'COMMON.INTERACT'
5874 include 'COMMON.DERIV'
5875 include 'COMMON.VAR'
5876 include 'COMMON.CHAIN'
5877 include 'COMMON.IOUNITS'
5878 include 'COMMON.NAMES'
5879 include 'COMMON.FFIELD'
5880 include 'COMMON.CONTROL'
5881 include 'COMMON.SETUP'
5882 double precision u(3),ud(3)
5885 do i=ibondp_start,ibondp_end
5886 c 3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
5889 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
5890 diff = vbld(i)-vbldp0
5892 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5893 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5895 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5896 c & *dc(j,i-1)/vbld(i)
5898 c if (energy_dec) write(iout,*)
5899 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5901 C Checking if it involves dummy (NH3+ or COO-) group
5902 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5903 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
5904 diff = vbld(i)-vbldpDUM
5905 if (energy_dec) write(iout,*) "dum_bond",i,diff
5907 C NO vbldp0 is the equlibrium length of spring for peptide group
5908 diff = vbld(i)-vbldp0
5911 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5912 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5915 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5917 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5921 estr=0.5d0*AKP*estr+estr1
5923 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5925 do i=ibond_start,ibond_end
5927 if (iti.ne.10 .and. iti.ne.ntyp1) then
5930 diff=vbld(i+nres)-vbldsc0(1,iti)
5931 if (energy_dec) write (iout,*)
5932 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5933 & AKSC(1,iti),AKSC(1,iti)*diff*diff
5934 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5936 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5940 diff=vbld(i+nres)-vbldsc0(j,iti)
5941 ud(j)=aksc(j,iti)*diff
5942 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5956 uprod2=uprod2*u(k)*u(k)
5960 usumsqder=usumsqder+ud(j)*uprod2
5962 estr=estr+uprod/usum
5964 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5972 C--------------------------------------------------------------------------
5973 subroutine ebend(etheta)
5975 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5976 C angles gamma and its derivatives in consecutive thetas and gammas.
5978 implicit real*8 (a-h,o-z)
5979 include 'DIMENSIONS'
5980 include 'COMMON.LOCAL'
5981 include 'COMMON.GEO'
5982 include 'COMMON.INTERACT'
5983 include 'COMMON.DERIV'
5984 include 'COMMON.VAR'
5985 include 'COMMON.CHAIN'
5986 include 'COMMON.IOUNITS'
5987 include 'COMMON.NAMES'
5988 include 'COMMON.FFIELD'
5989 include 'COMMON.CONTROL'
5990 include 'COMMON.TORCNSTR'
5991 common /calcthet/ term1,term2,termm,diffak,ratak,
5992 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5993 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5994 double precision y(2),z(2)
5996 c time11=dexp(-2*time)
5999 c write (*,'(a,i2)') 'EBEND ICG=',icg
6000 do i=ithet_start,ithet_end
6001 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6002 & .or.itype(i).eq.ntyp1) cycle
6003 C Zero the energy function and its derivative at 0 or pi.
6004 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6006 ichir1=isign(1,itype(i-2))
6007 ichir2=isign(1,itype(i))
6008 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6009 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6010 if (itype(i-1).eq.10) then
6011 itype1=isign(10,itype(i-2))
6012 ichir11=isign(1,itype(i-2))
6013 ichir12=isign(1,itype(i-2))
6014 itype2=isign(10,itype(i))
6015 ichir21=isign(1,itype(i))
6016 ichir22=isign(1,itype(i))
6019 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6022 if (phii.ne.phii) phii=150.0
6032 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6035 if (phii1.ne.phii1) phii1=150.0
6047 C Calculate the "mean" value of theta from the part of the distribution
6048 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6049 C In following comments this theta will be referred to as t_c.
6050 thet_pred_mean=0.0d0
6052 athetk=athet(k,it,ichir1,ichir2)
6053 bthetk=bthet(k,it,ichir1,ichir2)
6055 athetk=athet(k,itype1,ichir11,ichir12)
6056 bthetk=bthet(k,itype2,ichir21,ichir22)
6058 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6059 c write(iout,*) 'chuj tu', y(k),z(k)
6061 dthett=thet_pred_mean*ssd
6062 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6063 C Derivatives of the "mean" values in gamma1 and gamma2.
6064 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6065 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6066 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6067 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6069 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6070 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6071 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6072 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6074 if (theta(i).gt.pi-delta) then
6075 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6077 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6078 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6079 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6081 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6083 else if (theta(i).lt.delta) then
6084 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6085 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6086 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6088 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6089 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6092 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6095 etheta=etheta+ethetai
6096 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6097 & 'ebend',i,ethetai,theta(i),itype(i)
6098 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6099 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6100 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6103 C Ufff.... We've done all this!!!
6106 C---------------------------------------------------------------------------
6107 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6109 implicit real*8 (a-h,o-z)
6110 include 'DIMENSIONS'
6111 include 'COMMON.LOCAL'
6112 include 'COMMON.IOUNITS'
6113 common /calcthet/ term1,term2,termm,diffak,ratak,
6114 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6115 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6116 C Calculate the contributions to both Gaussian lobes.
6117 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6118 C The "polynomial part" of the "standard deviation" of this part of
6119 C the distributioni.
6120 ccc write (iout,*) thetai,thet_pred_mean
6123 sig=sig*thet_pred_mean+polthet(j,it)
6125 C Derivative of the "interior part" of the "standard deviation of the"
6126 C gamma-dependent Gaussian lobe in t_c.
6127 sigtc=3*polthet(3,it)
6129 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6132 C Set the parameters of both Gaussian lobes of the distribution.
6133 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6134 fac=sig*sig+sigc0(it)
6137 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6138 sigsqtc=-4.0D0*sigcsq*sigtc
6139 c print *,i,sig,sigtc,sigsqtc
6140 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6141 sigtc=-sigtc/(fac*fac)
6142 C Following variable is sigma(t_c)**(-2)
6143 sigcsq=sigcsq*sigcsq
6145 sig0inv=1.0D0/sig0i**2
6146 delthec=thetai-thet_pred_mean
6147 delthe0=thetai-theta0i
6148 term1=-0.5D0*sigcsq*delthec*delthec
6149 term2=-0.5D0*sig0inv*delthe0*delthe0
6150 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6151 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6152 C NaNs in taking the logarithm. We extract the largest exponent which is added
6153 C to the energy (this being the log of the distribution) at the end of energy
6154 C term evaluation for this virtual-bond angle.
6155 if (term1.gt.term2) then
6157 term2=dexp(term2-termm)
6161 term1=dexp(term1-termm)
6164 C The ratio between the gamma-independent and gamma-dependent lobes of
6165 C the distribution is a Gaussian function of thet_pred_mean too.
6166 diffak=gthet(2,it)-thet_pred_mean
6167 ratak=diffak/gthet(3,it)**2
6168 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6169 C Let's differentiate it in thet_pred_mean NOW.
6171 C Now put together the distribution terms to make complete distribution.
6172 termexp=term1+ak*term2
6173 termpre=sigc+ak*sig0i
6174 C Contribution of the bending energy from this theta is just the -log of
6175 C the sum of the contributions from the two lobes and the pre-exponential
6176 C factor. Simple enough, isn't it?
6177 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6178 C write (iout,*) 'termexp',termexp,termm,termpre,i
6179 C NOW the derivatives!!!
6180 C 6/6/97 Take into account the deformation.
6181 E_theta=(delthec*sigcsq*term1
6182 & +ak*delthe0*sig0inv*term2)/termexp
6183 E_tc=((sigtc+aktc*sig0i)/termpre
6184 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6185 & aktc*term2)/termexp)
6188 c-----------------------------------------------------------------------------
6189 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6190 implicit real*8 (a-h,o-z)
6191 include 'DIMENSIONS'
6192 include 'COMMON.LOCAL'
6193 include 'COMMON.IOUNITS'
6194 common /calcthet/ term1,term2,termm,diffak,ratak,
6195 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6196 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6197 delthec=thetai-thet_pred_mean
6198 delthe0=thetai-theta0i
6199 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6200 t3 = thetai-thet_pred_mean
6204 t14 = t12+t6*sigsqtc
6206 t21 = thetai-theta0i
6212 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6213 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6214 & *(-t12*t9-ak*sig0inv*t27)
6218 C--------------------------------------------------------------------------
6219 subroutine ebend(etheta)
6221 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6222 C angles gamma and its derivatives in consecutive thetas and gammas.
6223 C ab initio-derived potentials from
6224 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6226 implicit real*8 (a-h,o-z)
6227 include 'DIMENSIONS'
6228 include 'COMMON.LOCAL'
6229 include 'COMMON.GEO'
6230 include 'COMMON.INTERACT'
6231 include 'COMMON.DERIV'
6232 include 'COMMON.VAR'
6233 include 'COMMON.CHAIN'
6234 include 'COMMON.IOUNITS'
6235 include 'COMMON.NAMES'
6236 include 'COMMON.FFIELD'
6237 include 'COMMON.CONTROL'
6238 include 'COMMON.TORCNSTR'
6239 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6240 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6241 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6242 & sinph1ph2(maxdouble,maxdouble)
6243 logical lprn /.false./, lprn1 /.false./
6245 do i=ithet_start,ithet_end
6246 c print *,i,itype(i-1),itype(i),itype(i-2)
6247 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6248 & .or.itype(i).eq.ntyp1) cycle
6249 C print *,i,theta(i)
6250 if (iabs(itype(i+1)).eq.20) iblock=2
6251 if (iabs(itype(i+1)).ne.20) iblock=1
6255 theti2=0.5d0*theta(i)
6256 ityp2=ithetyp((itype(i-1)))
6258 coskt(k)=dcos(k*theti2)
6259 sinkt(k)=dsin(k*theti2)
6262 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6265 if (phii.ne.phii) phii=150.0
6269 ityp1=ithetyp((itype(i-2)))
6270 C propagation of chirality for glycine type
6272 cosph1(k)=dcos(k*phii)
6273 sinph1(k)=dsin(k*phii)
6278 ityp1=ithetyp((itype(i-2)))
6283 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6286 if (phii1.ne.phii1) phii1=150.0
6291 ityp3=ithetyp((itype(i)))
6293 cosph2(k)=dcos(k*phii1)
6294 sinph2(k)=dsin(k*phii1)
6298 ityp3=ithetyp((itype(i)))
6304 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6307 ccl=cosph1(l)*cosph2(k-l)
6308 ssl=sinph1(l)*sinph2(k-l)
6309 scl=sinph1(l)*cosph2(k-l)
6310 csl=cosph1(l)*sinph2(k-l)
6311 cosph1ph2(l,k)=ccl-ssl
6312 cosph1ph2(k,l)=ccl+ssl
6313 sinph1ph2(l,k)=scl+csl
6314 sinph1ph2(k,l)=scl-csl
6318 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6319 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6320 write (iout,*) "coskt and sinkt"
6322 write (iout,*) k,coskt(k),sinkt(k)
6326 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6327 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6330 & write (iout,*) "k",k,"
6331 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6332 & " ethetai",ethetai
6335 write (iout,*) "cosph and sinph"
6337 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6339 write (iout,*) "cosph1ph2 and sinph2ph2"
6342 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6343 & sinph1ph2(l,k),sinph1ph2(k,l)
6346 write(iout,*) "ethetai",ethetai
6351 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6352 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6353 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6354 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6355 ethetai=ethetai+sinkt(m)*aux
6356 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6357 dephii=dephii+k*sinkt(m)*(
6358 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6359 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6360 dephii1=dephii1+k*sinkt(m)*(
6361 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6362 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6364 & write (iout,*) "m",m," k",k," bbthet",
6365 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6366 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6367 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6368 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6369 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6372 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6373 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6374 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6375 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6377 & write(iout,*) "ethetai",ethetai
6378 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6382 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6383 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6384 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6385 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6386 ethetai=ethetai+sinkt(m)*aux
6387 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6388 dephii=dephii+l*sinkt(m)*(
6389 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6390 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6391 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6392 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6393 dephii1=dephii1+(k-l)*sinkt(m)*(
6394 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6395 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6396 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6397 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6399 write (iout,*) "m",m," k",k," l",l," ffthet",
6400 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6401 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6402 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6403 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6404 & " ethetai",ethetai
6405 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6406 & cosph1ph2(k,l)*sinkt(m),
6407 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6416 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6417 & i,theta(i)*rad2deg,phii*rad2deg,
6418 & phii1*rad2deg,ethetai
6420 etheta=etheta+ethetai
6421 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6422 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6423 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6430 c-----------------------------------------------------------------------------
6431 subroutine esc(escloc)
6432 C Calculate the local energy of a side chain and its derivatives in the
6433 C corresponding virtual-bond valence angles THETA and the spherical angles
6435 implicit real*8 (a-h,o-z)
6436 include 'DIMENSIONS'
6437 include 'COMMON.GEO'
6438 include 'COMMON.LOCAL'
6439 include 'COMMON.VAR'
6440 include 'COMMON.INTERACT'
6441 include 'COMMON.DERIV'
6442 include 'COMMON.CHAIN'
6443 include 'COMMON.IOUNITS'
6444 include 'COMMON.NAMES'
6445 include 'COMMON.FFIELD'
6446 include 'COMMON.CONTROL'
6447 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6448 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6449 common /sccalc/ time11,time12,time112,theti,it,nlobit
6452 c write (iout,'(a)') 'ESC'
6453 do i=loc_start,loc_end
6455 if (it.eq.ntyp1) cycle
6456 if (it.eq.10) goto 1
6457 nlobit=nlob(iabs(it))
6458 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6459 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6460 theti=theta(i+1)-pipol
6465 if (x(2).gt.pi-delta) then
6469 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6471 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6472 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6474 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6475 & ddersc0(1),dersc(1))
6476 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6477 & ddersc0(3),dersc(3))
6479 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6481 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6482 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6483 & dersc0(2),esclocbi,dersc02)
6484 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6486 call splinthet(x(2),0.5d0*delta,ss,ssd)
6491 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6493 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6494 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6496 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6498 c write (iout,*) escloci
6499 else if (x(2).lt.delta) then
6503 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6505 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6506 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6508 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6509 & ddersc0(1),dersc(1))
6510 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6511 & ddersc0(3),dersc(3))
6513 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6515 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6516 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6517 & dersc0(2),esclocbi,dersc02)
6518 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6523 call splinthet(x(2),0.5d0*delta,ss,ssd)
6525 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6527 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6528 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6530 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6531 c write (iout,*) escloci
6533 call enesc(x,escloci,dersc,ddummy,.false.)
6536 escloc=escloc+escloci
6537 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6538 & 'escloc',i,escloci
6539 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6541 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6543 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6544 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6549 C---------------------------------------------------------------------------
6550 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6551 implicit real*8 (a-h,o-z)
6552 include 'DIMENSIONS'
6553 include 'COMMON.GEO'
6554 include 'COMMON.LOCAL'
6555 include 'COMMON.IOUNITS'
6556 common /sccalc/ time11,time12,time112,theti,it,nlobit
6557 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6558 double precision contr(maxlob,-1:1)
6560 c write (iout,*) 'it=',it,' nlobit=',nlobit
6564 if (mixed) ddersc(j)=0.0d0
6568 C Because of periodicity of the dependence of the SC energy in omega we have
6569 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6570 C To avoid underflows, first compute & store the exponents.
6578 z(k)=x(k)-censc(k,j,it)
6583 Axk=Axk+gaussc(l,k,j,it)*z(l)
6589 expfac=expfac+Ax(k,j,iii)*z(k)
6597 C As in the case of ebend, we want to avoid underflows in exponentiation and
6598 C subsequent NaNs and INFs in energy calculation.
6599 C Find the largest exponent
6603 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6607 cd print *,'it=',it,' emin=',emin
6609 C Compute the contribution to SC energy and derivatives
6614 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6615 if(adexp.ne.adexp) adexp=1.0
6618 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6620 cd print *,'j=',j,' expfac=',expfac
6621 escloc_i=escloc_i+expfac
6623 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6627 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6628 & +gaussc(k,2,j,it))*expfac
6635 dersc(1)=dersc(1)/cos(theti)**2
6636 ddersc(1)=ddersc(1)/cos(theti)**2
6639 escloci=-(dlog(escloc_i)-emin)
6641 dersc(j)=dersc(j)/escloc_i
6645 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6650 C------------------------------------------------------------------------------
6651 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6652 implicit real*8 (a-h,o-z)
6653 include 'DIMENSIONS'
6654 include 'COMMON.GEO'
6655 include 'COMMON.LOCAL'
6656 include 'COMMON.IOUNITS'
6657 common /sccalc/ time11,time12,time112,theti,it,nlobit
6658 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6659 double precision contr(maxlob)
6670 z(k)=x(k)-censc(k,j,it)
6676 Axk=Axk+gaussc(l,k,j,it)*z(l)
6682 expfac=expfac+Ax(k,j)*z(k)
6687 C As in the case of ebend, we want to avoid underflows in exponentiation and
6688 C subsequent NaNs and INFs in energy calculation.
6689 C Find the largest exponent
6692 if (emin.gt.contr(j)) emin=contr(j)
6696 C Compute the contribution to SC energy and derivatives
6700 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6701 escloc_i=escloc_i+expfac
6703 dersc(k)=dersc(k)+Ax(k,j)*expfac
6705 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6706 & +gaussc(1,2,j,it))*expfac
6710 dersc(1)=dersc(1)/cos(theti)**2
6711 dersc12=dersc12/cos(theti)**2
6712 escloci=-(dlog(escloc_i)-emin)
6714 dersc(j)=dersc(j)/escloc_i
6716 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6720 c----------------------------------------------------------------------------------
6721 subroutine esc(escloc)
6722 C Calculate the local energy of a side chain and its derivatives in the
6723 C corresponding virtual-bond valence angles THETA and the spherical angles
6724 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6725 C added by Urszula Kozlowska. 07/11/2007
6727 implicit real*8 (a-h,o-z)
6728 include 'DIMENSIONS'
6729 include 'COMMON.GEO'
6730 include 'COMMON.LOCAL'
6731 include 'COMMON.VAR'
6732 include 'COMMON.SCROT'
6733 include 'COMMON.INTERACT'
6734 include 'COMMON.DERIV'
6735 include 'COMMON.CHAIN'
6736 include 'COMMON.IOUNITS'
6737 include 'COMMON.NAMES'
6738 include 'COMMON.FFIELD'
6739 include 'COMMON.CONTROL'
6740 include 'COMMON.VECTORS'
6741 double precision x_prime(3),y_prime(3),z_prime(3)
6742 & , sumene,dsc_i,dp2_i,x(65),
6743 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6744 & de_dxx,de_dyy,de_dzz,de_dt
6745 double precision s1_t,s1_6_t,s2_t,s2_6_t
6747 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6748 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6749 & dt_dCi(3),dt_dCi1(3)
6750 common /sccalc/ time11,time12,time112,theti,it,nlobit
6753 do i=loc_start,loc_end
6754 if (itype(i).eq.ntyp1) cycle
6755 costtab(i+1) =dcos(theta(i+1))
6756 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6757 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6758 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6759 cosfac2=0.5d0/(1.0d0+costtab(i+1))
6760 cosfac=dsqrt(cosfac2)
6761 sinfac2=0.5d0/(1.0d0-costtab(i+1))
6762 sinfac=dsqrt(sinfac2)
6764 if (it.eq.10) goto 1
6766 C Compute the axes of tghe local cartesian coordinates system; store in
6767 c x_prime, y_prime and z_prime
6774 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6775 C & dc_norm(3,i+nres)
6777 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6778 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6781 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6784 c write (2,*) "x_prime",(x_prime(j),j=1,3)
6785 c write (2,*) "y_prime",(y_prime(j),j=1,3)
6786 c write (2,*) "z_prime",(z_prime(j),j=1,3)
6787 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6788 c & " xy",scalar(x_prime(1),y_prime(1)),
6789 c & " xz",scalar(x_prime(1),z_prime(1)),
6790 c & " yy",scalar(y_prime(1),y_prime(1)),
6791 c & " yz",scalar(y_prime(1),z_prime(1)),
6792 c & " zz",scalar(z_prime(1),z_prime(1))
6794 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6795 C to local coordinate system. Store in xx, yy, zz.
6801 xx = xx + x_prime(j)*dc_norm(j,i+nres)
6802 yy = yy + y_prime(j)*dc_norm(j,i+nres)
6803 zz = zz + z_prime(j)*dc_norm(j,i+nres)
6810 C Compute the energy of the ith side cbain
6812 c write (2,*) "xx",xx," yy",yy," zz",zz
6815 x(j) = sc_parmin(j,it)
6818 Cc diagnostics - remove later
6820 yy1 = dsin(alph(2))*dcos(omeg(2))
6821 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6822 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6823 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6825 C," --- ", xx_w,yy_w,zz_w
6828 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
6829 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
6831 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6832 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6834 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6835 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6836 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6837 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6838 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6840 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6841 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6842 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6843 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6844 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6846 dsc_i = 0.743d0+x(61)
6848 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6849 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6850 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6851 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6852 s1=(1+x(63))/(0.1d0 + dscp1)
6853 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6854 s2=(1+x(65))/(0.1d0 + dscp2)
6855 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6856 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6857 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6858 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6860 c & dscp1,dscp2,sumene
6861 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6862 escloc = escloc + sumene
6863 if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
6864 & " escloc",sumene,escloc,it,itype(i)
6869 C This section to check the numerical derivatives of the energy of ith side
6870 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6871 C #define DEBUG in the code to turn it on.
6873 write (2,*) "sumene =",sumene
6877 write (2,*) xx,yy,zz
6878 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6879 de_dxx_num=(sumenep-sumene)/aincr
6881 write (2,*) "xx+ sumene from enesc=",sumenep
6884 write (2,*) xx,yy,zz
6885 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6886 de_dyy_num=(sumenep-sumene)/aincr
6888 write (2,*) "yy+ sumene from enesc=",sumenep
6891 write (2,*) xx,yy,zz
6892 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6893 de_dzz_num=(sumenep-sumene)/aincr
6895 write (2,*) "zz+ sumene from enesc=",sumenep
6896 costsave=cost2tab(i+1)
6897 sintsave=sint2tab(i+1)
6898 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6899 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6900 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6901 de_dt_num=(sumenep-sumene)/aincr
6902 write (2,*) " t+ sumene from enesc=",sumenep
6903 cost2tab(i+1)=costsave
6904 sint2tab(i+1)=sintsave
6905 C End of diagnostics section.
6908 C Compute the gradient of esc
6910 c zz=zz*dsign(1.0,dfloat(itype(i)))
6911 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6912 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6913 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6914 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6915 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6916 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6917 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6918 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6919 pom1=(sumene3*sint2tab(i+1)+sumene1)
6920 & *(pom_s1/dscp1+pom_s16*dscp1**4)
6921 pom2=(sumene4*cost2tab(i+1)+sumene2)
6922 & *(pom_s2/dscp2+pom_s26*dscp2**4)
6923 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6924 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6925 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6927 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6928 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6929 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6931 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6932 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6933 & +(pom1+pom2)*pom_dx
6935 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6938 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6939 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6940 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6942 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6943 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6944 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6945 & +x(59)*zz**2 +x(60)*xx*zz
6946 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6947 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6948 & +(pom1-pom2)*pom_dy
6950 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6953 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6954 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6955 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6956 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
6957 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
6958 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6959 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6960 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
6962 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6965 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6966 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6967 & +pom1*pom_dt1+pom2*pom_dt2
6969 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6974 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6975 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6976 cosfac2xx=cosfac2*xx
6977 sinfac2yy=sinfac2*yy
6979 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6981 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6983 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6984 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6985 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6986 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6987 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6988 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6989 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6990 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6991 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6992 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6996 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6997 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6998 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6999 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7002 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7003 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7004 dZZ_XYZ(k)=vbld_inv(i+nres)*
7005 & (z_prime(k)-zz*dC_norm(k,i+nres))
7007 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7008 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7012 dXX_Ctab(k,i)=dXX_Ci(k)
7013 dXX_C1tab(k,i)=dXX_Ci1(k)
7014 dYY_Ctab(k,i)=dYY_Ci(k)
7015 dYY_C1tab(k,i)=dYY_Ci1(k)
7016 dZZ_Ctab(k,i)=dZZ_Ci(k)
7017 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7018 dXX_XYZtab(k,i)=dXX_XYZ(k)
7019 dYY_XYZtab(k,i)=dYY_XYZ(k)
7020 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7024 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7025 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7026 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7027 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7028 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7030 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7031 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7032 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7033 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7034 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7035 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7036 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7037 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7039 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7040 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7042 C to check gradient call subroutine check_grad
7048 c------------------------------------------------------------------------------
7049 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7051 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7052 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7053 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7054 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7056 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7057 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7059 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7060 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7061 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7062 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7063 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7065 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7066 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7067 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7068 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7069 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7071 dsc_i = 0.743d0+x(61)
7073 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7074 & *(xx*cost2+yy*sint2))
7075 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7076 & *(xx*cost2-yy*sint2))
7077 s1=(1+x(63))/(0.1d0 + dscp1)
7078 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7079 s2=(1+x(65))/(0.1d0 + dscp2)
7080 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7081 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7082 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7087 c------------------------------------------------------------------------------
7088 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7090 C This procedure calculates two-body contact function g(rij) and its derivative:
7093 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7096 C where x=(rij-r0ij)/delta
7098 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7101 double precision rij,r0ij,eps0ij,fcont,fprimcont
7102 double precision x,x2,x4,delta
7106 if (x.lt.-1.0D0) then
7109 else if (x.le.1.0D0) then
7112 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7113 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7120 c------------------------------------------------------------------------------
7121 subroutine splinthet(theti,delta,ss,ssder)
7122 implicit real*8 (a-h,o-z)
7123 include 'DIMENSIONS'
7124 include 'COMMON.VAR'
7125 include 'COMMON.GEO'
7128 if (theti.gt.pipol) then
7129 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7131 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7136 c------------------------------------------------------------------------------
7137 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7139 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7140 double precision ksi,ksi2,ksi3,a1,a2,a3
7141 a1=fprim0*delta/(f1-f0)
7147 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7148 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7151 c------------------------------------------------------------------------------
7152 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7154 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7155 double precision ksi,ksi2,ksi3,a1,a2,a3
7160 a2=3*(f1x-f0x)-2*fprim0x*delta
7161 a3=fprim0x*delta-2*(f1x-f0x)
7162 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7165 C-----------------------------------------------------------------------------
7167 C-----------------------------------------------------------------------------
7168 subroutine etor(etors)
7169 implicit real*8 (a-h,o-z)
7170 include 'DIMENSIONS'
7171 include 'COMMON.VAR'
7172 include 'COMMON.GEO'
7173 include 'COMMON.LOCAL'
7174 include 'COMMON.TORSION'
7175 include 'COMMON.INTERACT'
7176 include 'COMMON.DERIV'
7177 include 'COMMON.CHAIN'
7178 include 'COMMON.NAMES'
7179 include 'COMMON.IOUNITS'
7180 include 'COMMON.FFIELD'
7181 include 'COMMON.TORCNSTR'
7182 include 'COMMON.CONTROL'
7184 C Set lprn=.true. for debugging
7188 do i=iphi_start,iphi_end
7190 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7191 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7192 itori=itortyp(itype(i-2))
7193 itori1=itortyp(itype(i-1))
7196 C Proline-Proline pair is a special case...
7197 if (itori.eq.3 .and. itori1.eq.3) then
7198 if (phii.gt.-dwapi3) then
7200 fac=1.0D0/(1.0D0-cosphi)
7201 etorsi=v1(1,3,3)*fac
7202 etorsi=etorsi+etorsi
7203 etors=etors+etorsi-v1(1,3,3)
7204 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7205 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7208 v1ij=v1(j+1,itori,itori1)
7209 v2ij=v2(j+1,itori,itori1)
7212 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7213 if (energy_dec) etors_ii=etors_ii+
7214 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7215 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7219 v1ij=v1(j,itori,itori1)
7220 v2ij=v2(j,itori,itori1)
7223 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7224 if (energy_dec) etors_ii=etors_ii+
7225 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7226 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7229 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7232 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7233 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7234 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7235 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7236 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7240 c------------------------------------------------------------------------------
7241 subroutine etor_d(etors_d)
7245 c----------------------------------------------------------------------------
7246 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7247 subroutine e_modeller(ehomology_constr)
7248 ehomology_constr=0.0d0
7249 write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7252 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7254 c------------------------------------------------------------------------------
7255 subroutine etor_d(etors_d)
7259 c----------------------------------------------------------------------------
7261 subroutine etor(etors)
7262 implicit real*8 (a-h,o-z)
7263 include 'DIMENSIONS'
7264 include 'COMMON.VAR'
7265 include 'COMMON.GEO'
7266 include 'COMMON.LOCAL'
7267 include 'COMMON.TORSION'
7268 include 'COMMON.INTERACT'
7269 include 'COMMON.DERIV'
7270 include 'COMMON.CHAIN'
7271 include 'COMMON.NAMES'
7272 include 'COMMON.IOUNITS'
7273 include 'COMMON.FFIELD'
7274 include 'COMMON.TORCNSTR'
7275 include 'COMMON.CONTROL'
7277 C Set lprn=.true. for debugging
7281 do i=iphi_start,iphi_end
7282 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7283 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7284 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7285 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7286 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7287 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7288 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7289 C For introducing the NH3+ and COO- group please check the etor_d for reference
7292 if (iabs(itype(i)).eq.20) then
7297 itori=itortyp(itype(i-2))
7298 itori1=itortyp(itype(i-1))
7301 C Regular cosine and sine terms
7302 do j=1,nterm(itori,itori1,iblock)
7303 v1ij=v1(j,itori,itori1,iblock)
7304 v2ij=v2(j,itori,itori1,iblock)
7307 etors=etors+v1ij*cosphi+v2ij*sinphi
7308 if (energy_dec) etors_ii=etors_ii+
7309 & v1ij*cosphi+v2ij*sinphi
7310 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7314 C E = SUM ----------------------------------- - v1
7315 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7317 cosphi=dcos(0.5d0*phii)
7318 sinphi=dsin(0.5d0*phii)
7319 do j=1,nlor(itori,itori1,iblock)
7320 vl1ij=vlor1(j,itori,itori1)
7321 vl2ij=vlor2(j,itori,itori1)
7322 vl3ij=vlor3(j,itori,itori1)
7323 pom=vl2ij*cosphi+vl3ij*sinphi
7324 pom1=1.0d0/(pom*pom+1.0d0)
7325 etors=etors+vl1ij*pom1
7326 if (energy_dec) etors_ii=etors_ii+
7329 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7331 C Subtract the constant term
7332 etors=etors-v0(itori,itori1,iblock)
7333 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7334 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7336 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7337 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7338 & (v1(j,itori,itori1,iblock),j=1,6),
7339 & (v2(j,itori,itori1,iblock),j=1,6)
7340 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7341 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7345 c----------------------------------------------------------------------------
7346 subroutine etor_d(etors_d)
7347 C 6/23/01 Compute double torsional energy
7348 implicit real*8 (a-h,o-z)
7349 include 'DIMENSIONS'
7350 include 'COMMON.VAR'
7351 include 'COMMON.GEO'
7352 include 'COMMON.LOCAL'
7353 include 'COMMON.TORSION'
7354 include 'COMMON.INTERACT'
7355 include 'COMMON.DERIV'
7356 include 'COMMON.CHAIN'
7357 include 'COMMON.NAMES'
7358 include 'COMMON.IOUNITS'
7359 include 'COMMON.FFIELD'
7360 include 'COMMON.TORCNSTR'
7362 C Set lprn=.true. for debugging
7366 c write(iout,*) "a tu??"
7367 do i=iphid_start,iphid_end
7368 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7369 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7370 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7371 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7372 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7373 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7374 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7375 & (itype(i+1).eq.ntyp1)) cycle
7376 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7377 itori=itortyp(itype(i-2))
7378 itori1=itortyp(itype(i-1))
7379 itori2=itortyp(itype(i))
7385 if (iabs(itype(i+1)).eq.20) iblock=2
7386 C Iblock=2 Proline type
7387 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7388 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7389 C if (itype(i+1).eq.ntyp1) iblock=3
7390 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7391 C IS or IS NOT need for this
7392 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7393 C is (itype(i-3).eq.ntyp1) ntblock=2
7394 C ntblock is N-terminal blocking group
7396 C Regular cosine and sine terms
7397 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7398 C Example of changes for NH3+ blocking group
7399 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7400 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7401 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7402 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7403 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7404 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7405 cosphi1=dcos(j*phii)
7406 sinphi1=dsin(j*phii)
7407 cosphi2=dcos(j*phii1)
7408 sinphi2=dsin(j*phii1)
7409 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7410 & v2cij*cosphi2+v2sij*sinphi2
7411 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7412 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7414 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7416 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7417 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7418 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7419 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7420 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7421 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7422 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7423 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7424 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7425 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7426 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7427 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7428 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7429 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7432 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7433 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7438 C----------------------------------------------------------------------------------
7439 C The rigorous attempt to derive energy function
7440 subroutine etor_kcc(etors)
7441 implicit real*8 (a-h,o-z)
7442 include 'DIMENSIONS'
7443 include 'COMMON.VAR'
7444 include 'COMMON.GEO'
7445 include 'COMMON.LOCAL'
7446 include 'COMMON.TORSION'
7447 include 'COMMON.INTERACT'
7448 include 'COMMON.DERIV'
7449 include 'COMMON.CHAIN'
7450 include 'COMMON.NAMES'
7451 include 'COMMON.IOUNITS'
7452 include 'COMMON.FFIELD'
7453 include 'COMMON.TORCNSTR'
7454 include 'COMMON.CONTROL'
7455 double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7457 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7458 C Set lprn=.true. for debugging
7461 C print *,"wchodze kcc"
7462 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7464 do i=iphi_start,iphi_end
7465 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7466 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7467 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7468 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7469 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7470 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7471 itori=itortyp(itype(i-2))
7472 itori1=itortyp(itype(i-1))
7477 C to avoid multiple devision by 2
7478 c theti22=0.5d0*theta(i)
7479 C theta 12 is the theta_1 /2
7480 C theta 22 is theta_2 /2
7481 c theti12=0.5d0*theta(i-1)
7482 C and appropriate sinus function
7483 sinthet1=dsin(theta(i-1))
7484 sinthet2=dsin(theta(i))
7485 costhet1=dcos(theta(i-1))
7486 costhet2=dcos(theta(i))
7487 C to speed up lets store its mutliplication
7488 sint1t2=sinthet2*sinthet1
7490 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7491 C +d_n*sin(n*gamma)) *
7492 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7493 C we have two sum 1) Non-Chebyshev which is with n and gamma
7494 nval=nterm_kcc_Tb(itori,itori1)
7500 c1(j)=c1(j-1)*costhet1
7501 c2(j)=c2(j-1)*costhet2
7504 do j=1,nterm_kcc(itori,itori1)
7508 sint1t2n=sint1t2n*sint1t2
7514 sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7515 gradvalct1=gradvalct1+
7516 & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7517 gradvalct2=gradvalct2+
7518 & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7521 gradvalct1=-gradvalct1*sinthet1
7522 gradvalct2=-gradvalct2*sinthet2
7528 sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7529 gradvalst1=gradvalst1+
7530 & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7531 gradvalst2=gradvalst2+
7532 & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7535 gradvalst1=-gradvalst1*sinthet1
7536 gradvalst2=-gradvalst2*sinthet2
7537 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7538 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7539 C glocig is the gradient local i site in gamma
7540 glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7541 C now gradient over theta_1
7542 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7543 & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7544 glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7545 & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7548 C derivative over gamma
7549 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7550 C derivative over theta1
7551 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7552 C now derivative over theta2
7553 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7555 write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7556 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7557 write (iout,*) "c1",(c1(k),k=0,nval),
7558 & " c2",(c2(k),k=0,nval)
7563 c---------------------------------------------------------------------------------------------
7564 subroutine etor_constr(edihcnstr)
7565 implicit real*8 (a-h,o-z)
7566 include 'DIMENSIONS'
7567 include 'COMMON.VAR'
7568 include 'COMMON.GEO'
7569 include 'COMMON.LOCAL'
7570 include 'COMMON.TORSION'
7571 include 'COMMON.INTERACT'
7572 include 'COMMON.DERIV'
7573 include 'COMMON.CHAIN'
7574 include 'COMMON.NAMES'
7575 include 'COMMON.IOUNITS'
7576 include 'COMMON.FFIELD'
7577 include 'COMMON.TORCNSTR'
7578 include 'COMMON.BOUNDS'
7579 include 'COMMON.CONTROL'
7580 ! 6/20/98 - dihedral angle constraints
7582 c do i=1,ndih_constr
7583 if (raw_psipred) then
7584 do i=idihconstr_start,idihconstr_end
7585 itori=idih_constr(i)
7587 gaudih_i=vpsipred(1,i)
7591 cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7592 dexpcos_i=dexp(-cos_i*cos_i)
7593 gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7594 gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7595 & *cos_i*dexpcos_i/s**2
7597 edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7598 gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7600 & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7601 & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7602 & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7603 & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7604 & -wdihc*dlog(gaudih_i)
7608 do i=idihconstr_start,idihconstr_end
7609 itori=idih_constr(i)
7611 difi=pinorm(phii-phi0(i))
7612 if (difi.gt.drange(i)) then
7614 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7615 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7616 else if (difi.lt.-drange(i)) then
7618 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7619 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7629 c----------------------------------------------------------------------------
7630 c MODELLER restraint function
7631 subroutine e_modeller(ehomology_constr)
7633 include 'DIMENSIONS'
7635 double precision ehomology_constr
7636 integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7637 integer katy, odleglosci, test7
7638 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7640 real*8 distance(max_template),distancek(max_template),
7641 & min_odl,godl(max_template),dih_diff(max_template)
7644 c FP - 30/10/2014 Temporary specifications for homology restraints
7646 double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7648 double precision, dimension (maxres) :: guscdiff,usc_diff
7649 double precision, dimension (max_template) ::
7650 & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7652 double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7653 & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7654 & betai,sum_sgodl,dij
7655 double precision dist,pinorm
7657 include 'COMMON.SBRIDGE'
7658 include 'COMMON.CHAIN'
7659 include 'COMMON.GEO'
7660 include 'COMMON.DERIV'
7661 include 'COMMON.LOCAL'
7662 include 'COMMON.INTERACT'
7663 include 'COMMON.VAR'
7664 include 'COMMON.IOUNITS'
7665 c include 'COMMON.MD'
7666 include 'COMMON.CONTROL'
7667 include 'COMMON.HOMOLOGY'
7668 include 'COMMON.QRESTR'
7670 c From subroutine Econstr_back
7672 include 'COMMON.NAMES'
7673 include 'COMMON.TIME1'
7678 distancek(i)=9999999.9
7684 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7686 C AL 5/2/14 - Introduce list of restraints
7687 c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7689 write(iout,*) "------- dist restrs start -------"
7691 do ii = link_start_homo,link_end_homo
7695 c write (iout,*) "dij(",i,j,") =",dij
7697 do k=1,constr_homology
7698 c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7699 if(.not.l_homo(k,ii)) then
7703 distance(k)=odl(k,ii)-dij
7704 c write (iout,*) "distance(",k,") =",distance(k)
7706 c For Gaussian-type Urestr
7708 distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7709 c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7710 c write (iout,*) "distancek(",k,") =",distancek(k)
7711 c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7713 c For Lorentzian-type Urestr
7715 if (waga_dist.lt.0.0d0) then
7716 sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7717 distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7718 & (distance(k)**2+sigma_odlir(k,ii)**2))
7722 c min_odl=minval(distancek)
7726 do kk=1,constr_homology
7727 if(l_homo(kk,ii)) then
7728 min_odl=distancek(kk)
7732 do kk=1,constr_homology
7733 if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7734 & min_odl=distancek(kk)
7738 c write (iout,* )"min_odl",min_odl
7740 write (iout,*) "ij dij",i,j,dij
7741 write (iout,*) "distance",(distance(k),k=1,constr_homology)
7742 write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7743 write (iout,* )"min_odl",min_odl
7748 if (waga_dist.ge.0.0d0) then
7754 do k=1,constr_homology
7755 c Nie wiem po co to liczycie jeszcze raz!
7756 c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7757 c & (2*(sigma_odl(i,j,k))**2))
7758 if(.not.l_homo(k,ii)) cycle
7759 if (waga_dist.ge.0.0d0) then
7761 c For Gaussian-type Urestr
7763 godl(k)=dexp(-distancek(k)+min_odl)
7764 odleg2=odleg2+godl(k)
7766 c For Lorentzian-type Urestr
7769 odleg2=odleg2+distancek(k)
7772 ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7773 ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7774 ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7775 ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7778 c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7779 c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7781 write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7782 write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7784 if (waga_dist.ge.0.0d0) then
7786 c For Gaussian-type Urestr
7788 odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7790 c For Lorentzian-type Urestr
7793 odleg=odleg+odleg2/constr_homology
7796 c write (iout,*) "odleg",odleg ! sum of -ln-s
7799 c For Gaussian-type Urestr
7801 if (waga_dist.ge.0.0d0) sum_godl=odleg2
7803 do k=1,constr_homology
7804 c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7805 c & *waga_dist)+min_odl
7806 c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7808 if(.not.l_homo(k,ii)) cycle
7809 if (waga_dist.ge.0.0d0) then
7810 c For Gaussian-type Urestr
7812 sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7814 c For Lorentzian-type Urestr
7817 sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7818 & sigma_odlir(k,ii)**2)**2)
7820 sum_sgodl=sum_sgodl+sgodl
7822 c sgodl2=sgodl2+sgodl
7823 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7824 c write(iout,*) "constr_homology=",constr_homology
7825 c write(iout,*) i, j, k, "TEST K"
7827 if (waga_dist.ge.0.0d0) then
7829 c For Gaussian-type Urestr
7831 grad_odl3=waga_homology(iset)*waga_dist
7832 & *sum_sgodl/(sum_godl*dij)
7834 c For Lorentzian-type Urestr
7837 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7838 c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7839 grad_odl3=-waga_homology(iset)*waga_dist*
7840 & sum_sgodl/(constr_homology*dij)
7843 c grad_odl3=sum_sgodl/(sum_godl*dij)
7846 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7847 c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7848 c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7850 ccc write(iout,*) godl, sgodl, grad_odl3
7852 c grad_odl=grad_odl+grad_odl3
7855 ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7856 ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7857 ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7858 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
7859 ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7860 ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7861 ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7862 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
7863 c if (i.eq.25.and.j.eq.27) then
7864 c write(iout,*) "jik",jik,"i",i,"j",j
7865 c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7866 c write(iout,*) "grad_odl3",grad_odl3
7867 c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7868 c write(iout,*) "ggodl",ggodl
7869 c write(iout,*) "ghpbc(",jik,i,")",
7870 c & ghpbc(jik,i),"ghpbc(",jik,j,")",
7874 ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7875 ccc & dLOG(odleg2),"-odleg=", -odleg
7877 enddo ! ii-loop for dist
7879 write(iout,*) "------- dist restrs end -------"
7880 c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7881 c & waga_d.eq.1.0d0) call sum_gradient
7883 c Pseudo-energy and gradient from dihedral-angle restraints from
7884 c homology templates
7885 c write (iout,*) "End of distance loop"
7888 c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7890 write(iout,*) "------- dih restrs start -------"
7891 do i=idihconstr_start_homo,idihconstr_end_homo
7892 write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7895 do i=idihconstr_start_homo,idihconstr_end_homo
7897 c betai=beta(i,i+1,i+2,i+3)
7899 c write (iout,*) "betai =",betai
7900 do k=1,constr_homology
7901 dih_diff(k)=pinorm(dih(k,i)-betai)
7902 cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7903 cd & ,sigma_dih(k,i)
7904 c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7905 c & -(6.28318-dih_diff(i,k))
7906 c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7907 c & 6.28318+dih_diff(i,k)
7909 kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7911 kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7913 c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7916 c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7919 c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7920 c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7922 write (iout,*) "i",i," betai",betai," kat2",kat2
7923 write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7925 if (kat2.le.1.0d-14) cycle
7926 kat=kat-dLOG(kat2/constr_homology)
7927 c write (iout,*) "kat",kat ! sum of -ln-s
7929 ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7930 ccc & dLOG(kat2), "-kat=", -kat
7932 c ----------------------------------------------------------------------
7934 c ----------------------------------------------------------------------
7938 do k=1,constr_homology
7940 sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
7942 sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd
7944 c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7945 sum_sgdih=sum_sgdih+sgdih
7947 c grad_dih3=sum_sgdih/sum_gdih
7948 grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7950 c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7951 ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7952 ccc & gloc(nphi+i-3,icg)
7953 gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7955 c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7957 ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7958 ccc & gloc(nphi+i-3,icg)
7960 enddo ! i-loop for dih
7962 write(iout,*) "------- dih restrs end -------"
7965 c Pseudo-energy and gradient for theta angle restraints from
7966 c homology templates
7967 c FP 01/15 - inserted from econstr_local_test.F, loop structure
7971 c For constr_homology reference structures (FP)
7973 c Uconst_back_tot=0.0d0
7976 c Econstr_back legacy
7978 c do i=ithet_start,ithet_end
7981 c do i=loc_start,loc_end
7984 duscdiffx(j,i)=0.0d0
7989 c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7990 c write (iout,*) "waga_theta",waga_theta
7991 if (waga_theta.gt.0.0d0) then
7993 write (iout,*) "usampl",usampl
7994 write(iout,*) "------- theta restrs start -------"
7995 c do i=ithet_start,ithet_end
7996 c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7999 c write (iout,*) "maxres",maxres,"nres",nres
8001 do i=ithet_start,ithet_end
8004 c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8006 c Deviation of theta angles wrt constr_homology ref structures
8008 utheta_i=0.0d0 ! argument of Gaussian for single k
8009 gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8010 c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8011 c over residues in a fragment
8012 c write (iout,*) "theta(",i,")=",theta(i)
8013 do k=1,constr_homology
8015 c dtheta_i=theta(j)-thetaref(j,iref)
8016 c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8017 theta_diff(k)=thetatpl(k,i)-theta(i)
8018 cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8019 cd & ,sigma_theta(k,i)
8022 utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8023 c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8024 gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8025 gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk)
8026 c Gradient for single Gaussian restraint in subr Econstr_back
8027 c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8030 c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8031 c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8034 c Gradient for multiple Gaussian restraint
8035 sum_gtheta=gutheta_i
8037 do k=1,constr_homology
8038 c New generalized expr for multiple Gaussian from Econstr_back
8039 sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8041 c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8042 sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8044 c Final value of gradient using same var as in Econstr_back
8045 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8046 & +sum_sgtheta/sum_gtheta*waga_theta
8047 & *waga_homology(iset)
8048 c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8049 c & *waga_homology(iset)
8050 c dutheta(i)=sum_sgtheta/sum_gtheta
8052 c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8053 Eval=Eval-dLOG(gutheta_i/constr_homology)
8054 c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8055 c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8056 c Uconst_back=Uconst_back+utheta(i)
8057 enddo ! (i-loop for theta)
8059 write(iout,*) "------- theta restrs end -------"
8063 c Deviation of local SC geometry
8065 c Separation of two i-loops (instructed by AL - 11/3/2014)
8067 c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8068 c write (iout,*) "waga_d",waga_d
8071 write(iout,*) "------- SC restrs start -------"
8072 write (iout,*) "Initial duscdiff,duscdiffx"
8073 do i=loc_start,loc_end
8074 write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8075 & (duscdiffx(jik,i),jik=1,3)
8078 do i=loc_start,loc_end
8079 usc_diff_i=0.0d0 ! argument of Gaussian for single k
8080 guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8081 c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8082 c write(iout,*) "xxtab, yytab, zztab"
8083 c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8084 do k=1,constr_homology
8086 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8087 c Original sign inverted for calc of gradients (s. Econstr_back)
8088 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8089 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8090 c write(iout,*) "dxx, dyy, dzz"
8091 cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8093 usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
8094 c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8095 c uscdiffk(k)=usc_diff(i)
8096 guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8097 c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8098 c & " guscdiff2",guscdiff2(k)
8099 guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk)
8100 c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8101 c & xxref(j),yyref(j),zzref(j)
8106 c Generalized expression for multiple Gaussian acc to that for a single
8107 c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8109 c Original implementation
8110 c sum_guscdiff=guscdiff(i)
8112 c sum_sguscdiff=0.0d0
8113 c do k=1,constr_homology
8114 c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8115 c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8116 c sum_sguscdiff=sum_sguscdiff+sguscdiff
8119 c Implementation of new expressions for gradient (Jan. 2015)
8121 c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8122 do k=1,constr_homology
8124 c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8125 c before. Now the drivatives should be correct
8127 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8128 c Original sign inverted for calc of gradients (s. Econstr_back)
8129 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8130 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8132 c New implementation
8134 sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8135 & sigma_d(k,i) ! for the grad wrt r'
8136 c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8139 c New implementation
8140 sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8142 duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8143 & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8144 & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8145 duscdiff(jik,i)=duscdiff(jik,i)+
8146 & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8147 & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8148 duscdiffx(jik,i)=duscdiffx(jik,i)+
8149 & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8150 & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8153 write(iout,*) "jik",jik,"i",i
8154 write(iout,*) "dxx, dyy, dzz"
8155 write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8156 write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8157 c write(iout,*) "sum_sguscdiff",sum_sguscdiff
8158 cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8159 c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8160 c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8161 c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8162 c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8163 c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8164 c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8165 c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8166 c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8167 c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8168 c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8169 c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8175 c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
8176 c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8178 c write (iout,*) i," uscdiff",uscdiff(i)
8180 c Put together deviations from local geometry
8182 c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8183 c & wfrag_back(3,i,iset)*uscdiff(i)
8184 Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8185 c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8186 c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8187 c Uconst_back=Uconst_back+usc_diff(i)
8189 c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8191 c New implment: multiplied by sum_sguscdiff
8194 enddo ! (i-loop for dscdiff)
8199 write(iout,*) "------- SC restrs end -------"
8200 write (iout,*) "------ After SC loop in e_modeller ------"
8201 do i=loc_start,loc_end
8202 write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8203 write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8205 if (waga_theta.eq.1.0d0) then
8206 write (iout,*) "in e_modeller after SC restr end: dutheta"
8207 do i=ithet_start,ithet_end
8208 write (iout,*) i,dutheta(i)
8211 if (waga_d.eq.1.0d0) then
8212 write (iout,*) "e_modeller after SC loop: duscdiff/x"
8214 write (iout,*) i,(duscdiff(j,i),j=1,3)
8215 write (iout,*) i,(duscdiffx(j,i),j=1,3)
8220 c Total energy from homology restraints
8222 write (iout,*) "odleg",odleg," kat",kat
8225 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8227 c ehomology_constr=odleg+kat
8229 c For Lorentzian-type Urestr
8232 if (waga_dist.ge.0.0d0) then
8234 c For Gaussian-type Urestr
8236 ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8237 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8238 c write (iout,*) "ehomology_constr=",ehomology_constr
8241 c For Lorentzian-type Urestr
8243 ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8244 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8245 c write (iout,*) "ehomology_constr=",ehomology_constr
8248 write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8249 & "Eval",waga_theta,eval,
8250 & "Erot",waga_d,Erot
8251 write (iout,*) "ehomology_constr",ehomology_constr
8257 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8258 747 format(a12,i4,i4,i4,f8.3,f8.3)
8259 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8260 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8261 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8262 & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8264 c----------------------------------------------------------------------------
8265 C The rigorous attempt to derive energy function
8266 subroutine ebend_kcc(etheta)
8268 implicit real*8 (a-h,o-z)
8269 include 'DIMENSIONS'
8270 include 'COMMON.VAR'
8271 include 'COMMON.GEO'
8272 include 'COMMON.LOCAL'
8273 include 'COMMON.TORSION'
8274 include 'COMMON.INTERACT'
8275 include 'COMMON.DERIV'
8276 include 'COMMON.CHAIN'
8277 include 'COMMON.NAMES'
8278 include 'COMMON.IOUNITS'
8279 include 'COMMON.FFIELD'
8280 include 'COMMON.TORCNSTR'
8281 include 'COMMON.CONTROL'
8283 double precision thybt1(maxang_kcc)
8284 C Set lprn=.true. for debugging
8287 C print *,"wchodze kcc"
8288 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8290 do i=ithet_start,ithet_end
8291 c print *,i,itype(i-1),itype(i),itype(i-2)
8292 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8293 & .or.itype(i).eq.ntyp1) cycle
8294 iti=iabs(itortyp(itype(i-1)))
8295 sinthet=dsin(theta(i))
8296 costhet=dcos(theta(i))
8297 do j=1,nbend_kcc_Tb(iti)
8298 thybt1(j)=v1bend_chyb(j,iti)
8300 sumth1thyb=v1bend_chyb(0,iti)+
8301 & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8302 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8304 ihelp=nbend_kcc_Tb(iti)-1
8305 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8306 etheta=etheta+sumth1thyb
8307 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8308 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8312 c-------------------------------------------------------------------------------------
8313 subroutine etheta_constr(ethetacnstr)
8315 implicit real*8 (a-h,o-z)
8316 include 'DIMENSIONS'
8317 include 'COMMON.VAR'
8318 include 'COMMON.GEO'
8319 include 'COMMON.LOCAL'
8320 include 'COMMON.TORSION'
8321 include 'COMMON.INTERACT'
8322 include 'COMMON.DERIV'
8323 include 'COMMON.CHAIN'
8324 include 'COMMON.NAMES'
8325 include 'COMMON.IOUNITS'
8326 include 'COMMON.FFIELD'
8327 include 'COMMON.TORCNSTR'
8328 include 'COMMON.CONTROL'
8330 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8331 do i=ithetaconstr_start,ithetaconstr_end
8332 itheta=itheta_constr(i)
8333 thetiii=theta(itheta)
8334 difi=pinorm(thetiii-theta_constr0(i))
8335 if (difi.gt.theta_drange(i)) then
8336 difi=difi-theta_drange(i)
8337 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8338 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8339 & +for_thet_constr(i)*difi**3
8340 else if (difi.lt.-drange(i)) then
8342 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8343 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8344 & +for_thet_constr(i)*difi**3
8348 if (energy_dec) then
8349 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8350 & i,itheta,rad2deg*thetiii,
8351 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8352 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8353 & gloc(itheta+nphi-2,icg)
8358 c------------------------------------------------------------------------------
8359 subroutine eback_sc_corr(esccor)
8360 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8361 c conformational states; temporarily implemented as differences
8362 c between UNRES torsional potentials (dependent on three types of
8363 c residues) and the torsional potentials dependent on all 20 types
8364 c of residues computed from AM1 energy surfaces of terminally-blocked
8365 c amino-acid residues.
8366 implicit real*8 (a-h,o-z)
8367 include 'DIMENSIONS'
8368 include 'COMMON.VAR'
8369 include 'COMMON.GEO'
8370 include 'COMMON.LOCAL'
8371 include 'COMMON.TORSION'
8372 include 'COMMON.SCCOR'
8373 include 'COMMON.INTERACT'
8374 include 'COMMON.DERIV'
8375 include 'COMMON.CHAIN'
8376 include 'COMMON.NAMES'
8377 include 'COMMON.IOUNITS'
8378 include 'COMMON.FFIELD'
8379 include 'COMMON.CONTROL'
8381 C Set lprn=.true. for debugging
8384 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8386 do i=itau_start,itau_end
8387 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8389 isccori=isccortyp(itype(i-2))
8390 isccori1=isccortyp(itype(i-1))
8391 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8393 do intertyp=1,3 !intertyp
8394 cc Added 09 May 2012 (Adasko)
8395 cc Intertyp means interaction type of backbone mainchain correlation:
8396 c 1 = SC...Ca...Ca...Ca
8397 c 2 = Ca...Ca...Ca...SC
8398 c 3 = SC...Ca...Ca...SCi
8400 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8401 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8402 & (itype(i-1).eq.ntyp1)))
8403 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8404 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8405 & .or.(itype(i).eq.ntyp1)))
8406 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8407 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8408 & (itype(i-3).eq.ntyp1)))) cycle
8409 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8410 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8412 do j=1,nterm_sccor(isccori,isccori1)
8413 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8414 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8415 cosphi=dcos(j*tauangle(intertyp,i))
8416 sinphi=dsin(j*tauangle(intertyp,i))
8417 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8418 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8420 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8421 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8423 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8424 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8425 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8426 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8427 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8434 c----------------------------------------------------------------------------
8435 subroutine multibody(ecorr)
8436 C This subroutine calculates multi-body contributions to energy following
8437 C the idea of Skolnick et al. If side chains I and J make a contact and
8438 C at the same time side chains I+1 and J+1 make a contact, an extra
8439 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8440 implicit real*8 (a-h,o-z)
8441 include 'DIMENSIONS'
8442 include 'COMMON.IOUNITS'
8443 include 'COMMON.DERIV'
8444 include 'COMMON.INTERACT'
8445 include 'COMMON.CONTACTS'
8446 include 'COMMON.CONTMAT'
8447 include 'COMMON.CORRMAT'
8448 double precision gx(3),gx1(3)
8451 C Set lprn=.true. for debugging
8455 write (iout,'(a)') 'Contact function values:'
8457 write (iout,'(i2,20(1x,i2,f10.5))')
8458 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8473 num_conti=num_cont(i)
8474 num_conti1=num_cont(i1)
8479 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8480 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8481 cd & ' ishift=',ishift
8482 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8483 C The system gains extra energy.
8484 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8485 endif ! j1==j+-ishift
8494 c------------------------------------------------------------------------------
8495 double precision function esccorr(i,j,k,l,jj,kk)
8496 implicit real*8 (a-h,o-z)
8497 include 'DIMENSIONS'
8498 include 'COMMON.IOUNITS'
8499 include 'COMMON.DERIV'
8500 include 'COMMON.INTERACT'
8501 include 'COMMON.CONTACTS'
8502 include 'COMMON.CONTMAT'
8503 include 'COMMON.CORRMAT'
8504 include 'COMMON.SHIELD'
8505 double precision gx(3),gx1(3)
8510 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8511 C Calculate the multi-body contribution to energy.
8512 C Calculate multi-body contributions to the gradient.
8513 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8514 cd & k,l,(gacont(m,kk,k),m=1,3)
8516 gx(m) =ekl*gacont(m,jj,i)
8517 gx1(m)=eij*gacont(m,kk,k)
8518 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8519 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8520 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8521 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8525 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8530 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8536 c------------------------------------------------------------------------------
8537 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8538 C This subroutine calculates multi-body contributions to hydrogen-bonding
8539 implicit real*8 (a-h,o-z)
8540 include 'DIMENSIONS'
8541 include 'COMMON.IOUNITS'
8544 parameter (max_cont=maxconts)
8545 parameter (max_dim=26)
8546 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8547 double precision zapas(max_dim,maxconts,max_fg_procs),
8548 & zapas_recv(max_dim,maxconts,max_fg_procs)
8549 common /przechowalnia/ zapas
8550 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8551 & status_array(MPI_STATUS_SIZE,maxconts*2)
8553 include 'COMMON.SETUP'
8554 include 'COMMON.FFIELD'
8555 include 'COMMON.DERIV'
8556 include 'COMMON.INTERACT'
8557 include 'COMMON.CONTACTS'
8558 include 'COMMON.CONTMAT'
8559 include 'COMMON.CORRMAT'
8560 include 'COMMON.CONTROL'
8561 include 'COMMON.LOCAL'
8562 double precision gx(3),gx1(3),time00
8565 C Set lprn=.true. for debugging
8570 if (nfgtasks.le.1) goto 30
8572 write (iout,'(a)') 'Contact function values before RECEIVE:'
8574 write (iout,'(2i3,50(1x,i2,f5.2))')
8575 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8576 & j=1,num_cont_hb(i))
8580 do i=1,ntask_cont_from
8583 do i=1,ntask_cont_to
8586 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8588 C Make the list of contacts to send to send to other procesors
8589 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8591 do i=iturn3_start,iturn3_end
8592 c write (iout,*) "make contact list turn3",i," num_cont",
8594 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8596 do i=iturn4_start,iturn4_end
8597 c write (iout,*) "make contact list turn4",i," num_cont",
8599 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8603 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8605 do j=1,num_cont_hb(i)
8608 iproc=iint_sent_local(k,jjc,ii)
8609 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8610 if (iproc.gt.0) then
8611 ncont_sent(iproc)=ncont_sent(iproc)+1
8612 nn=ncont_sent(iproc)
8614 zapas(2,nn,iproc)=jjc
8615 zapas(3,nn,iproc)=facont_hb(j,i)
8616 zapas(4,nn,iproc)=ees0p(j,i)
8617 zapas(5,nn,iproc)=ees0m(j,i)
8618 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8619 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8620 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8621 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8622 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8623 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8624 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8625 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8626 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8627 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8628 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8629 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8630 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8631 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8632 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8633 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8634 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8635 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8636 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8637 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8638 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8645 & "Numbers of contacts to be sent to other processors",
8646 & (ncont_sent(i),i=1,ntask_cont_to)
8647 write (iout,*) "Contacts sent"
8648 do ii=1,ntask_cont_to
8650 iproc=itask_cont_to(ii)
8651 write (iout,*) nn," contacts to processor",iproc,
8652 & " of CONT_TO_COMM group"
8654 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8662 CorrelID1=nfgtasks+fg_rank+1
8664 C Receive the numbers of needed contacts from other processors
8665 do ii=1,ntask_cont_from
8666 iproc=itask_cont_from(ii)
8668 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8669 & FG_COMM,req(ireq),IERR)
8671 c write (iout,*) "IRECV ended"
8673 C Send the number of contacts needed by other processors
8674 do ii=1,ntask_cont_to
8675 iproc=itask_cont_to(ii)
8677 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8678 & FG_COMM,req(ireq),IERR)
8680 c write (iout,*) "ISEND ended"
8681 c write (iout,*) "number of requests (nn)",ireq
8684 & call MPI_Waitall(ireq,req,status_array,ierr)
8686 c & "Numbers of contacts to be received from other processors",
8687 c & (ncont_recv(i),i=1,ntask_cont_from)
8691 do ii=1,ntask_cont_from
8692 iproc=itask_cont_from(ii)
8694 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8695 c & " of CONT_TO_COMM group"
8699 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8700 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8701 c write (iout,*) "ireq,req",ireq,req(ireq)
8704 C Send the contacts to processors that need them
8705 do ii=1,ntask_cont_to
8706 iproc=itask_cont_to(ii)
8708 c write (iout,*) nn," contacts to processor",iproc,
8709 c & " of CONT_TO_COMM group"
8712 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8713 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8714 c write (iout,*) "ireq,req",ireq,req(ireq)
8716 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8720 c write (iout,*) "number of requests (contacts)",ireq
8721 c write (iout,*) "req",(req(i),i=1,4)
8724 & call MPI_Waitall(ireq,req,status_array,ierr)
8725 do iii=1,ntask_cont_from
8726 iproc=itask_cont_from(iii)
8729 write (iout,*) "Received",nn," contacts from processor",iproc,
8730 & " of CONT_FROM_COMM group"
8733 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8738 ii=zapas_recv(1,i,iii)
8739 c Flag the received contacts to prevent double-counting
8740 jj=-zapas_recv(2,i,iii)
8741 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8743 nnn=num_cont_hb(ii)+1
8746 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8747 ees0p(nnn,ii)=zapas_recv(4,i,iii)
8748 ees0m(nnn,ii)=zapas_recv(5,i,iii)
8749 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8750 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8751 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8752 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8753 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8754 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8755 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8756 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8757 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8758 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8759 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8760 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8761 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8762 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8763 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8764 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8765 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8766 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8767 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8768 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8769 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8773 write (iout,'(a)') 'Contact function values after receive:'
8775 write (iout,'(2i3,50(1x,i3,f5.2))')
8776 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8777 & j=1,num_cont_hb(i))
8784 write (iout,'(a)') 'Contact function values:'
8786 write (iout,'(2i3,50(1x,i3,f5.2))')
8787 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8788 & j=1,num_cont_hb(i))
8793 C Remove the loop below after debugging !!!
8800 C Calculate the local-electrostatic correlation terms
8801 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8803 num_conti=num_cont_hb(i)
8804 num_conti1=num_cont_hb(i+1)
8811 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8812 c & ' jj=',jj,' kk=',kk
8814 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8815 & .or. j.lt.0 .and. j1.gt.0) .and.
8816 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8817 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8818 C The system gains extra energy.
8819 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8820 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8821 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8823 else if (j1.eq.j) then
8824 C Contacts I-J and I-(J+1) occur simultaneously.
8825 C The system loses extra energy.
8826 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8831 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8832 c & ' jj=',jj,' kk=',kk
8834 C Contacts I-J and (I+1)-J occur simultaneously.
8835 C The system loses extra energy.
8836 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8843 c------------------------------------------------------------------------------
8844 subroutine add_hb_contact(ii,jj,itask)
8845 implicit real*8 (a-h,o-z)
8846 include "DIMENSIONS"
8847 include "COMMON.IOUNITS"
8850 parameter (max_cont=maxconts)
8851 parameter (max_dim=26)
8852 include "COMMON.CONTACTS"
8853 include 'COMMON.CONTMAT'
8854 include 'COMMON.CORRMAT'
8855 double precision zapas(max_dim,maxconts,max_fg_procs),
8856 & zapas_recv(max_dim,maxconts,max_fg_procs)
8857 common /przechowalnia/ zapas
8858 integer i,j,ii,jj,iproc,itask(4),nn
8859 c write (iout,*) "itask",itask
8862 if (iproc.gt.0) then
8863 do j=1,num_cont_hb(ii)
8865 c write (iout,*) "i",ii," j",jj," jjc",jjc
8867 ncont_sent(iproc)=ncont_sent(iproc)+1
8868 nn=ncont_sent(iproc)
8869 zapas(1,nn,iproc)=ii
8870 zapas(2,nn,iproc)=jjc
8871 zapas(3,nn,iproc)=facont_hb(j,ii)
8872 zapas(4,nn,iproc)=ees0p(j,ii)
8873 zapas(5,nn,iproc)=ees0m(j,ii)
8874 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8875 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8876 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8877 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8878 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8879 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8880 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8881 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8882 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8883 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8884 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8885 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8886 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8887 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8888 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8889 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8890 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8891 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8892 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8893 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8894 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8902 c------------------------------------------------------------------------------
8903 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8905 C This subroutine calculates multi-body contributions to hydrogen-bonding
8906 implicit real*8 (a-h,o-z)
8907 include 'DIMENSIONS'
8908 include 'COMMON.IOUNITS'
8911 parameter (max_cont=maxconts)
8912 parameter (max_dim=70)
8913 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8914 double precision zapas(max_dim,maxconts,max_fg_procs),
8915 & zapas_recv(max_dim,maxconts,max_fg_procs)
8916 common /przechowalnia/ zapas
8917 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8918 & status_array(MPI_STATUS_SIZE,maxconts*2)
8920 include 'COMMON.SETUP'
8921 include 'COMMON.FFIELD'
8922 include 'COMMON.DERIV'
8923 include 'COMMON.LOCAL'
8924 include 'COMMON.INTERACT'
8925 include 'COMMON.CONTACTS'
8926 include 'COMMON.CONTMAT'
8927 include 'COMMON.CORRMAT'
8928 include 'COMMON.CHAIN'
8929 include 'COMMON.CONTROL'
8930 include 'COMMON.SHIELD'
8931 double precision gx(3),gx1(3)
8932 integer num_cont_hb_old(maxres)
8934 double precision eello4,eello5,eelo6,eello_turn6
8935 external eello4,eello5,eello6,eello_turn6
8936 C Set lprn=.true. for debugging
8941 num_cont_hb_old(i)=num_cont_hb(i)
8945 if (nfgtasks.le.1) goto 30
8947 write (iout,'(a)') 'Contact function values before RECEIVE:'
8949 write (iout,'(2i3,50(1x,i2,f5.2))')
8950 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8951 & j=1,num_cont_hb(i))
8954 do i=1,ntask_cont_from
8957 do i=1,ntask_cont_to
8960 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8962 C Make the list of contacts to send to send to other procesors
8963 do i=iturn3_start,iturn3_end
8964 c write (iout,*) "make contact list turn3",i," num_cont",
8966 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8968 do i=iturn4_start,iturn4_end
8969 c write (iout,*) "make contact list turn4",i," num_cont",
8971 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8975 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8977 do j=1,num_cont_hb(i)
8980 iproc=iint_sent_local(k,jjc,ii)
8981 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8982 if (iproc.ne.0) then
8983 ncont_sent(iproc)=ncont_sent(iproc)+1
8984 nn=ncont_sent(iproc)
8986 zapas(2,nn,iproc)=jjc
8987 zapas(3,nn,iproc)=d_cont(j,i)
8991 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8996 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9004 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9015 & "Numbers of contacts to be sent to other processors",
9016 & (ncont_sent(i),i=1,ntask_cont_to)
9017 write (iout,*) "Contacts sent"
9018 do ii=1,ntask_cont_to
9020 iproc=itask_cont_to(ii)
9021 write (iout,*) nn," contacts to processor",iproc,
9022 & " of CONT_TO_COMM group"
9024 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9032 CorrelID1=nfgtasks+fg_rank+1
9034 C Receive the numbers of needed contacts from other processors
9035 do ii=1,ntask_cont_from
9036 iproc=itask_cont_from(ii)
9038 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9039 & FG_COMM,req(ireq),IERR)
9041 c write (iout,*) "IRECV ended"
9043 C Send the number of contacts needed by other processors
9044 do ii=1,ntask_cont_to
9045 iproc=itask_cont_to(ii)
9047 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9048 & FG_COMM,req(ireq),IERR)
9050 c write (iout,*) "ISEND ended"
9051 c write (iout,*) "number of requests (nn)",ireq
9054 & call MPI_Waitall(ireq,req,status_array,ierr)
9056 c & "Numbers of contacts to be received from other processors",
9057 c & (ncont_recv(i),i=1,ntask_cont_from)
9061 do ii=1,ntask_cont_from
9062 iproc=itask_cont_from(ii)
9064 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9065 c & " of CONT_TO_COMM group"
9069 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9070 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9071 c write (iout,*) "ireq,req",ireq,req(ireq)
9074 C Send the contacts to processors that need them
9075 do ii=1,ntask_cont_to
9076 iproc=itask_cont_to(ii)
9078 c write (iout,*) nn," contacts to processor",iproc,
9079 c & " of CONT_TO_COMM group"
9082 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9083 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9084 c write (iout,*) "ireq,req",ireq,req(ireq)
9086 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9090 c write (iout,*) "number of requests (contacts)",ireq
9091 c write (iout,*) "req",(req(i),i=1,4)
9094 & call MPI_Waitall(ireq,req,status_array,ierr)
9095 do iii=1,ntask_cont_from
9096 iproc=itask_cont_from(iii)
9099 write (iout,*) "Received",nn," contacts from processor",iproc,
9100 & " of CONT_FROM_COMM group"
9103 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9108 ii=zapas_recv(1,i,iii)
9109 c Flag the received contacts to prevent double-counting
9110 jj=-zapas_recv(2,i,iii)
9111 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9113 nnn=num_cont_hb(ii)+1
9116 d_cont(nnn,ii)=zapas_recv(3,i,iii)
9120 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9125 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9133 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9141 write (iout,'(a)') 'Contact function values after receive:'
9143 write (iout,'(2i3,50(1x,i3,5f6.3))')
9144 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9145 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9152 write (iout,'(a)') 'Contact function values:'
9154 write (iout,'(2i3,50(1x,i2,5f6.3))')
9155 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9156 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9162 C Remove the loop below after debugging !!!
9169 C Calculate the dipole-dipole interaction energies
9170 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9171 do i=iatel_s,iatel_e+1
9172 num_conti=num_cont_hb(i)
9181 C Calculate the local-electrostatic correlation terms
9182 c write (iout,*) "gradcorr5 in eello5 before loop"
9184 c write (iout,'(i5,3f10.5)')
9185 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9187 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9188 c write (iout,*) "corr loop i",i
9190 num_conti=num_cont_hb(i)
9191 num_conti1=num_cont_hb(i+1)
9198 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9199 c & ' jj=',jj,' kk=',kk
9200 c if (j1.eq.j+1 .or. j1.eq.j-1) then
9201 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9202 & .or. j.lt.0 .and. j1.gt.0) .and.
9203 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9204 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9205 C The system gains extra energy.
9207 sqd1=dsqrt(d_cont(jj,i))
9208 sqd2=dsqrt(d_cont(kk,i1))
9209 sred_geom = sqd1*sqd2
9210 IF (sred_geom.lt.cutoff_corr) THEN
9211 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9213 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9214 cd & ' jj=',jj,' kk=',kk
9215 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9216 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9218 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9219 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9222 cd write (iout,*) 'sred_geom=',sred_geom,
9223 cd & ' ekont=',ekont,' fprim=',fprimcont,
9224 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9225 cd write (iout,*) "g_contij",g_contij
9226 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9227 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9228 call calc_eello(i,jp,i+1,jp1,jj,kk)
9229 if (wcorr4.gt.0.0d0)
9230 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9231 CC & *fac_shield(i)**2*fac_shield(j)**2
9232 if (energy_dec.and.wcorr4.gt.0.0d0)
9233 1 write (iout,'(a6,4i5,0pf7.3)')
9234 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9235 c write (iout,*) "gradcorr5 before eello5"
9237 c write (iout,'(i5,3f10.5)')
9238 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9240 if (wcorr5.gt.0.0d0)
9241 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9242 c write (iout,*) "gradcorr5 after eello5"
9244 c write (iout,'(i5,3f10.5)')
9245 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9247 if (energy_dec.and.wcorr5.gt.0.0d0)
9248 1 write (iout,'(a6,4i5,0pf7.3)')
9249 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9250 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9251 cd write(2,*)'ijkl',i,jp,i+1,jp1
9252 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9253 & .or. wturn6.eq.0.0d0))then
9254 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9255 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9256 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9257 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9258 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9259 cd & 'ecorr6=',ecorr6
9260 cd write (iout,'(4e15.5)') sred_geom,
9261 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9262 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9263 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9264 else if (wturn6.gt.0.0d0
9265 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9266 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9267 eturn6=eturn6+eello_turn6(i,jj,kk)
9268 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9269 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9270 cd write (2,*) 'multibody_eello:eturn6',eturn6
9279 num_cont_hb(i)=num_cont_hb_old(i)
9281 c write (iout,*) "gradcorr5 in eello5"
9283 c write (iout,'(i5,3f10.5)')
9284 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9288 c------------------------------------------------------------------------------
9289 subroutine add_hb_contact_eello(ii,jj,itask)
9290 implicit real*8 (a-h,o-z)
9291 include "DIMENSIONS"
9292 include "COMMON.IOUNITS"
9295 parameter (max_cont=maxconts)
9296 parameter (max_dim=70)
9297 include "COMMON.CONTACTS"
9298 include 'COMMON.CONTMAT'
9299 include 'COMMON.CORRMAT'
9300 double precision zapas(max_dim,maxconts,max_fg_procs),
9301 & zapas_recv(max_dim,maxconts,max_fg_procs)
9302 common /przechowalnia/ zapas
9303 integer i,j,ii,jj,iproc,itask(4),nn
9304 c write (iout,*) "itask",itask
9307 if (iproc.gt.0) then
9308 do j=1,num_cont_hb(ii)
9310 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9312 ncont_sent(iproc)=ncont_sent(iproc)+1
9313 nn=ncont_sent(iproc)
9314 zapas(1,nn,iproc)=ii
9315 zapas(2,nn,iproc)=jjc
9316 zapas(3,nn,iproc)=d_cont(j,ii)
9320 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9325 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9333 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9345 c------------------------------------------------------------------------------
9346 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9347 implicit real*8 (a-h,o-z)
9348 include 'DIMENSIONS'
9349 include 'COMMON.IOUNITS'
9350 include 'COMMON.DERIV'
9351 include 'COMMON.INTERACT'
9352 include 'COMMON.CONTACTS'
9353 include 'COMMON.CONTMAT'
9354 include 'COMMON.CORRMAT'
9355 include 'COMMON.SHIELD'
9356 include 'COMMON.CONTROL'
9357 double precision gx(3),gx1(3)
9360 C print *,"wchodze",fac_shield(i),shield_mode
9368 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9370 C & fac_shield(i)**2*fac_shield(j)**2
9371 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9372 C Following 4 lines for diagnostics.
9377 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9378 c & 'Contacts ',i,j,
9379 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9380 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9382 C Calculate the multi-body contribution to energy.
9383 C ecorr=ecorr+ekont*ees
9384 C Calculate multi-body contributions to the gradient.
9385 coeffpees0pij=coeffp*ees0pij
9386 coeffmees0mij=coeffm*ees0mij
9387 coeffpees0pkl=coeffp*ees0pkl
9388 coeffmees0mkl=coeffm*ees0mkl
9390 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9391 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9392 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9393 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9394 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9395 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9396 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9397 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9398 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9399 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9400 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9401 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9402 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9403 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9404 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9405 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9406 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9407 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9408 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9409 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9410 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9411 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9412 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9413 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9414 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9419 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9420 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9421 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9422 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9427 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9428 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9429 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9430 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9433 c write (iout,*) "ehbcorr",ekont*ees
9434 C print *,ekont,ees,i,k
9436 C now gradient over shielding
9438 if (shield_mode.gt.0) then
9441 C print *,i,j,fac_shield(i),fac_shield(j),
9442 C &fac_shield(k),fac_shield(l)
9443 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9444 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9445 do ilist=1,ishield_list(i)
9446 iresshield=shield_list(ilist,i)
9448 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9450 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9452 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9453 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9457 do ilist=1,ishield_list(j)
9458 iresshield=shield_list(ilist,j)
9460 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9462 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9464 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9465 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9470 do ilist=1,ishield_list(k)
9471 iresshield=shield_list(ilist,k)
9473 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9475 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9477 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9478 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9482 do ilist=1,ishield_list(l)
9483 iresshield=shield_list(ilist,l)
9485 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9487 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9489 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9490 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9494 C print *,gshieldx(m,iresshield)
9496 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9497 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9498 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9499 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9500 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9501 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9502 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9503 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9505 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9506 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9507 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9508 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9509 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9510 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9511 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9512 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9520 C---------------------------------------------------------------------------
9521 subroutine dipole(i,j,jj)
9522 implicit real*8 (a-h,o-z)
9523 include 'DIMENSIONS'
9524 include 'COMMON.IOUNITS'
9525 include 'COMMON.CHAIN'
9526 include 'COMMON.FFIELD'
9527 include 'COMMON.DERIV'
9528 include 'COMMON.INTERACT'
9529 include 'COMMON.CONTACTS'
9530 include 'COMMON.CONTMAT'
9531 include 'COMMON.CORRMAT'
9532 include 'COMMON.TORSION'
9533 include 'COMMON.VAR'
9534 include 'COMMON.GEO'
9535 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9537 iti1 = itortyp(itype(i+1))
9538 if (j.lt.nres-1) then
9539 itj1 = itype2loc(itype(j+1))
9544 dipi(iii,1)=Ub2(iii,i)
9545 dipderi(iii)=Ub2der(iii,i)
9546 dipi(iii,2)=b1(iii,i+1)
9547 dipj(iii,1)=Ub2(iii,j)
9548 dipderj(iii)=Ub2der(iii,j)
9549 dipj(iii,2)=b1(iii,j+1)
9553 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9556 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9563 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9567 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9572 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9573 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9575 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9577 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9579 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9584 C---------------------------------------------------------------------------
9585 subroutine calc_eello(i,j,k,l,jj,kk)
9587 C This subroutine computes matrices and vectors needed to calculate
9588 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9590 implicit real*8 (a-h,o-z)
9591 include 'DIMENSIONS'
9592 include 'COMMON.IOUNITS'
9593 include 'COMMON.CHAIN'
9594 include 'COMMON.DERIV'
9595 include 'COMMON.INTERACT'
9596 include 'COMMON.CONTACTS'
9597 include 'COMMON.CONTMAT'
9598 include 'COMMON.CORRMAT'
9599 include 'COMMON.TORSION'
9600 include 'COMMON.VAR'
9601 include 'COMMON.GEO'
9602 include 'COMMON.FFIELD'
9603 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9604 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9607 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9608 cd & ' jj=',jj,' kk=',kk
9609 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9610 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9611 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9614 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9615 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9618 call transpose2(aa1(1,1),aa1t(1,1))
9619 call transpose2(aa2(1,1),aa2t(1,1))
9622 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9623 & aa1tder(1,1,lll,kkk))
9624 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9625 & aa2tder(1,1,lll,kkk))
9629 C parallel orientation of the two CA-CA-CA frames.
9631 iti=itype2loc(itype(i))
9635 itk1=itype2loc(itype(k+1))
9636 itj=itype2loc(itype(j))
9637 if (l.lt.nres-1) then
9638 itl1=itype2loc(itype(l+1))
9642 C A1 kernel(j+1) A2T
9644 cd write (iout,'(3f10.5,5x,3f10.5)')
9645 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9647 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9648 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9649 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9650 C Following matrices are needed only for 6-th order cumulants
9651 IF (wcorr6.gt.0.0d0) THEN
9652 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9653 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9654 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9655 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9656 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9657 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9658 & ADtEAderx(1,1,1,1,1,1))
9660 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9661 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9662 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9663 & ADtEA1derx(1,1,1,1,1,1))
9665 C End 6-th order cumulants
9668 cd write (2,*) 'In calc_eello6'
9670 cd write (2,*) 'iii=',iii
9672 cd write (2,*) 'kkk=',kkk
9674 cd write (2,'(3(2f10.5),5x)')
9675 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9680 call transpose2(EUgder(1,1,k),auxmat(1,1))
9681 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9682 call transpose2(EUg(1,1,k),auxmat(1,1))
9683 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9684 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9685 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9686 c in theta; to be sriten later.
9688 c call transpose2(gtEE(1,1,k),auxmat(1,1))
9689 c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9690 c call transpose2(EUg(1,1,k),auxmat(1,1))
9691 c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9696 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9697 & EAEAderx(1,1,lll,kkk,iii,1))
9701 C A1T kernel(i+1) A2
9702 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9703 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9704 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9705 C Following matrices are needed only for 6-th order cumulants
9706 IF (wcorr6.gt.0.0d0) THEN
9707 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9708 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9709 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9710 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9711 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9712 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9713 & ADtEAderx(1,1,1,1,1,2))
9714 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9715 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9716 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9717 & ADtEA1derx(1,1,1,1,1,2))
9719 C End 6-th order cumulants
9720 call transpose2(EUgder(1,1,l),auxmat(1,1))
9721 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9722 call transpose2(EUg(1,1,l),auxmat(1,1))
9723 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9724 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9728 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9729 & EAEAderx(1,1,lll,kkk,iii,2))
9734 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9735 C They are needed only when the fifth- or the sixth-order cumulants are
9737 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9738 call transpose2(AEA(1,1,1),auxmat(1,1))
9739 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9740 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9741 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9742 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9743 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9744 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9745 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9746 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9747 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9748 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9749 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9750 call transpose2(AEA(1,1,2),auxmat(1,1))
9751 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9752 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9753 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9754 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9755 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9756 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9757 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9758 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9759 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9760 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9761 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9762 C Calculate the Cartesian derivatives of the vectors.
9766 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9767 call matvec2(auxmat(1,1),b1(1,i),
9768 & AEAb1derx(1,lll,kkk,iii,1,1))
9769 call matvec2(auxmat(1,1),Ub2(1,i),
9770 & AEAb2derx(1,lll,kkk,iii,1,1))
9771 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9772 & AEAb1derx(1,lll,kkk,iii,2,1))
9773 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9774 & AEAb2derx(1,lll,kkk,iii,2,1))
9775 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9776 call matvec2(auxmat(1,1),b1(1,j),
9777 & AEAb1derx(1,lll,kkk,iii,1,2))
9778 call matvec2(auxmat(1,1),Ub2(1,j),
9779 & AEAb2derx(1,lll,kkk,iii,1,2))
9780 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9781 & AEAb1derx(1,lll,kkk,iii,2,2))
9782 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9783 & AEAb2derx(1,lll,kkk,iii,2,2))
9790 C Antiparallel orientation of the two CA-CA-CA frames.
9792 iti=itype2loc(itype(i))
9796 itk1=itype2loc(itype(k+1))
9797 itl=itype2loc(itype(l))
9798 itj=itype2loc(itype(j))
9799 if (j.lt.nres-1) then
9800 itj1=itype2loc(itype(j+1))
9804 C A2 kernel(j-1)T A1T
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.,EUg(1,1,j),EUgder(1,1,j),
9807 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9808 C Following matrices are needed only for 6-th order cumulants
9809 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9810 & j.eq.i+4 .and. l.eq.i+3)) THEN
9811 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9812 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9813 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9814 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9815 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9816 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9817 & ADtEAderx(1,1,1,1,1,1))
9818 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9819 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9820 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9821 & ADtEA1derx(1,1,1,1,1,1))
9823 C End 6-th order cumulants
9824 call transpose2(EUgder(1,1,k),auxmat(1,1))
9825 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9826 call transpose2(EUg(1,1,k),auxmat(1,1))
9827 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9828 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9832 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9833 & EAEAderx(1,1,lll,kkk,iii,1))
9837 C A2T kernel(i+1)T A1
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.,EUg(1,1,k),EUgder(1,1,k),
9840 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9841 C Following matrices are needed only for 6-th order cumulants
9842 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9843 & j.eq.i+4 .and. l.eq.i+3)) THEN
9844 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9845 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9846 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9847 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9848 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9849 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9850 & ADtEAderx(1,1,1,1,1,2))
9851 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9852 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9853 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9854 & ADtEA1derx(1,1,1,1,1,2))
9856 C End 6-th order cumulants
9857 call transpose2(EUgder(1,1,j),auxmat(1,1))
9858 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9859 call transpose2(EUg(1,1,j),auxmat(1,1))
9860 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9861 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9865 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9866 & EAEAderx(1,1,lll,kkk,iii,2))
9871 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9872 C They are needed only when the fifth- or the sixth-order cumulants are
9874 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9875 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9876 call transpose2(AEA(1,1,1),auxmat(1,1))
9877 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9878 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9879 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9880 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9881 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9882 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9883 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9884 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9885 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9886 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9887 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9888 call transpose2(AEA(1,1,2),auxmat(1,1))
9889 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9890 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9891 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9892 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9893 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9894 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9895 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9896 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9897 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9898 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9899 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9900 C Calculate the Cartesian derivatives of the vectors.
9904 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9905 call matvec2(auxmat(1,1),b1(1,i),
9906 & AEAb1derx(1,lll,kkk,iii,1,1))
9907 call matvec2(auxmat(1,1),Ub2(1,i),
9908 & AEAb2derx(1,lll,kkk,iii,1,1))
9909 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9910 & AEAb1derx(1,lll,kkk,iii,2,1))
9911 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9912 & AEAb2derx(1,lll,kkk,iii,2,1))
9913 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9914 call matvec2(auxmat(1,1),b1(1,l),
9915 & AEAb1derx(1,lll,kkk,iii,1,2))
9916 call matvec2(auxmat(1,1),Ub2(1,l),
9917 & AEAb2derx(1,lll,kkk,iii,1,2))
9918 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9919 & AEAb1derx(1,lll,kkk,iii,2,2))
9920 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9921 & AEAb2derx(1,lll,kkk,iii,2,2))
9930 C---------------------------------------------------------------------------
9931 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9932 & KK,KKderg,AKA,AKAderg,AKAderx)
9936 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9937 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9938 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9943 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9945 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9948 cd if (lprn) write (2,*) 'In kernel'
9950 cd if (lprn) write (2,*) 'kkk=',kkk
9952 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9953 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9955 cd write (2,*) 'lll=',lll
9956 cd write (2,*) 'iii=1'
9958 cd write (2,'(3(2f10.5),5x)')
9959 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9962 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9963 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9965 cd write (2,*) 'lll=',lll
9966 cd write (2,*) 'iii=2'
9968 cd write (2,'(3(2f10.5),5x)')
9969 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9976 C---------------------------------------------------------------------------
9977 double precision function eello4(i,j,k,l,jj,kk)
9978 implicit real*8 (a-h,o-z)
9979 include 'DIMENSIONS'
9980 include 'COMMON.IOUNITS'
9981 include 'COMMON.CHAIN'
9982 include 'COMMON.DERIV'
9983 include 'COMMON.INTERACT'
9984 include 'COMMON.CONTACTS'
9985 include 'COMMON.CONTMAT'
9986 include 'COMMON.CORRMAT'
9987 include 'COMMON.TORSION'
9988 include 'COMMON.VAR'
9989 include 'COMMON.GEO'
9990 double precision pizda(2,2),ggg1(3),ggg2(3)
9991 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9995 cd print *,'eello4:',i,j,k,l,jj,kk
9996 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
9997 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
9998 cold eij=facont_hb(jj,i)
9999 cold ekl=facont_hb(kk,k)
10001 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10002 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10003 gcorr_loc(k-1)=gcorr_loc(k-1)
10004 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10006 gcorr_loc(l-1)=gcorr_loc(l-1)
10007 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10008 C Al 4/16/16: Derivatives in theta, to be added later.
10010 c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10011 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10014 gcorr_loc(j-1)=gcorr_loc(j-1)
10015 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10017 c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10018 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10024 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10025 & -EAEAderx(2,2,lll,kkk,iii,1)
10026 cd derx(lll,kkk,iii)=0.0d0
10030 cd gcorr_loc(l-1)=0.0d0
10031 cd gcorr_loc(j-1)=0.0d0
10032 cd gcorr_loc(k-1)=0.0d0
10034 cd write (iout,*)'Contacts have occurred for peptide groups',
10035 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
10036 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10037 if (j.lt.nres-1) then
10044 if (l.lt.nres-1) then
10052 cgrad ggg1(ll)=eel4*g_contij(ll,1)
10053 cgrad ggg2(ll)=eel4*g_contij(ll,2)
10054 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10055 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10056 cgrad ghalf=0.5d0*ggg1(ll)
10057 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10058 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10059 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10060 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10061 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10062 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10063 cgrad ghalf=0.5d0*ggg2(ll)
10064 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10065 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10066 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10067 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10068 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10069 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10073 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10078 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10083 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10088 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10092 cd write (2,*) iii,gcorr_loc(iii)
10095 cd write (2,*) 'ekont',ekont
10096 cd write (iout,*) 'eello4',ekont*eel4
10099 C---------------------------------------------------------------------------
10100 double precision function eello5(i,j,k,l,jj,kk)
10101 implicit real*8 (a-h,o-z)
10102 include 'DIMENSIONS'
10103 include 'COMMON.IOUNITS'
10104 include 'COMMON.CHAIN'
10105 include 'COMMON.DERIV'
10106 include 'COMMON.INTERACT'
10107 include 'COMMON.CONTACTS'
10108 include 'COMMON.CONTMAT'
10109 include 'COMMON.CORRMAT'
10110 include 'COMMON.TORSION'
10111 include 'COMMON.VAR'
10112 include 'COMMON.GEO'
10113 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10114 double precision ggg1(3),ggg2(3)
10115 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10117 C Parallel chains C
10120 C /l\ / \ \ / \ / \ / C
10121 C / \ / \ \ / \ / \ / C
10122 C j| o |l1 | o | o| o | | o |o C
10123 C \ |/k\| |/ \| / |/ \| |/ \| C
10124 C \i/ \ / \ / / \ / \ C
10126 C (I) (II) (III) (IV) C
10128 C eello5_1 eello5_2 eello5_3 eello5_4 C
10130 C Antiparallel chains C
10133 C /j\ / \ \ / \ / \ / C
10134 C / \ / \ \ / \ / \ / C
10135 C j1| o |l | o | o| o | | o |o C
10136 C \ |/k\| |/ \| / |/ \| |/ \| C
10137 C \i/ \ / \ / / \ / \ C
10139 C (I) (II) (III) (IV) C
10141 C eello5_1 eello5_2 eello5_3 eello5_4 C
10143 C o denotes a local interaction, vertical lines an electrostatic interaction. C
10145 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10146 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10151 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
10153 itk=itype2loc(itype(k))
10154 itl=itype2loc(itype(l))
10155 itj=itype2loc(itype(j))
10160 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10161 cd & eel5_3_num,eel5_4_num)
10165 derx(lll,kkk,iii)=0.0d0
10169 cd eij=facont_hb(jj,i)
10170 cd ekl=facont_hb(kk,k)
10172 cd write (iout,*)'Contacts have occurred for peptide groups',
10173 cd & i,j,' fcont:',eij,' eij',' and ',k,l
10175 C Contribution from the graph I.
10176 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10177 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10178 call transpose2(EUg(1,1,k),auxmat(1,1))
10179 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10180 vv(1)=pizda(1,1)-pizda(2,2)
10181 vv(2)=pizda(1,2)+pizda(2,1)
10182 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10183 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10184 C Explicit gradient in virtual-dihedral angles.
10185 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10186 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10187 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10188 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10189 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10190 vv(1)=pizda(1,1)-pizda(2,2)
10191 vv(2)=pizda(1,2)+pizda(2,1)
10192 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10193 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10194 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10195 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10196 vv(1)=pizda(1,1)-pizda(2,2)
10197 vv(2)=pizda(1,2)+pizda(2,1)
10199 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10200 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10201 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10203 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10204 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10205 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10207 C Cartesian gradient
10211 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10213 vv(1)=pizda(1,1)-pizda(2,2)
10214 vv(2)=pizda(1,2)+pizda(2,1)
10215 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10216 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10217 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10223 C Contribution from graph II
10224 call transpose2(EE(1,1,k),auxmat(1,1))
10225 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10226 vv(1)=pizda(1,1)+pizda(2,2)
10227 vv(2)=pizda(2,1)-pizda(1,2)
10228 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10229 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10230 C Explicit gradient in virtual-dihedral angles.
10231 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10232 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10233 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10234 vv(1)=pizda(1,1)+pizda(2,2)
10235 vv(2)=pizda(2,1)-pizda(1,2)
10237 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10238 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10239 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10241 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10242 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10243 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10245 C Cartesian gradient
10249 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10251 vv(1)=pizda(1,1)+pizda(2,2)
10252 vv(2)=pizda(2,1)-pizda(1,2)
10253 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10254 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10255 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10263 C Parallel orientation
10264 C Contribution from graph III
10265 call transpose2(EUg(1,1,l),auxmat(1,1))
10266 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10267 vv(1)=pizda(1,1)-pizda(2,2)
10268 vv(2)=pizda(1,2)+pizda(2,1)
10269 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10270 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10271 C Explicit gradient in virtual-dihedral angles.
10272 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10273 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10274 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10275 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10276 vv(1)=pizda(1,1)-pizda(2,2)
10277 vv(2)=pizda(1,2)+pizda(2,1)
10278 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10279 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10280 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10281 call transpose2(EUgder(1,1,l),auxmat1(1,1))
10282 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10283 vv(1)=pizda(1,1)-pizda(2,2)
10284 vv(2)=pizda(1,2)+pizda(2,1)
10285 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10286 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10287 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10288 C Cartesian gradient
10292 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10294 vv(1)=pizda(1,1)-pizda(2,2)
10295 vv(2)=pizda(1,2)+pizda(2,1)
10296 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10297 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10298 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10303 C Contribution from graph IV
10305 call transpose2(EE(1,1,l),auxmat(1,1))
10306 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10307 vv(1)=pizda(1,1)+pizda(2,2)
10308 vv(2)=pizda(2,1)-pizda(1,2)
10309 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10310 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10311 C Explicit gradient in virtual-dihedral angles.
10312 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10313 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10314 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10315 vv(1)=pizda(1,1)+pizda(2,2)
10316 vv(2)=pizda(2,1)-pizda(1,2)
10317 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10318 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10319 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10320 C Cartesian gradient
10324 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10326 vv(1)=pizda(1,1)+pizda(2,2)
10327 vv(2)=pizda(2,1)-pizda(1,2)
10328 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10329 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10330 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10335 C Antiparallel orientation
10336 C Contribution from graph III
10338 call transpose2(EUg(1,1,j),auxmat(1,1))
10339 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10340 vv(1)=pizda(1,1)-pizda(2,2)
10341 vv(2)=pizda(1,2)+pizda(2,1)
10342 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10343 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10344 C Explicit gradient in virtual-dihedral angles.
10345 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10346 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10347 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10348 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10349 vv(1)=pizda(1,1)-pizda(2,2)
10350 vv(2)=pizda(1,2)+pizda(2,1)
10351 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10352 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10353 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10354 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10355 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10356 vv(1)=pizda(1,1)-pizda(2,2)
10357 vv(2)=pizda(1,2)+pizda(2,1)
10358 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10359 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10360 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10361 C Cartesian gradient
10365 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10367 vv(1)=pizda(1,1)-pizda(2,2)
10368 vv(2)=pizda(1,2)+pizda(2,1)
10369 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10370 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10371 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10376 C Contribution from graph IV
10378 call transpose2(EE(1,1,j),auxmat(1,1))
10379 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10380 vv(1)=pizda(1,1)+pizda(2,2)
10381 vv(2)=pizda(2,1)-pizda(1,2)
10382 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10383 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10384 C Explicit gradient in virtual-dihedral angles.
10385 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10386 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10387 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10388 vv(1)=pizda(1,1)+pizda(2,2)
10389 vv(2)=pizda(2,1)-pizda(1,2)
10390 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10391 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10392 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10393 C Cartesian gradient
10397 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10399 vv(1)=pizda(1,1)+pizda(2,2)
10400 vv(2)=pizda(2,1)-pizda(1,2)
10401 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10402 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10403 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10409 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10410 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10411 cd write (2,*) 'ijkl',i,j,k,l
10412 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10413 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10415 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10416 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10417 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10418 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10419 if (j.lt.nres-1) then
10426 if (l.lt.nres-1) then
10436 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10437 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10438 C summed up outside the subrouine as for the other subroutines
10439 C handling long-range interactions. The old code is commented out
10440 C with "cgrad" to keep track of changes.
10442 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10443 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10444 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10445 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10446 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10447 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10448 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10449 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10450 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10451 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10453 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10454 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10455 cgrad ghalf=0.5d0*ggg1(ll)
10457 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10458 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10459 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10460 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10461 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10462 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10463 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10464 cgrad ghalf=0.5d0*ggg2(ll)
10466 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10467 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10468 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10469 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10470 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10471 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10476 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10477 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10482 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10483 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10489 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10494 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10498 cd write (2,*) iii,g_corr5_loc(iii)
10501 cd write (2,*) 'ekont',ekont
10502 cd write (iout,*) 'eello5',ekont*eel5
10505 c--------------------------------------------------------------------------
10506 double precision function eello6(i,j,k,l,jj,kk)
10507 implicit real*8 (a-h,o-z)
10508 include 'DIMENSIONS'
10509 include 'COMMON.IOUNITS'
10510 include 'COMMON.CHAIN'
10511 include 'COMMON.DERIV'
10512 include 'COMMON.INTERACT'
10513 include 'COMMON.CONTACTS'
10514 include 'COMMON.CONTMAT'
10515 include 'COMMON.CORRMAT'
10516 include 'COMMON.TORSION'
10517 include 'COMMON.VAR'
10518 include 'COMMON.GEO'
10519 include 'COMMON.FFIELD'
10520 double precision ggg1(3),ggg2(3)
10521 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10526 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10534 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10535 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10539 derx(lll,kkk,iii)=0.0d0
10543 cd eij=facont_hb(jj,i)
10544 cd ekl=facont_hb(kk,k)
10550 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10551 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10552 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10553 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10554 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10555 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10557 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10558 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10559 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10560 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10561 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10562 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10566 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10568 C If turn contributions are considered, they will be handled separately.
10569 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10570 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10571 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10572 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10573 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10574 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10575 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10577 if (j.lt.nres-1) then
10584 if (l.lt.nres-1) then
10592 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10593 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10594 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10595 cgrad ghalf=0.5d0*ggg1(ll)
10597 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10598 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10599 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10600 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10601 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10602 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10603 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10604 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10605 cgrad ghalf=0.5d0*ggg2(ll)
10606 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10608 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10609 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10610 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10611 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10612 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10613 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10618 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10619 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10624 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10625 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10631 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10636 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10640 cd write (2,*) iii,g_corr6_loc(iii)
10643 cd write (2,*) 'ekont',ekont
10644 cd write (iout,*) 'eello6',ekont*eel6
10647 c--------------------------------------------------------------------------
10648 double precision function eello6_graph1(i,j,k,l,imat,swap)
10649 implicit real*8 (a-h,o-z)
10650 include 'DIMENSIONS'
10651 include 'COMMON.IOUNITS'
10652 include 'COMMON.CHAIN'
10653 include 'COMMON.DERIV'
10654 include 'COMMON.INTERACT'
10655 include 'COMMON.CONTACTS'
10656 include 'COMMON.CONTMAT'
10657 include 'COMMON.CORRMAT'
10658 include 'COMMON.TORSION'
10659 include 'COMMON.VAR'
10660 include 'COMMON.GEO'
10661 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10664 common /kutas/ lprn
10665 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10667 C Parallel Antiparallel C
10673 C \ j|/k\| / \ |/k\|l / C
10674 C \ / \ / \ / \ / C
10678 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10679 itk=itype2loc(itype(k))
10680 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10681 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10682 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10683 call transpose2(EUgC(1,1,k),auxmat(1,1))
10684 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10685 vv1(1)=pizda1(1,1)-pizda1(2,2)
10686 vv1(2)=pizda1(1,2)+pizda1(2,1)
10687 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10688 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10689 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10690 s5=scalar2(vv(1),Dtobr2(1,i))
10691 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10692 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10693 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10694 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10695 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10696 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10697 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10698 & +scalar2(vv(1),Dtobr2der(1,i)))
10699 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10700 vv1(1)=pizda1(1,1)-pizda1(2,2)
10701 vv1(2)=pizda1(1,2)+pizda1(2,1)
10702 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10703 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10705 g_corr6_loc(l-1)=g_corr6_loc(l-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 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10712 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10713 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10714 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10715 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10717 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10718 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10719 vv1(1)=pizda1(1,1)-pizda1(2,2)
10720 vv1(2)=pizda1(1,2)+pizda1(2,1)
10721 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10722 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10723 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10724 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10733 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10734 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10735 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10736 call transpose2(EUgC(1,1,k),auxmat(1,1))
10737 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10739 vv1(1)=pizda1(1,1)-pizda1(2,2)
10740 vv1(2)=pizda1(1,2)+pizda1(2,1)
10741 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10742 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10743 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10744 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10745 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10746 s5=scalar2(vv(1),Dtobr2(1,i))
10747 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10753 c----------------------------------------------------------------------------
10754 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10755 implicit real*8 (a-h,o-z)
10756 include 'DIMENSIONS'
10757 include 'COMMON.IOUNITS'
10758 include 'COMMON.CHAIN'
10759 include 'COMMON.DERIV'
10760 include 'COMMON.INTERACT'
10761 include 'COMMON.CONTACTS'
10762 include 'COMMON.CONTMAT'
10763 include 'COMMON.CORRMAT'
10764 include 'COMMON.TORSION'
10765 include 'COMMON.VAR'
10766 include 'COMMON.GEO'
10768 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10769 & auxvec1(2),auxvec2(2),auxmat1(2,2)
10771 common /kutas/ lprn
10772 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10774 C Parallel Antiparallel C
10780 C \ j|/k\| \ |/k\|l C
10785 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10786 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10787 C AL 7/4/01 s1 would occur in the sixth-order moment,
10788 C but not in a cluster cumulant
10790 s1=dip(1,jj,i)*dip(1,kk,k)
10792 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10793 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10794 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10795 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10796 call transpose2(EUg(1,1,k),auxmat(1,1))
10797 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10798 vv(1)=pizda(1,1)-pizda(2,2)
10799 vv(2)=pizda(1,2)+pizda(2,1)
10800 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10801 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10803 eello6_graph2=-(s1+s2+s3+s4)
10805 eello6_graph2=-(s2+s3+s4)
10807 c eello6_graph2=-s3
10808 C Derivatives in gamma(i-1)
10811 s1=dipderg(1,jj,i)*dip(1,kk,k)
10813 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10814 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10815 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10816 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10818 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10820 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10822 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10824 C Derivatives in gamma(k-1)
10826 s1=dip(1,jj,i)*dipderg(1,kk,k)
10828 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10829 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10830 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10831 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10832 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10833 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10834 vv(1)=pizda(1,1)-pizda(2,2)
10835 vv(2)=pizda(1,2)+pizda(2,1)
10836 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10838 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10840 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10842 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10843 C Derivatives in gamma(j-1) or gamma(l-1)
10846 s1=dipderg(3,jj,i)*dip(1,kk,k)
10848 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10849 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10850 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10851 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10852 vv(1)=pizda(1,1)-pizda(2,2)
10853 vv(2)=pizda(1,2)+pizda(2,1)
10854 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10857 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10859 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10862 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10863 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10865 C Derivatives in gamma(l-1) or gamma(j-1)
10868 s1=dip(1,jj,i)*dipderg(3,kk,k)
10870 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10871 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10872 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10873 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10874 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10875 vv(1)=pizda(1,1)-pizda(2,2)
10876 vv(2)=pizda(1,2)+pizda(2,1)
10877 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10880 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10882 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10885 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10886 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10888 C Cartesian derivatives.
10890 write (2,*) 'In eello6_graph2'
10892 write (2,*) 'iii=',iii
10894 write (2,*) 'kkk=',kkk
10896 write (2,'(3(2f10.5),5x)')
10897 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10907 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10909 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10912 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10914 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10915 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10917 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10918 call transpose2(EUg(1,1,k),auxmat(1,1))
10919 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10921 vv(1)=pizda(1,1)-pizda(2,2)
10922 vv(2)=pizda(1,2)+pizda(2,1)
10923 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10924 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10926 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10928 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10931 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10933 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10940 c----------------------------------------------------------------------------
10941 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10942 implicit real*8 (a-h,o-z)
10943 include 'DIMENSIONS'
10944 include 'COMMON.IOUNITS'
10945 include 'COMMON.CHAIN'
10946 include 'COMMON.DERIV'
10947 include 'COMMON.INTERACT'
10948 include 'COMMON.CONTACTS'
10949 include 'COMMON.CONTMAT'
10950 include 'COMMON.CORRMAT'
10951 include 'COMMON.TORSION'
10952 include 'COMMON.VAR'
10953 include 'COMMON.GEO'
10954 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10956 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10958 C Parallel Antiparallel C
10963 C /| o |o o| o |\ C
10964 C j|/k\| / |/k\|l / C
10969 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10971 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10972 C energy moment and not to the cluster cumulant.
10973 iti=itortyp(itype(i))
10974 if (j.lt.nres-1) then
10975 itj1=itype2loc(itype(j+1))
10979 itk=itype2loc(itype(k))
10980 itk1=itype2loc(itype(k+1))
10981 if (l.lt.nres-1) then
10982 itl1=itype2loc(itype(l+1))
10987 s1=dip(4,jj,i)*dip(4,kk,k)
10989 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10990 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10991 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10992 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10993 call transpose2(EE(1,1,k),auxmat(1,1))
10994 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10995 vv(1)=pizda(1,1)+pizda(2,2)
10996 vv(2)=pizda(2,1)-pizda(1,2)
10997 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10998 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10999 cd & "sum",-(s2+s3+s4)
11001 eello6_graph3=-(s1+s2+s3+s4)
11003 eello6_graph3=-(s2+s3+s4)
11005 c eello6_graph3=-s4
11006 C Derivatives in gamma(k-1)
11007 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11008 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11009 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11010 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11011 C Derivatives in gamma(l-1)
11012 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11013 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11014 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11015 vv(1)=pizda(1,1)+pizda(2,2)
11016 vv(2)=pizda(2,1)-pizda(1,2)
11017 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11018 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11019 C Cartesian derivatives.
11025 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11027 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11030 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11032 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11033 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11035 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11036 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11038 vv(1)=pizda(1,1)+pizda(2,2)
11039 vv(2)=pizda(2,1)-pizda(1,2)
11040 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11042 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11044 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11047 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11049 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11051 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11057 c----------------------------------------------------------------------------
11058 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11059 implicit real*8 (a-h,o-z)
11060 include 'DIMENSIONS'
11061 include 'COMMON.IOUNITS'
11062 include 'COMMON.CHAIN'
11063 include 'COMMON.DERIV'
11064 include 'COMMON.INTERACT'
11065 include 'COMMON.CONTACTS'
11066 include 'COMMON.CONTMAT'
11067 include 'COMMON.CORRMAT'
11068 include 'COMMON.TORSION'
11069 include 'COMMON.VAR'
11070 include 'COMMON.GEO'
11071 include 'COMMON.FFIELD'
11072 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11073 & auxvec1(2),auxmat1(2,2)
11075 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11077 C Parallel Antiparallel C
11082 C /| o |o o| o |\ C
11083 C \ j|/k\| \ |/k\|l C
11088 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11090 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11091 C energy moment and not to the cluster cumulant.
11092 cd write (2,*) 'eello_graph4: wturn6',wturn6
11093 iti=itype2loc(itype(i))
11094 itj=itype2loc(itype(j))
11095 if (j.lt.nres-1) then
11096 itj1=itype2loc(itype(j+1))
11100 itk=itype2loc(itype(k))
11101 if (k.lt.nres-1) then
11102 itk1=itype2loc(itype(k+1))
11106 itl=itype2loc(itype(l))
11107 if (l.lt.nres-1) then
11108 itl1=itype2loc(itype(l+1))
11112 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11113 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11114 cd & ' itl',itl,' itl1',itl1
11116 if (imat.eq.1) then
11117 s1=dip(3,jj,i)*dip(3,kk,k)
11119 s1=dip(2,jj,j)*dip(2,kk,l)
11122 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11123 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11125 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11126 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11128 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11129 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11131 call transpose2(EUg(1,1,k),auxmat(1,1))
11132 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11133 vv(1)=pizda(1,1)-pizda(2,2)
11134 vv(2)=pizda(2,1)+pizda(1,2)
11135 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11136 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11138 eello6_graph4=-(s1+s2+s3+s4)
11140 eello6_graph4=-(s2+s3+s4)
11142 C Derivatives in gamma(i-1)
11145 if (imat.eq.1) then
11146 s1=dipderg(2,jj,i)*dip(3,kk,k)
11148 s1=dipderg(4,jj,j)*dip(2,kk,l)
11151 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11153 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11154 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11156 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11157 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11159 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11160 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11161 cd write (2,*) 'turn6 derivatives'
11163 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11165 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11169 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11171 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11175 C Derivatives in gamma(k-1)
11177 if (imat.eq.1) then
11178 s1=dip(3,jj,i)*dipderg(2,kk,k)
11180 s1=dip(2,jj,j)*dipderg(4,kk,l)
11183 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11184 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11186 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11187 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11189 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11190 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11192 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11193 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11194 vv(1)=pizda(1,1)-pizda(2,2)
11195 vv(2)=pizda(2,1)+pizda(1,2)
11196 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11197 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11199 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11201 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11205 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11207 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11210 C Derivatives in gamma(j-1) or gamma(l-1)
11211 if (l.eq.j+1 .and. l.gt.1) then
11212 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11213 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11214 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11215 vv(1)=pizda(1,1)-pizda(2,2)
11216 vv(2)=pizda(2,1)+pizda(1,2)
11217 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11218 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11219 else if (j.gt.1) then
11220 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11221 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11222 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11223 vv(1)=pizda(1,1)-pizda(2,2)
11224 vv(2)=pizda(2,1)+pizda(1,2)
11225 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11226 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11227 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11229 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11232 C Cartesian derivatives.
11238 if (imat.eq.1) then
11239 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11241 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11244 if (imat.eq.1) then
11245 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11247 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11251 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11253 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11255 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11256 & b1(1,j+1),auxvec(1))
11257 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11259 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11260 & b1(1,l+1),auxvec(1))
11261 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11263 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11265 vv(1)=pizda(1,1)-pizda(2,2)
11266 vv(2)=pizda(2,1)+pizda(1,2)
11267 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11269 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11271 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11274 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11277 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11280 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11282 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11284 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11288 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11290 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11293 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11295 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11303 c----------------------------------------------------------------------------
11304 double precision function eello_turn6(i,jj,kk)
11305 implicit real*8 (a-h,o-z)
11306 include 'DIMENSIONS'
11307 include 'COMMON.IOUNITS'
11308 include 'COMMON.CHAIN'
11309 include 'COMMON.DERIV'
11310 include 'COMMON.INTERACT'
11311 include 'COMMON.CONTACTS'
11312 include 'COMMON.CONTMAT'
11313 include 'COMMON.CORRMAT'
11314 include 'COMMON.TORSION'
11315 include 'COMMON.VAR'
11316 include 'COMMON.GEO'
11317 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11318 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11320 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11321 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11322 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11323 C the respective energy moment and not to the cluster cumulant.
11332 iti=itype2loc(itype(i))
11333 itk=itype2loc(itype(k))
11334 itk1=itype2loc(itype(k+1))
11335 itl=itype2loc(itype(l))
11336 itj=itype2loc(itype(j))
11337 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11338 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11339 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11344 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11346 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11350 derx_turn(lll,kkk,iii)=0.0d0
11357 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11359 cd write (2,*) 'eello6_5',eello6_5
11361 call transpose2(AEA(1,1,1),auxmat(1,1))
11362 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11363 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11364 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11366 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11367 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11368 s2 = scalar2(b1(1,k),vtemp1(1))
11370 call transpose2(AEA(1,1,2),atemp(1,1))
11371 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11372 call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11373 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11375 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11376 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11377 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11379 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11380 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11381 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11382 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11383 ss13 = scalar2(b1(1,k),vtemp4(1))
11384 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11386 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11392 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11393 C Derivatives in gamma(i+2)
11397 call transpose2(AEA(1,1,1),auxmatd(1,1))
11398 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11399 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11400 call transpose2(AEAderg(1,1,2),atempd(1,1))
11401 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11402 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11404 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11405 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11406 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11412 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11413 C Derivatives in gamma(i+3)
11415 call transpose2(AEA(1,1,1),auxmatd(1,1))
11416 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11417 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11418 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11420 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11421 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11422 s2d = scalar2(b1(1,k),vtemp1d(1))
11424 call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11425 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11427 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11429 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11430 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11431 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11439 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11440 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11442 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11443 & -0.5d0*ekont*(s2d+s12d)
11445 C Derivatives in gamma(i+4)
11446 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11447 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11448 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11450 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11451 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11452 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11460 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11462 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11464 C Derivatives in gamma(i+5)
11466 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11467 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11468 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11470 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11471 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11472 s2d = scalar2(b1(1,k),vtemp1d(1))
11474 call transpose2(AEA(1,1,2),atempd(1,1))
11475 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11476 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11478 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11479 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11481 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11482 ss13d = scalar2(b1(1,k),vtemp4d(1))
11483 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11491 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11492 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11494 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11495 & -0.5d0*ekont*(s2d+s12d)
11497 C Cartesian derivatives
11502 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11503 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11504 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11506 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11507 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11509 s2d = scalar2(b1(1,k),vtemp1d(1))
11511 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11512 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11513 s8d = -(atempd(1,1)+atempd(2,2))*
11514 & scalar2(cc(1,1,l),vtemp2(1))
11516 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11518 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11519 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11526 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11527 & - 0.5d0*(s1d+s2d)
11529 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11533 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11534 & - 0.5d0*(s8d+s12d)
11536 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11545 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11546 & achuj_tempd(1,1))
11547 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11548 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11549 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11550 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11551 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11553 ss13d = scalar2(b1(1,k),vtemp4d(1))
11554 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11555 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11559 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11560 cd & 16*eel_turn6_num
11562 if (j.lt.nres-1) then
11569 if (l.lt.nres-1) then
11577 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11578 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11579 cgrad ghalf=0.5d0*ggg1(ll)
11581 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11582 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11583 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11584 & +ekont*derx_turn(ll,2,1)
11585 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11586 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11587 & +ekont*derx_turn(ll,4,1)
11588 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11589 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11590 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11591 cgrad ghalf=0.5d0*ggg2(ll)
11593 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11594 & +ekont*derx_turn(ll,2,2)
11595 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11596 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11597 & +ekont*derx_turn(ll,4,2)
11598 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11599 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11600 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11605 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11610 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11616 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11621 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11625 cd write (2,*) iii,g_corr6_loc(iii)
11627 eello_turn6=ekont*eel_turn6
11628 cd write (2,*) 'ekont',ekont
11629 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11632 C-----------------------------------------------------------------------------
11634 double precision function scalar(u,v)
11635 !DIR$ INLINEALWAYS scalar
11637 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11640 double precision u(3),v(3)
11641 cd double precision sc
11649 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11652 crc-------------------------------------------------
11653 SUBROUTINE MATVEC2(A1,V1,V2)
11654 !DIR$ INLINEALWAYS MATVEC2
11656 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11658 implicit real*8 (a-h,o-z)
11659 include 'DIMENSIONS'
11660 DIMENSION A1(2,2),V1(2),V2(2)
11664 c 3 VI=VI+A1(I,K)*V1(K)
11668 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11669 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11674 C---------------------------------------
11675 SUBROUTINE MATMAT2(A1,A2,A3)
11677 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11679 implicit real*8 (a-h,o-z)
11680 include 'DIMENSIONS'
11681 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11682 c DIMENSION AI3(2,2)
11686 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11692 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11693 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11694 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11695 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11703 c-------------------------------------------------------------------------
11704 double precision function scalar2(u,v)
11705 !DIR$ INLINEALWAYS scalar2
11707 double precision u(2),v(2)
11708 double precision sc
11710 scalar2=u(1)*v(1)+u(2)*v(2)
11714 C-----------------------------------------------------------------------------
11716 subroutine transpose2(a,at)
11717 !DIR$ INLINEALWAYS transpose2
11719 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11722 double precision a(2,2),at(2,2)
11729 c--------------------------------------------------------------------------
11730 subroutine transpose(n,a,at)
11733 double precision a(n,n),at(n,n)
11741 C---------------------------------------------------------------------------
11742 subroutine prodmat3(a1,a2,kk,transp,prod)
11743 !DIR$ INLINEALWAYS prodmat3
11745 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11749 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11751 crc double precision auxmat(2,2),prod_(2,2)
11754 crc call transpose2(kk(1,1),auxmat(1,1))
11755 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11756 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11758 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11759 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11760 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11761 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11762 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11763 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11764 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11765 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11768 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11769 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11771 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11772 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11773 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11774 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11775 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11776 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11777 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11778 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11781 c call transpose2(a2(1,1),a2t(1,1))
11784 crc print *,((prod_(i,j),i=1,2),j=1,2)
11785 crc print *,((prod(i,j),i=1,2),j=1,2)
11789 CCC----------------------------------------------
11790 subroutine Eliptransfer(eliptran)
11791 implicit real*8 (a-h,o-z)
11792 include 'DIMENSIONS'
11793 include 'COMMON.GEO'
11794 include 'COMMON.VAR'
11795 include 'COMMON.LOCAL'
11796 include 'COMMON.CHAIN'
11797 include 'COMMON.DERIV'
11798 include 'COMMON.NAMES'
11799 include 'COMMON.INTERACT'
11800 include 'COMMON.IOUNITS'
11801 include 'COMMON.CALC'
11802 include 'COMMON.CONTROL'
11803 include 'COMMON.SPLITELE'
11804 include 'COMMON.SBRIDGE'
11805 C this is done by Adasko
11806 C print *,"wchodze"
11807 C structure of box:
11809 C--bordliptop-- buffore starts
11810 C--bufliptop--- here true lipid starts
11812 C--buflipbot--- lipid ends buffore starts
11813 C--bordlipbot--buffore ends
11815 do i=ilip_start,ilip_end
11817 if (itype(i).eq.ntyp1) cycle
11819 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11820 if (positi.le.0.0) positi=positi+boxzsize
11822 C first for peptide groups
11823 c for each residue check if it is in lipid or lipid water border area
11824 if ((positi.gt.bordlipbot)
11825 &.and.(positi.lt.bordliptop)) then
11826 C the energy transfer exist
11827 if (positi.lt.buflipbot) then
11828 C what fraction I am in
11830 & ((positi-bordlipbot)/lipbufthick)
11831 C lipbufthick is thickenes of lipid buffore
11832 sslip=sscalelip(fracinbuf)
11833 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11834 eliptran=eliptran+sslip*pepliptran
11835 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11836 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11837 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11839 C print *,"doing sccale for lower part"
11840 C print *,i,sslip,fracinbuf,ssgradlip
11841 elseif (positi.gt.bufliptop) then
11842 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11843 sslip=sscalelip(fracinbuf)
11844 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11845 eliptran=eliptran+sslip*pepliptran
11846 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11847 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11848 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11849 C print *, "doing sscalefor top part"
11850 C print *,i,sslip,fracinbuf,ssgradlip
11852 eliptran=eliptran+pepliptran
11853 C print *,"I am in true lipid"
11856 C eliptran=elpitran+0.0 ! I am in water
11859 C print *, "nic nie bylo w lipidzie?"
11860 C now multiply all by the peptide group transfer factor
11861 C eliptran=eliptran*pepliptran
11862 C now the same for side chains
11864 do i=ilip_start,ilip_end
11865 if (itype(i).eq.ntyp1) cycle
11866 positi=(mod(c(3,i+nres),boxzsize))
11867 if (positi.le.0) positi=positi+boxzsize
11868 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11869 c for each residue check if it is in lipid or lipid water border area
11870 C respos=mod(c(3,i+nres),boxzsize)
11871 C print *,positi,bordlipbot,buflipbot
11872 if ((positi.gt.bordlipbot)
11873 & .and.(positi.lt.bordliptop)) then
11874 C the energy transfer exist
11875 if (positi.lt.buflipbot) then
11877 & ((positi-bordlipbot)/lipbufthick)
11878 C lipbufthick is thickenes of lipid buffore
11879 sslip=sscalelip(fracinbuf)
11880 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11881 eliptran=eliptran+sslip*liptranene(itype(i))
11882 gliptranx(3,i)=gliptranx(3,i)
11883 &+ssgradlip*liptranene(itype(i))
11884 gliptranc(3,i-1)= gliptranc(3,i-1)
11885 &+ssgradlip*liptranene(itype(i))
11886 C print *,"doing sccale for lower part"
11887 elseif (positi.gt.bufliptop) then
11889 &((bordliptop-positi)/lipbufthick)
11890 sslip=sscalelip(fracinbuf)
11891 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11892 eliptran=eliptran+sslip*liptranene(itype(i))
11893 gliptranx(3,i)=gliptranx(3,i)
11894 &+ssgradlip*liptranene(itype(i))
11895 gliptranc(3,i-1)= gliptranc(3,i-1)
11896 &+ssgradlip*liptranene(itype(i))
11897 C print *, "doing sscalefor top part",sslip,fracinbuf
11899 eliptran=eliptran+liptranene(itype(i))
11900 C print *,"I am in true lipid"
11902 endif ! if in lipid or buffor
11904 C eliptran=elpitran+0.0 ! I am in water
11908 C---------------------------------------------------------
11909 C AFM soubroutine for constant force
11910 subroutine AFMforce(Eafmforce)
11911 implicit real*8 (a-h,o-z)
11912 include 'DIMENSIONS'
11913 include 'COMMON.GEO'
11914 include 'COMMON.VAR'
11915 include 'COMMON.LOCAL'
11916 include 'COMMON.CHAIN'
11917 include 'COMMON.DERIV'
11918 include 'COMMON.NAMES'
11919 include 'COMMON.INTERACT'
11920 include 'COMMON.IOUNITS'
11921 include 'COMMON.CALC'
11922 include 'COMMON.CONTROL'
11923 include 'COMMON.SPLITELE'
11924 include 'COMMON.SBRIDGE'
11929 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11930 dist=dist+diffafm(i)**2
11933 Eafmforce=-forceAFMconst*(dist-distafminit)
11935 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11936 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11938 C print *,'AFM',Eafmforce
11941 C---------------------------------------------------------
11942 C AFM subroutine with pseudoconstant velocity
11943 subroutine AFMvel(Eafmforce)
11944 implicit real*8 (a-h,o-z)
11945 include 'DIMENSIONS'
11946 include 'COMMON.GEO'
11947 include 'COMMON.VAR'
11948 include 'COMMON.LOCAL'
11949 include 'COMMON.CHAIN'
11950 include 'COMMON.DERIV'
11951 include 'COMMON.NAMES'
11952 include 'COMMON.INTERACT'
11953 include 'COMMON.IOUNITS'
11954 include 'COMMON.CALC'
11955 include 'COMMON.CONTROL'
11956 include 'COMMON.SPLITELE'
11957 include 'COMMON.SBRIDGE'
11959 C Only for check grad COMMENT if not used for checkgrad
11961 C--------------------------------------------------------
11962 C print *,"wchodze"
11966 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11967 dist=dist+diffafm(i)**2
11970 Eafmforce=0.5d0*forceAFMconst
11971 & *(distafminit+totTafm*velAFMconst-dist)**2
11972 C Eafmforce=-forceAFMconst*(dist-distafminit)
11974 gradafm(i,afmend-1)=-forceAFMconst*
11975 &(distafminit+totTafm*velAFMconst-dist)
11977 gradafm(i,afmbeg-1)=forceAFMconst*
11978 &(distafminit+totTafm*velAFMconst-dist)
11981 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11984 C-----------------------------------------------------------
11985 C first for shielding is setting of function of side-chains
11986 subroutine set_shield_fac
11987 implicit real*8 (a-h,o-z)
11988 include 'DIMENSIONS'
11989 include 'COMMON.CHAIN'
11990 include 'COMMON.DERIV'
11991 include 'COMMON.IOUNITS'
11992 include 'COMMON.SHIELD'
11993 include 'COMMON.INTERACT'
11994 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11995 double precision div77_81/0.974996043d0/,
11996 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11998 C the vector between center of side_chain and peptide group
11999 double precision pep_side(3),long,side_calf(3),
12000 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12001 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12002 C the line belowe needs to be changed for FGPROC>1
12004 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12006 Cif there two consequtive dummy atoms there is no peptide group between them
12007 C the line below has to be changed for FGPROC>1
12010 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12014 C first lets set vector conecting the ithe side-chain with kth side-chain
12015 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12016 C pep_side(j)=2.0d0
12017 C and vector conecting the side-chain with its proper calfa
12018 side_calf(j)=c(j,k+nres)-c(j,k)
12019 C side_calf(j)=2.0d0
12020 pept_group(j)=c(j,i)-c(j,i+1)
12021 C lets have their lenght
12022 dist_pep_side=pep_side(j)**2+dist_pep_side
12023 dist_side_calf=dist_side_calf+side_calf(j)**2
12024 dist_pept_group=dist_pept_group+pept_group(j)**2
12026 dist_pep_side=dsqrt(dist_pep_side)
12027 dist_pept_group=dsqrt(dist_pept_group)
12028 dist_side_calf=dsqrt(dist_side_calf)
12030 pep_side_norm(j)=pep_side(j)/dist_pep_side
12031 side_calf_norm(j)=dist_side_calf
12033 C now sscale fraction
12034 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12035 C print *,buff_shield,"buff"
12037 if (sh_frac_dist.le.0.0) cycle
12038 C If we reach here it means that this side chain reaches the shielding sphere
12039 C Lets add him to the list for gradient
12040 ishield_list(i)=ishield_list(i)+1
12041 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12042 C this list is essential otherwise problem would be O3
12043 shield_list(ishield_list(i),i)=k
12044 C Lets have the sscale value
12045 if (sh_frac_dist.gt.1.0) then
12046 scale_fac_dist=1.0d0
12048 sh_frac_dist_grad(j)=0.0d0
12051 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12052 & *(2.0*sh_frac_dist-3.0d0)
12053 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12054 & /dist_pep_side/buff_shield*0.5
12055 C remember for the final gradient multiply sh_frac_dist_grad(j)
12056 C for side_chain by factor -2 !
12058 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12059 C print *,"jestem",scale_fac_dist,fac_help_scale,
12060 C & sh_frac_dist_grad(j)
12063 C if ((i.eq.3).and.(k.eq.2)) then
12064 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12068 C this is what is now we have the distance scaling now volume...
12069 short=short_r_sidechain(itype(k))
12070 long=long_r_sidechain(itype(k))
12071 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12074 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12075 C costhet_fac=0.0d0
12077 costhet_grad(j)=costhet_fac*pep_side(j)
12079 C remember for the final gradient multiply costhet_grad(j)
12080 C for side_chain by factor -2 !
12081 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12082 C pep_side0pept_group is vector multiplication
12083 pep_side0pept_group=0.0
12085 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12087 cosalfa=(pep_side0pept_group/
12088 & (dist_pep_side*dist_side_calf))
12089 fac_alfa_sin=1.0-cosalfa**2
12090 fac_alfa_sin=dsqrt(fac_alfa_sin)
12091 rkprim=fac_alfa_sin*(long-short)+short
12093 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12094 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12097 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12098 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12099 &*(long-short)/fac_alfa_sin*cosalfa/
12100 &((dist_pep_side*dist_side_calf))*
12101 &((side_calf(j))-cosalfa*
12102 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12104 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12105 &*(long-short)/fac_alfa_sin*cosalfa
12106 &/((dist_pep_side*dist_side_calf))*
12108 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12111 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12114 C now the gradient...
12115 C grad_shield is gradient of Calfa for peptide groups
12116 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12118 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12119 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12121 grad_shield(j,i)=grad_shield(j,i)
12122 C gradient po skalowaniu
12123 & +(sh_frac_dist_grad(j)
12124 C gradient po costhet
12125 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12126 &-scale_fac_dist*(cosphi_grad_long(j))
12127 &/(1.0-cosphi) )*div77_81
12129 C grad_shield_side is Cbeta sidechain gradient
12130 grad_shield_side(j,ishield_list(i),i)=
12131 & (sh_frac_dist_grad(j)*(-2.0d0)
12132 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12133 & +scale_fac_dist*(cosphi_grad_long(j))
12134 & *2.0d0/(1.0-cosphi))
12135 & *div77_81*VofOverlap
12137 grad_shield_loc(j,ishield_list(i),i)=
12138 & scale_fac_dist*cosphi_grad_loc(j)
12139 & *2.0d0/(1.0-cosphi)
12140 & *div77_81*VofOverlap
12142 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12144 fac_shield(i)=VolumeTotal*div77_81+div4_81
12145 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12149 C--------------------------------------------------------------------------
12150 double precision function tschebyshev(m,n,x,y)
12152 include "DIMENSIONS"
12154 double precision x(n),y,yy(0:maxvar),aux
12155 c Tschebyshev polynomial. Note that the first term is omitted
12156 c m=0: the constant term is included
12157 c m=1: the constant term is not included
12161 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12170 C--------------------------------------------------------------------------
12171 double precision function gradtschebyshev(m,n,x,y)
12173 include "DIMENSIONS"
12175 double precision x(n+1),y,yy(0:maxvar),aux
12176 c Tschebyshev polynomial. Note that the first term is omitted
12177 c m=0: the constant term is included
12178 c m=1: the constant term is not included
12182 yy(i)=2*y*yy(i-1)-yy(i-2)
12186 aux=aux+x(i+1)*yy(i)*(i+1)
12187 C print *, x(i+1),yy(i),i
12189 gradtschebyshev=aux
12192 C------------------------------------------------------------------------
12193 C first for shielding is setting of function of side-chains
12194 subroutine set_shield_fac2
12195 implicit real*8 (a-h,o-z)
12196 include 'DIMENSIONS'
12197 include 'COMMON.CHAIN'
12198 include 'COMMON.DERIV'
12199 include 'COMMON.IOUNITS'
12200 include 'COMMON.SHIELD'
12201 include 'COMMON.INTERACT'
12202 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12203 double precision div77_81/0.974996043d0/,
12204 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12206 C the vector between center of side_chain and peptide group
12207 double precision pep_side(3),long,side_calf(3),
12208 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12209 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12210 C the line belowe needs to be changed for FGPROC>1
12212 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12214 Cif there two consequtive dummy atoms there is no peptide group between them
12215 C the line below has to be changed for FGPROC>1
12218 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12222 C first lets set vector conecting the ithe side-chain with kth side-chain
12223 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12224 C pep_side(j)=2.0d0
12225 C and vector conecting the side-chain with its proper calfa
12226 side_calf(j)=c(j,k+nres)-c(j,k)
12227 C side_calf(j)=2.0d0
12228 pept_group(j)=c(j,i)-c(j,i+1)
12229 C lets have their lenght
12230 dist_pep_side=pep_side(j)**2+dist_pep_side
12231 dist_side_calf=dist_side_calf+side_calf(j)**2
12232 dist_pept_group=dist_pept_group+pept_group(j)**2
12234 dist_pep_side=dsqrt(dist_pep_side)
12235 dist_pept_group=dsqrt(dist_pept_group)
12236 dist_side_calf=dsqrt(dist_side_calf)
12238 pep_side_norm(j)=pep_side(j)/dist_pep_side
12239 side_calf_norm(j)=dist_side_calf
12241 C now sscale fraction
12242 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12243 C print *,buff_shield,"buff"
12245 if (sh_frac_dist.le.0.0) cycle
12246 C If we reach here it means that this side chain reaches the shielding sphere
12247 C Lets add him to the list for gradient
12248 ishield_list(i)=ishield_list(i)+1
12249 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12250 C this list is essential otherwise problem would be O3
12251 shield_list(ishield_list(i),i)=k
12252 C Lets have the sscale value
12253 if (sh_frac_dist.gt.1.0) then
12254 scale_fac_dist=1.0d0
12256 sh_frac_dist_grad(j)=0.0d0
12259 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12260 & *(2.0d0*sh_frac_dist-3.0d0)
12261 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12262 & /dist_pep_side/buff_shield*0.5d0
12263 C remember for the final gradient multiply sh_frac_dist_grad(j)
12264 C for side_chain by factor -2 !
12266 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12267 C sh_frac_dist_grad(j)=0.0d0
12268 C scale_fac_dist=1.0d0
12269 C print *,"jestem",scale_fac_dist,fac_help_scale,
12270 C & sh_frac_dist_grad(j)
12273 C this is what is now we have the distance scaling now volume...
12274 short=short_r_sidechain(itype(k))
12275 long=long_r_sidechain(itype(k))
12276 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12277 sinthet=short/dist_pep_side*costhet
12281 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12282 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12283 C & -short/dist_pep_side**2/costhet)
12284 C costhet_fac=0.0d0
12286 costhet_grad(j)=costhet_fac*pep_side(j)
12288 C remember for the final gradient multiply costhet_grad(j)
12289 C for side_chain by factor -2 !
12290 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12291 C pep_side0pept_group is vector multiplication
12292 pep_side0pept_group=0.0d0
12294 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12296 cosalfa=(pep_side0pept_group/
12297 & (dist_pep_side*dist_side_calf))
12298 fac_alfa_sin=1.0d0-cosalfa**2
12299 fac_alfa_sin=dsqrt(fac_alfa_sin)
12300 rkprim=fac_alfa_sin*(long-short)+short
12304 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12306 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12307 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12308 & dist_pep_side**2)
12311 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12312 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12313 &*(long-short)/fac_alfa_sin*cosalfa/
12314 &((dist_pep_side*dist_side_calf))*
12315 &((side_calf(j))-cosalfa*
12316 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12317 C cosphi_grad_long(j)=0.0d0
12318 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12319 &*(long-short)/fac_alfa_sin*cosalfa
12320 &/((dist_pep_side*dist_side_calf))*
12322 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12323 C cosphi_grad_loc(j)=0.0d0
12325 C print *,sinphi,sinthet
12326 c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12327 c & VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12328 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12331 C now the gradient...
12333 grad_shield(j,i)=grad_shield(j,i)
12334 C gradient po skalowaniu
12335 & +(sh_frac_dist_grad(j)*VofOverlap
12336 C gradient po costhet
12337 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12338 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12339 & sinphi/sinthet*costhet*costhet_grad(j)
12340 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12342 C grad_shield_side is Cbeta sidechain gradient
12343 grad_shield_side(j,ishield_list(i),i)=
12344 & (sh_frac_dist_grad(j)*(-2.0d0)
12346 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12347 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12348 & sinphi/sinthet*costhet*costhet_grad(j)
12349 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12352 grad_shield_loc(j,ishield_list(i),i)=
12353 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12354 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12355 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12359 c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12361 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12363 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12364 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12365 c & " wshield",wshield
12366 c write(2,*) "TU",rpp(1,1),short,long,buff_shield
12370 C-----------------------------------------------------------------------
12371 C-----------------------------------------------------------
12372 C This subroutine is to mimic the histone like structure but as well can be
12373 C utilizet to nanostructures (infinit) small modification has to be used to
12374 C make it finite (z gradient at the ends has to be changes as well as the x,y
12375 C gradient has to be modified at the ends
12376 C The energy function is Kihara potential
12377 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12378 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12379 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12380 C simple Kihara potential
12381 subroutine calctube(Etube)
12382 implicit real*8 (a-h,o-z)
12383 include 'DIMENSIONS'
12384 include 'COMMON.GEO'
12385 include 'COMMON.VAR'
12386 include 'COMMON.LOCAL'
12387 include 'COMMON.CHAIN'
12388 include 'COMMON.DERIV'
12389 include 'COMMON.NAMES'
12390 include 'COMMON.INTERACT'
12391 include 'COMMON.IOUNITS'
12392 include 'COMMON.CALC'
12393 include 'COMMON.CONTROL'
12394 include 'COMMON.SPLITELE'
12395 include 'COMMON.SBRIDGE'
12396 double precision tub_r,vectube(3),enetube(maxres*2)
12401 C first we calculate the distance from tube center
12402 C first sugare-phosphate group for NARES this would be peptide group
12405 C lets ommit dummy atoms for now
12406 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12407 C now calculate distance from center of tube and direction vectors
12408 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12409 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12410 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12411 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12412 vectube(1)=vectube(1)-tubecenter(1)
12413 vectube(2)=vectube(2)-tubecenter(2)
12415 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12416 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12418 C as the tube is infinity we do not calculate the Z-vector use of Z
12421 C now calculte the distance
12422 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12423 C now normalize vector
12424 vectube(1)=vectube(1)/tub_r
12425 vectube(2)=vectube(2)/tub_r
12426 C calculte rdiffrence between r and r0
12429 rdiff6=rdiff**6.0d0
12430 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12431 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12432 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12433 C print *,rdiff,rdiff6,pep_aa_tube
12434 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12435 C now we calculate gradient
12436 fac=(-12.0d0*pep_aa_tube/rdiff6+
12437 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12438 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12441 C now direction of gg_tube vector
12443 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12444 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12447 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12449 C Lets not jump over memory as we use many times iti
12451 C lets ommit dummy atoms for now
12453 C in UNRES uncomment the line below as GLY has no side-chain...
12456 vectube(1)=c(1,i+nres)
12457 vectube(1)=mod(vectube(1),boxxsize)
12458 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12459 vectube(2)=c(2,i+nres)
12460 vectube(2)=mod(vectube(2),boxxsize)
12461 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12463 vectube(1)=vectube(1)-tubecenter(1)
12464 vectube(2)=vectube(2)-tubecenter(2)
12466 C as the tube is infinity we do not calculate the Z-vector use of Z
12469 C now calculte the distance
12470 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12471 C now normalize vector
12472 vectube(1)=vectube(1)/tub_r
12473 vectube(2)=vectube(2)/tub_r
12474 C calculte rdiffrence between r and r0
12477 rdiff6=rdiff**6.0d0
12478 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12479 sc_aa_tube=sc_aa_tube_par(iti)
12480 sc_bb_tube=sc_bb_tube_par(iti)
12481 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12482 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12483 C now we calculate gradient
12484 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12485 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12486 C now direction of gg_tube vector
12488 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12489 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12493 Etube=Etube+enetube(i)
12495 C print *,"ETUBE", etube
12498 C TO DO 1) add to total energy
12499 C 2) add to gradient summation
12500 C 3) add reading parameters (AND of course oppening of PARAM file)
12501 C 4) add reading the center of tube
12503 C 6) add to zerograd
12505 C-----------------------------------------------------------------------
12506 C-----------------------------------------------------------
12507 C This subroutine is to mimic the histone like structure but as well can be
12508 C utilizet to nanostructures (infinit) small modification has to be used to
12509 C make it finite (z gradient at the ends has to be changes as well as the x,y
12510 C gradient has to be modified at the ends
12511 C The energy function is Kihara potential
12512 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12513 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12514 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12515 C simple Kihara potential
12516 subroutine calctube2(Etube)
12517 implicit real*8 (a-h,o-z)
12518 include 'DIMENSIONS'
12519 include 'COMMON.GEO'
12520 include 'COMMON.VAR'
12521 include 'COMMON.LOCAL'
12522 include 'COMMON.CHAIN'
12523 include 'COMMON.DERIV'
12524 include 'COMMON.NAMES'
12525 include 'COMMON.INTERACT'
12526 include 'COMMON.IOUNITS'
12527 include 'COMMON.CALC'
12528 include 'COMMON.CONTROL'
12529 include 'COMMON.SPLITELE'
12530 include 'COMMON.SBRIDGE'
12531 double precision tub_r,vectube(3),enetube(maxres*2)
12536 C first we calculate the distance from tube center
12537 C first sugare-phosphate group for NARES this would be peptide group
12540 C lets ommit dummy atoms for now
12541 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12542 C now calculate distance from center of tube and direction vectors
12543 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12544 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12545 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12546 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12547 vectube(1)=vectube(1)-tubecenter(1)
12548 vectube(2)=vectube(2)-tubecenter(2)
12550 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12551 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12553 C as the tube is infinity we do not calculate the Z-vector use of Z
12556 C now calculte the distance
12557 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12558 C now normalize vector
12559 vectube(1)=vectube(1)/tub_r
12560 vectube(2)=vectube(2)/tub_r
12561 C calculte rdiffrence between r and r0
12564 rdiff6=rdiff**6.0d0
12565 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12566 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12567 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12568 C print *,rdiff,rdiff6,pep_aa_tube
12569 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12570 C now we calculate gradient
12571 fac=(-12.0d0*pep_aa_tube/rdiff6+
12572 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12573 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12576 C now direction of gg_tube vector
12578 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12579 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12582 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12584 C Lets not jump over memory as we use many times iti
12586 C lets ommit dummy atoms for now
12588 C in UNRES uncomment the line below as GLY has no side-chain...
12591 vectube(1)=c(1,i+nres)
12592 vectube(1)=mod(vectube(1),boxxsize)
12593 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12594 vectube(2)=c(2,i+nres)
12595 vectube(2)=mod(vectube(2),boxxsize)
12596 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12598 vectube(1)=vectube(1)-tubecenter(1)
12599 vectube(2)=vectube(2)-tubecenter(2)
12600 C THIS FRAGMENT MAKES TUBE FINITE
12601 positi=(mod(c(3,i+nres),boxzsize))
12602 if (positi.le.0) positi=positi+boxzsize
12603 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12604 c for each residue check if it is in lipid or lipid water border area
12605 C respos=mod(c(3,i+nres),boxzsize)
12606 print *,positi,bordtubebot,buftubebot,bordtubetop
12607 if ((positi.gt.bordtubebot)
12608 & .and.(positi.lt.bordtubetop)) then
12609 C the energy transfer exist
12610 if (positi.lt.buftubebot) then
12612 & ((positi-bordtubebot)/tubebufthick)
12613 C lipbufthick is thickenes of lipid buffore
12614 sstube=sscalelip(fracinbuf)
12615 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12616 print *,ssgradtube, sstube,tubetranene(itype(i))
12617 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12618 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12619 &+ssgradtube*tubetranene(itype(i))
12620 gg_tube(3,i-1)= gg_tube(3,i-1)
12621 &+ssgradtube*tubetranene(itype(i))
12622 C print *,"doing sccale for lower part"
12623 elseif (positi.gt.buftubetop) then
12625 &((bordtubetop-positi)/tubebufthick)
12626 sstube=sscalelip(fracinbuf)
12627 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12628 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12629 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12630 C &+ssgradtube*tubetranene(itype(i))
12631 C gg_tube(3,i-1)= gg_tube(3,i-1)
12632 C &+ssgradtube*tubetranene(itype(i))
12633 C print *, "doing sscalefor top part",sslip,fracinbuf
12637 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12638 C print *,"I am in true lipid"
12644 endif ! if in lipid or buffor
12645 CEND OF FINITE FRAGMENT
12646 C as the tube is infinity we do not calculate the Z-vector use of Z
12649 C now calculte the distance
12650 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12651 C now normalize vector
12652 vectube(1)=vectube(1)/tub_r
12653 vectube(2)=vectube(2)/tub_r
12654 C calculte rdiffrence between r and r0
12657 rdiff6=rdiff**6.0d0
12658 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12659 sc_aa_tube=sc_aa_tube_par(iti)
12660 sc_bb_tube=sc_bb_tube_par(iti)
12661 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12662 & *sstube+enetube(i+nres)
12663 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12664 C now we calculate gradient
12665 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12666 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12667 C now direction of gg_tube vector
12669 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12670 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12672 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12673 &+ssgradtube*enetube(i+nres)/sstube
12674 gg_tube(3,i-1)= gg_tube(3,i-1)
12675 &+ssgradtube*enetube(i+nres)/sstube
12679 Etube=Etube+enetube(i)
12681 C print *,"ETUBE", etube
12684 C TO DO 1) add to total energy
12685 C 2) add to gradient summation
12686 C 3) add reading parameters (AND of course oppening of PARAM file)
12687 C 4) add reading the center of tube
12689 C 6) add to zerograd
12690 c----------------------------------------------------------------------------
12691 subroutine e_saxs(Esaxs_constr)
12693 include 'DIMENSIONS'
12696 include "COMMON.SETUP"
12699 include 'COMMON.SBRIDGE'
12700 include 'COMMON.CHAIN'
12701 include 'COMMON.GEO'
12702 include 'COMMON.DERIV'
12703 include 'COMMON.LOCAL'
12704 include 'COMMON.INTERACT'
12705 include 'COMMON.VAR'
12706 include 'COMMON.IOUNITS'
12707 c include 'COMMON.MD'
12710 include 'COMMON.LANGEVIN.lang0.5diag'
12712 include 'COMMON.LANGEVIN.lang0'
12715 include 'COMMON.LANGEVIN'
12717 include 'COMMON.CONTROL'
12718 include 'COMMON.SAXS'
12719 include 'COMMON.NAMES'
12720 include 'COMMON.TIME1'
12721 include 'COMMON.FFIELD'
12723 double precision Esaxs_constr
12724 integer i,iint,j,k,l
12725 double precision PgradC(maxSAXS,3,maxres),
12726 & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12728 double precision PgradC_(maxSAXS,3,maxres),
12729 & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12731 double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12732 & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12733 & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12734 & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12735 double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12736 double precision dist,mygauss,mygaussder
12738 integer llicz,lllicz
12739 double precision time01
12740 c SAXS restraint penalty function
12742 write(iout,*) "------- SAXS penalty function start -------"
12743 write (iout,*) "nsaxs",nsaxs
12744 write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12745 write (iout,*) "Psaxs"
12747 write (iout,'(i5,e15.5)') i, Psaxs(i)
12753 Esaxs_constr = 0.0d0
12758 PgradC(k,l,j)=0.0d0
12759 PgradX(k,l,j)=0.0d0
12764 do i=iatsc_s,iatsc_e
12765 if (itype(i).eq.ntyp1) cycle
12766 do iint=1,nint_gr(i)
12767 do j=istart(i,iint),iend(i,iint)
12768 if (itype(j).eq.ntyp1) cycle
12771 dijCASC=dist(i,j+nres)
12772 dijSCCA=dist(i+nres,j)
12773 dijSCSC=dist(i+nres,j+nres)
12774 sigma2CACA=2.0d0/(pstok**2)
12775 sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12776 sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12777 sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12780 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12781 if (itype(j).ne.10) then
12782 expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12786 if (itype(i).ne.10) then
12787 expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12791 if (itype(i).ne.10 .and. itype(j).ne.10) then
12792 expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12796 Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12798 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12800 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12801 CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12802 SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12803 SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12806 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12807 PgradC(k,l,i) = PgradC(k,l,i)-aux
12808 PgradC(k,l,j) = PgradC(k,l,j)+aux
12810 if (itype(j).ne.10) then
12811 aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12812 PgradC(k,l,i) = PgradC(k,l,i)-aux
12813 PgradC(k,l,j) = PgradC(k,l,j)+aux
12814 PgradX(k,l,j) = PgradX(k,l,j)+aux
12817 if (itype(i).ne.10) then
12818 aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12819 PgradX(k,l,i) = PgradX(k,l,i)-aux
12820 PgradC(k,l,i) = PgradC(k,l,i)-aux
12821 PgradC(k,l,j) = PgradC(k,l,j)+aux
12824 if (itype(i).ne.10 .and. itype(j).ne.10) then
12825 aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12826 PgradC(k,l,i) = PgradC(k,l,i)-aux
12827 PgradC(k,l,j) = PgradC(k,l,j)+aux
12828 PgradX(k,l,i) = PgradX(k,l,i)-aux
12829 PgradX(k,l,j) = PgradX(k,l,j)+aux
12835 sigma2CACA=scal_rad**2*0.25d0/
12836 & (restok(itype(j))**2+restok(itype(i))**2)
12837 c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12838 c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12840 sigmaCACA=dsqrt(sigma2CACA)
12841 threesig=3.0d0/sigmaCACA
12845 if (dabs(dijCACA-dk).ge.threesig) cycle
12848 aux = sigmaCACA*(dijCACA-dk)
12849 expCACA = mygauss(aux)
12850 c if (expcaca.eq.0.0d0) cycle
12851 Pcalc(k) = Pcalc(k)+expCACA
12852 CACAgrad = -sigmaCACA*mygaussder(aux)
12853 c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12855 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12856 PgradC(k,l,i) = PgradC(k,l,i)-aux
12857 PgradC(k,l,j) = PgradC(k,l,j)+aux
12860 c write (iout,*) "i",i," j",j," llicz",llicz
12862 IF (saxs_cutoff.eq.0) THEN
12865 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12866 Pcalc(k) = Pcalc(k)+expCACA
12867 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12869 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12870 PgradC(k,l,i) = PgradC(k,l,i)-aux
12871 PgradC(k,l,j) = PgradC(k,l,j)+aux
12875 rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12878 c write (2,*) "ijk",i,j,k
12879 sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12880 if (sss2.eq.0.0d0) cycle
12881 ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12882 if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12883 & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12884 & 1.0d0/dsqrt(sigma2CACA),rrr,dk,
12886 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
12887 Pcalc(k) = Pcalc(k)+expCACA
12889 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12891 CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
12892 & ssgrad2*expCACA/sss2
12895 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12896 PgradC(k,l,i) = PgradC(k,l,i)+aux
12897 PgradC(k,l,j) = PgradC(k,l,j)-aux
12907 c time_SAXS=time_SAXS+MPI_Wtime()-time01
12909 c write (iout,*) "lllicz",lllicz
12911 c time01=MPI_Wtime()
12914 if (nfgtasks.gt.1) then
12915 call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
12916 & MPI_SUM,FG_COMM,IERR)
12917 c if (fg_rank.eq.king) then
12919 Pcalc(k) = Pcalc_(k)
12922 c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
12923 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12924 c if (fg_rank.eq.king) then
12928 c PgradC(k,l,i) = PgradC_(k,l,i)
12934 c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
12935 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12936 c if (fg_rank.eq.king) then
12940 c PgradX(k,l,i) = PgradX_(k,l,i)
12950 Cnorm = Cnorm + Pcalc(k)
12953 if (fg_rank.eq.king) then
12955 Esaxs_constr = dlog(Cnorm)-wsaxs0
12957 if (Pcalc(k).gt.0.0d0)
12958 & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
12960 write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
12964 write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
12979 & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
12980 auxC1 = auxC1+PgradC(k,l,i)
12982 auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
12983 auxX1 = auxX1+PgradX(k,l,i)
12986 gsaxsC(l,i) = auxC - auxC1/Cnorm
12988 gsaxsX(l,i) = auxX - auxX1/Cnorm
12990 c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
12991 c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
12992 c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
12993 c * " gradX",wsaxs*gsaxsX(l,i)
12997 time_SAXS=time_SAXS+MPI_Wtime()-time01
13000 write (iout,*) "gsaxsc"
13002 write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13010 c----------------------------------------------------------------------------
13011 subroutine e_saxsC(Esaxs_constr)
13013 include 'DIMENSIONS'
13016 include "COMMON.SETUP"
13019 include 'COMMON.SBRIDGE'
13020 include 'COMMON.CHAIN'
13021 include 'COMMON.GEO'
13022 include 'COMMON.DERIV'
13023 include 'COMMON.LOCAL'
13024 include 'COMMON.INTERACT'
13025 include 'COMMON.VAR'
13026 include 'COMMON.IOUNITS'
13027 c include 'COMMON.MD'
13030 include 'COMMON.LANGEVIN.lang0.5diag'
13032 include 'COMMON.LANGEVIN.lang0'
13035 include 'COMMON.LANGEVIN'
13037 include 'COMMON.CONTROL'
13038 include 'COMMON.SAXS'
13039 include 'COMMON.NAMES'
13040 include 'COMMON.TIME1'
13041 include 'COMMON.FFIELD'
13043 double precision Esaxs_constr
13044 integer i,iint,j,k,l
13045 double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13047 double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13049 double precision dk,dijCASPH,dijSCSPH,
13050 & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13051 & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13053 c SAXS restraint penalty function
13055 write(iout,*) "------- SAXS penalty function start -------"
13056 write (iout,*) "nsaxs",nsaxs
13059 print *,MyRank,"C",i,(C(j,i),j=1,3)
13062 print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13065 Esaxs_constr = 0.0d0
13067 do j=isaxs_start,isaxs_end
13076 if (itype(i).eq.ntyp1) cycle
13080 dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13082 if (itype(i).ne.10) then
13084 dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13087 sigma2CA=2.0d0/pstok**2
13088 sigma2SC=4.0d0/restok(itype(i))**2
13089 expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13090 expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13091 Pcalc = Pcalc+expCASPH+expSCSPH
13093 write(*,*) "processor i j Pcalc",
13094 & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13096 CASPHgrad = sigma2CA*expCASPH
13097 SCSPHgrad = sigma2SC*expSCSPH
13099 aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13100 PgradX(l,i) = PgradX(l,i) + aux
13101 PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13106 gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13107 gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13110 logPtot = logPtot - dlog(Pcalc)
13111 c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13112 c & " logPtot",logPtot
13115 if (nfgtasks.gt.1) then
13116 c write (iout,*) "logPtot before reduction",logPtot
13117 call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13118 & MPI_SUM,king,FG_COMM,IERR)
13120 c write (iout,*) "logPtot after reduction",logPtot
13121 call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13122 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13123 if (fg_rank.eq.king) then
13126 gsaxsC(l,i) = gsaxsC_(l,i)
13130 call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13131 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13132 if (fg_rank.eq.king) then
13135 gsaxsX(l,i) = gsaxsX_(l,i)
13141 Esaxs_constr = logPtot
13144 c----------------------------------------------------------------------------
13145 double precision function sscale2(r,r_cut,r0,rlamb)
13147 double precision r,gamm,r_cut,r0,rlamb,rr
13149 c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13150 c write (2,*) "rr",rr
13151 if(rr.lt.r_cut-rlamb) then
13153 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13154 gamm=(rr-(r_cut-rlamb))/rlamb
13155 sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13161 C-----------------------------------------------------------------------
13162 double precision function sscalgrad2(r,r_cut,r0,rlamb)
13164 double precision r,gamm,r_cut,r0,rlamb,rr
13166 if(rr.lt.r_cut-rlamb) then
13168 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13169 gamm=(rr-(r_cut-rlamb))/rlamb
13171 sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13173 sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13180 c------------------------------------------------------------------------
13181 double precision function boxshift(x,boxsize)
13183 double precision x,boxsize
13184 double precision xtemp
13185 xtemp=dmod(x,boxsize)
13186 if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13187 boxshift=xtemp-boxsize
13188 else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13189 boxshift=xtemp+boxsize
13195 c--------------------------------------------------------------------------
13196 subroutine closest_img(xi,yi,zi,xj,yj,zj)
13197 include 'DIMENSIONS'
13198 include 'COMMON.CHAIN'
13199 integer xshift,yshift,zshift,subchap
13200 double precision dist_init,xj_safe,yj_safe,zj_safe,
13201 & xj_temp,yj_temp,zj_temp,dist_temp
13205 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13210 xj=xj_safe+xshift*boxxsize
13211 yj=yj_safe+yshift*boxysize
13212 zj=zj_safe+zshift*boxzsize
13213 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13214 if(dist_temp.lt.dist_init) then
13215 dist_init=dist_temp
13224 if (subchap.eq.1) then
13235 c--------------------------------------------------------------------------
13236 subroutine to_box(xi,yi,zi)
13238 include 'DIMENSIONS'
13239 include 'COMMON.CHAIN'
13240 double precision xi,yi,zi
13241 xi=dmod(xi,boxxsize)
13242 if (xi.lt.0.0d0) xi=xi+boxxsize
13243 yi=dmod(yi,boxysize)
13244 if (yi.lt.0.0d0) yi=yi+boxysize
13245 zi=dmod(zi,boxzsize)
13246 if (zi.lt.0.0d0) zi=zi+boxzsize
13249 c--------------------------------------------------------------------------
13250 subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13252 include 'DIMENSIONS'
13253 include 'COMMON.CHAIN'
13254 double precision xi,yi,zi,sslipi,ssgradlipi
13255 double precision fracinbuf
13256 double precision sscalelip,sscagradlip
13258 if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13259 C the energy transfer exist
13260 if (zi.lt.buflipbot) then
13261 C what fraction I am in
13262 fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13263 C lipbufthick is thickenes of lipid buffore
13264 sslipi=sscalelip(fracinbuf)
13265 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13266 elseif (zi.gt.bufliptop) then
13267 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13268 sslipi=sscalelip(fracinbuf)
13269 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick