1 subroutine etotal(energia)
2 implicit real*8 (a-h,o-z)
7 cMS$ATTRIBUTES C :: proc_proc
12 double precision weights_(n_ene)
14 include 'COMMON.SETUP'
15 include 'COMMON.IOUNITS'
16 double precision energia(0:n_ene)
17 include 'COMMON.LOCAL'
18 include 'COMMON.FFIELD'
19 include 'COMMON.DERIV'
20 include 'COMMON.INTERACT'
21 include 'COMMON.SBRIDGE'
22 include 'COMMON.CHAIN'
25 include 'COMMON.CONTROL'
26 include 'COMMON.TIME1'
27 include 'COMMON.SPLITELE'
28 include 'COMMON.TORCNSTR'
30 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
31 c & " nfgtasks",nfgtasks
32 if (nfgtasks.gt.1) then
34 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
35 if (fg_rank.eq.0) then
36 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
37 c print *,"Processor",myrank," BROADCAST iorder"
38 C FG master sets up the WEIGHTS_ array which will be broadcast to the
39 C FG slaves as WEIGHTS array.
61 weights_(28)=wdfa_dist
64 weights_(31)=wdfa_beta
65 C FG Master broadcasts the WEIGHTS_ array
66 call MPI_Bcast(weights_(1),n_ene,
67 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
69 C FG slaves receive the WEIGHTS array
70 call MPI_Bcast(weights(1),n_ene,
71 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
93 wdfa_dist=weights_(28)
96 wdfa_beta=weights_(31)
98 time_Bcast=time_Bcast+MPI_Wtime()-time00
99 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
100 c call chainbuild_cart
108 c print *,'Processor',myrank,' calling etotal ipot=',ipot
109 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
111 c if (modecalc.eq.12.or.modecalc.eq.14) then
112 c call int_from_cart1(.false.)
119 C Compute the side-chain and electrostatic interaction energy
122 goto (101,102,103,104,105,106) ipot
123 C Lennard-Jones potential.
125 cd print '(a)','Exit ELJ'
127 C Lennard-Jones-Kihara potential (shifted).
130 C Berne-Pechukas potential (dilated LJ, angular dependence).
133 C Gay-Berne potential (shifted LJ, angular dependence).
135 C print *,"bylem w egb"
137 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
140 C Soft-sphere potential
141 106 call e_softsphere(evdw)
143 C Calculate electrostatic (H-bonding) energy of the main chain.
147 C BARTEK for dfa test!
148 if (wdfa_dist.gt.0) then
153 c print*, 'edfad is finished!', edfadis
154 if (wdfa_tor.gt.0) then
159 c print*, 'edfat is finished!', edfator
160 if (wdfa_nei.gt.0) then
165 c print*, 'edfan is finished!', edfanei
166 if (wdfa_beta.gt.0) then
173 cmc Sep-06: egb takes care of dynamic ss bonds too
175 c if (dyn_ss) call dyn_set_nss
177 c print *,"Processor",myrank," computed USCSC"
183 time_vec=time_vec+MPI_Wtime()-time01
185 C Introduction of shielding effect first for each peptide group
186 C the shielding factor is set this factor is describing how each
187 C peptide group is shielded by side-chains
188 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
189 C write (iout,*) "shield_mode",shield_mode
190 if (shield_mode.eq.1) then
192 else if (shield_mode.eq.2) then
195 c print *,"Processor",myrank," left VEC_AND_DERIV"
198 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
199 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
200 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
201 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
203 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
204 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
205 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
206 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
208 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
217 write (iout,*) "Soft-spheer ELEC potential"
218 c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
222 c time_enecalc=time_enecalc+MPI_Wtime()-time00
224 c print *,"Processor",myrank," computed UELEC"
226 C Calculate excluded-volume interaction energy between peptide groups
231 call escp(evdw2,evdw2_14)
237 c write (iout,*) "Soft-sphere SCP potential"
238 call escp_soft_sphere(evdw2,evdw2_14)
241 c Calculate the bond-stretching energy
245 C Calculate the disulfide-bridge and other energy and the contributions
246 C from other distance constraints.
247 cd write (iout,*) 'Calling EHPB'
249 cd print *,'EHPB exitted succesfully.'
251 C Calculate the virtual-bond-angle energy.
253 if (wang.gt.0d0) then
254 if (tor_mode.eq.0) then
257 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
265 if (with_theta_constr) call etheta_constr(ethetacnstr)
266 c print *,"Processor",myrank," computed UB"
268 C Calculate the SC local energy.
270 C print *,"TU DOCHODZE?"
272 c print *,"Processor",myrank," computed USC"
274 C Calculate the virtual-bond torsional energy.
276 cd print *,'nterm=',nterm
277 C print *,"tor",tor_mode
278 if (wtor.gt.0.0d0) then
279 if (tor_mode.eq.0) then
282 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
290 if (ndih_constr.gt.0) call etor_constr(edihcnstr)
291 c print *,"Processor",myrank," computed Utor"
292 if (constr_homology.ge.1) then
293 call e_modeller(ehomology_constr)
294 c print *,'iset=',iset,'me=',me,ehomology_constr,
295 c & 'Processor',fg_rank,' CG group',kolor,
296 c & ' absolute rank',MyRank
298 ehomology_constr=0.0d0
301 C 6/23/01 Calculate double-torsional energy
303 if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
308 c print *,"Processor",myrank," computed Utord"
310 C 21/5/07 Calculate local sicdechain correlation energy
312 if (wsccor.gt.0.0d0) then
313 call eback_sc_corr(esccor)
317 C print *,"PRZED MULIt"
318 c print *,"Processor",myrank," computed Usccorr"
320 C 12/1/95 Multi-body terms
324 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
325 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
326 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
327 c write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
328 c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
336 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
337 c write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
340 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
341 c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
345 c print *,"Processor",myrank," computed Ucorr"
346 c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
347 if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
348 call e_saxs(Esaxs_constr)
349 c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
350 else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
351 call e_saxsC(Esaxs_constr)
352 c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
357 C If performing constraint dynamics, call the constraint energy
358 C after the equilibration time
359 c if(usampl.and.totT.gt.eq_time) then
360 c write (iout,*) "usampl",usampl
364 call Econstr_back_qlike
372 C 01/27/2015 added by adasko
373 C the energy component below is energy transfer into lipid environment
374 C based on partition function
375 C print *,"przed lipidami"
376 if (wliptran.gt.0) then
377 call Eliptransfer(eliptran)
379 C print *,"za lipidami"
380 if (AFMlog.gt.0) then
381 call AFMforce(Eafmforce)
382 else if (selfguide.gt.0) then
383 call AFMvel(Eafmforce)
385 if (TUBElog.eq.1) then
386 C print *,"just before call"
388 elseif (TUBElog.eq.2) then
389 call calctube2(Etube)
395 time_enecalc=time_enecalc+MPI_Wtime()-time00
397 c print *,"Processor",myrank," computed Uconstr"
406 energia(2)=evdw2-evdw2_14
423 energia(8)=eello_turn3
424 energia(9)=eello_turn4
431 energia(19)=edihcnstr
433 energia(20)=Uconst+Uconst_back
436 energia(23)=Eafmforce
437 energia(24)=ethetacnstr
439 energia(26)=Esaxs_constr
440 energia(27)=ehomology_constr
445 c write (iout,*) "esaxs_constr",energia(26)
446 c Here are the energies showed per procesor if the are more processors
447 c per molecule then we sum it up in sum_energy subroutine
448 c print *," Processor",myrank," calls SUM_ENERGY"
449 call sum_energy(energia,.true.)
450 c write (iout,*) "After sum_energy: esaxs_constr",energia(26)
451 if (dyn_ss) call dyn_set_nss
452 c print *," Processor",myrank," left SUM_ENERGY"
454 time_sumene=time_sumene+MPI_Wtime()-time00
458 c-------------------------------------------------------------------------------
459 subroutine sum_energy(energia,reduce)
460 implicit real*8 (a-h,o-z)
465 cMS$ATTRIBUTES C :: proc_proc
471 include 'COMMON.SETUP'
472 include 'COMMON.IOUNITS'
473 double precision energia(0:n_ene),enebuff(0:n_ene+1)
474 include 'COMMON.FFIELD'
475 include 'COMMON.DERIV'
476 include 'COMMON.INTERACT'
477 include 'COMMON.SBRIDGE'
478 include 'COMMON.CHAIN'
480 include 'COMMON.CONTROL'
481 include 'COMMON.TIME1'
484 if (nfgtasks.gt.1 .and. reduce) then
486 write (iout,*) "energies before REDUCE"
487 call enerprint(energia)
491 enebuff(i)=energia(i)
494 call MPI_Barrier(FG_COMM,IERR)
495 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
497 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
498 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
500 write (iout,*) "energies after REDUCE"
501 call enerprint(energia)
504 time_Reduce=time_Reduce+MPI_Wtime()-time00
506 if (fg_rank.eq.0) then
510 evdw2=energia(2)+energia(18)
526 eello_turn3=energia(8)
527 eello_turn4=energia(9)
534 edihcnstr=energia(19)
539 Eafmforce=energia(23)
540 ethetacnstr=energia(24)
542 esaxs_constr=energia(26)
543 ehomology_constr=energia(27)
549 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
550 & +wang*ebe+wtor*etors+wscloc*escloc
551 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
552 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
553 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
554 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
555 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
556 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
559 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
560 & +wang*ebe+wtor*etors+wscloc*escloc
561 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
562 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
563 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
564 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
566 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
567 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
574 if (isnan(etot).ne.0) energia(0)=1.0d+99
576 if (isnan(etot)) energia(0)=1.0d+99
581 idumm=proc_proc(etot,i)
583 call proc_proc(etot,i)
585 if(i.eq.1)energia(0)=1.0d+99
592 c-------------------------------------------------------------------------------
593 subroutine sum_gradient
594 implicit real*8 (a-h,o-z)
599 cMS$ATTRIBUTES C :: proc_proc
605 double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
606 & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
607 & ,gloc_scbuf(3,-1:maxres)
608 include 'COMMON.SETUP'
609 include 'COMMON.IOUNITS'
610 include 'COMMON.FFIELD'
611 include 'COMMON.DERIV'
612 include 'COMMON.INTERACT'
613 include 'COMMON.SBRIDGE'
614 include 'COMMON.CHAIN'
616 include 'COMMON.CONTROL'
617 include 'COMMON.TIME1'
618 include 'COMMON.MAXGRAD'
619 include 'COMMON.SCCOR'
625 write (iout,*) "sum_gradient gvdwc, gvdwx"
627 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
628 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
633 write (iout,*) "sum_gradient gsaxsc, gsaxsx"
635 write (iout,'(i3,3e15.5,5x,3e15.5)')
636 & i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
641 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
642 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
643 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
646 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
647 C in virtual-bond-vector coordinates
650 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
652 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
653 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
655 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
657 c write (iout,'(i5,3f10.5,2x,f10.5)')
658 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
660 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
662 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
663 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
669 write (iout,*) "gsaxsc"
671 write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
678 gradbufc(j,i)=wsc*gvdwc(j,i)+
679 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
680 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
681 & wel_loc*gel_loc_long(j,i)+
682 & wcorr*gradcorr_long(j,i)+
683 & wcorr5*gradcorr5_long(j,i)+
684 & wcorr6*gradcorr6_long(j,i)+
685 & wturn6*gcorr6_turn_long(j,i)+
687 & +wliptran*gliptranc(j,i)
689 & +welec*gshieldc(j,i)
690 & +wcorr*gshieldc_ec(j,i)
691 & +wturn3*gshieldc_t3(j,i)
692 & +wturn4*gshieldc_t4(j,i)
693 & +wel_loc*gshieldc_ll(j,i)
694 & +wtube*gg_tube(j,i)
701 gradbufc(j,i)=wsc*gvdwc(j,i)+
702 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
703 & welec*gelc_long(j,i)+
705 & wel_loc*gel_loc_long(j,i)+
706 & wcorr*gradcorr_long(j,i)+
707 & wcorr5*gradcorr5_long(j,i)+
708 & wcorr6*gradcorr6_long(j,i)+
709 & wturn6*gcorr6_turn_long(j,i)+
711 & +wliptran*gliptranc(j,i)
713 & +welec*gshieldc(j,i)
714 & +wcorr*gshieldc_ec(j,i)
715 & +wturn4*gshieldc_t4(j,i)
716 & +wel_loc*gshieldc_ll(j,i)
717 & +wtube*gg_tube(j,i)
724 gradbufc(j,i)=gradbufc(j,i)+
725 & wdfa_dist*gdfad(j,i)+
726 & wdfa_tor*gdfat(j,i)+
727 & wdfa_nei*gdfan(j,i)+
728 & wdfa_beta*gdfab(j,i)
732 write (iout,*) "gradc from gradbufc"
734 write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
739 if (nfgtasks.gt.1) then
742 write (iout,*) "gradbufc before allreduce"
744 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
750 gradbufc_sum(j,i)=gradbufc(j,i)
753 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
754 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
755 c time_reduce=time_reduce+MPI_Wtime()-time00
757 c write (iout,*) "gradbufc_sum after allreduce"
759 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
764 c time_allreduce=time_allreduce+MPI_Wtime()-time00
772 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
773 write (iout,*) (i," jgrad_start",jgrad_start(i),
774 & " jgrad_end ",jgrad_end(i),
775 & i=igrad_start,igrad_end)
778 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
779 c do not parallelize this part.
781 c do i=igrad_start,igrad_end
782 c do j=jgrad_start(i),jgrad_end(i)
784 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
789 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
793 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
797 write (iout,*) "gradbufc after summing"
799 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
806 write (iout,*) "gradbufc"
808 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
814 gradbufc_sum(j,i)=gradbufc(j,i)
819 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
823 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
828 c gradbufc(k,i)=0.0d0
832 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
837 write (iout,*) "gradbufc after summing"
839 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
847 gradbufc(k,nres)=0.0d0
852 C print *,gradbufc(1,13)
853 C print *,welec*gelc(1,13)
854 C print *,wel_loc*gel_loc(1,13)
855 C print *,0.5d0*(wscp*gvdwc_scpp(1,13))
856 C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
857 C print *,wel_loc*gel_loc_long(1,13)
858 C print *,gradafm(1,13),"AFM"
859 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
860 & wel_loc*gel_loc(j,i)+
861 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
862 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
863 & wel_loc*gel_loc_long(j,i)+
864 & wcorr*gradcorr_long(j,i)+
865 & wcorr5*gradcorr5_long(j,i)+
866 & wcorr6*gradcorr6_long(j,i)+
867 & wturn6*gcorr6_turn_long(j,i))+
869 & wcorr*gradcorr(j,i)+
870 & wturn3*gcorr3_turn(j,i)+
871 & wturn4*gcorr4_turn(j,i)+
872 & wcorr5*gradcorr5(j,i)+
873 & wcorr6*gradcorr6(j,i)+
874 & wturn6*gcorr6_turn(j,i)+
875 & wsccor*gsccorc(j,i)
876 & +wscloc*gscloc(j,i)
877 & +wliptran*gliptranc(j,i)
879 & +welec*gshieldc(j,i)
880 & +welec*gshieldc_loc(j,i)
881 & +wcorr*gshieldc_ec(j,i)
882 & +wcorr*gshieldc_loc_ec(j,i)
883 & +wturn3*gshieldc_t3(j,i)
884 & +wturn3*gshieldc_loc_t3(j,i)
885 & +wturn4*gshieldc_t4(j,i)
886 & +wturn4*gshieldc_loc_t4(j,i)
887 & +wel_loc*gshieldc_ll(j,i)
888 & +wel_loc*gshieldc_loc_ll(j,i)
889 & +wtube*gg_tube(j,i)
892 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
893 & wel_loc*gel_loc(j,i)+
894 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
895 & welec*gelc_long(j,i)+
896 & wel_loc*gel_loc_long(j,i)+
897 & wcorr*gcorr_long(j,i)+
898 & wcorr5*gradcorr5_long(j,i)+
899 & wcorr6*gradcorr6_long(j,i)+
900 & wturn6*gcorr6_turn_long(j,i))+
902 & wcorr*gradcorr(j,i)+
903 & wturn3*gcorr3_turn(j,i)+
904 & wturn4*gcorr4_turn(j,i)+
905 & wcorr5*gradcorr5(j,i)+
906 & wcorr6*gradcorr6(j,i)+
907 & wturn6*gcorr6_turn(j,i)+
908 & wsccor*gsccorc(j,i)
909 & +wscloc*gscloc(j,i)
910 & +wliptran*gliptranc(j,i)
912 & +welec*gshieldc(j,i)
913 & +welec*gshieldc_loc(j,i)
914 & +wcorr*gshieldc_ec(j,i)
915 & +wcorr*gshieldc_loc_ec(j,i)
916 & +wturn3*gshieldc_t3(j,i)
917 & +wturn3*gshieldc_loc_t3(j,i)
918 & +wturn4*gshieldc_t4(j,i)
919 & +wturn4*gshieldc_loc_t4(j,i)
920 & +wel_loc*gshieldc_ll(j,i)
921 & +wel_loc*gshieldc_loc_ll(j,i)
922 & +wtube*gg_tube(j,i)
926 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
928 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
929 & wsccor*gsccorx(j,i)
930 & +wscloc*gsclocx(j,i)
931 & +wliptran*gliptranx(j,i)
932 & +welec*gshieldx(j,i)
933 & +wcorr*gshieldx_ec(j,i)
934 & +wturn3*gshieldx_t3(j,i)
935 & +wturn4*gshieldx_t4(j,i)
936 & +wel_loc*gshieldx_ll(j,i)
937 & +wtube*gg_tube_sc(j,i)
944 if (constr_homology.gt.0) then
947 gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
948 gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
953 write (iout,*) "gradc gradx gloc after adding"
955 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
956 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
960 write (iout,*) "gloc before adding corr"
962 write (iout,*) i,gloc(i,icg)
966 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
967 & +wcorr5*g_corr5_loc(i)
968 & +wcorr6*g_corr6_loc(i)
969 & +wturn4*gel_loc_turn4(i)
970 & +wturn3*gel_loc_turn3(i)
971 & +wturn6*gel_loc_turn6(i)
972 & +wel_loc*gel_loc_loc(i)
975 write (iout,*) "gloc after adding corr"
977 write (iout,*) i,gloc(i,icg)
981 if (nfgtasks.gt.1) then
984 gradbufc(j,i)=gradc(j,i,icg)
985 gradbufx(j,i)=gradx(j,i,icg)
989 glocbuf(i)=gloc(i,icg)
993 write (iout,*) "gloc_sc before reduce"
996 write (iout,*) i,j,gloc_sc(j,i,icg)
1003 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1007 call MPI_Barrier(FG_COMM,IERR)
1008 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1010 call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1011 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1012 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1013 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1014 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1015 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1016 time_reduce=time_reduce+MPI_Wtime()-time00
1017 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1018 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1019 time_reduce=time_reduce+MPI_Wtime()-time00
1021 write (iout,*) "gradc after reduce"
1024 write (iout,*) i,j,gradc(j,i,icg)
1029 write (iout,*) "gloc_sc after reduce"
1032 write (iout,*) i,j,gloc_sc(j,i,icg)
1037 write (iout,*) "gloc after reduce"
1039 write (iout,*) i,gloc(i,icg)
1044 if (gnorm_check) then
1046 c Compute the maximum elements of the gradient
1056 gcorr3_turn_max=0.0d0
1057 gcorr4_turn_max=0.0d0
1060 gcorr6_turn_max=0.0d0
1070 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1071 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1072 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1073 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1074 & gvdwc_scp_max=gvdwc_scp_norm
1075 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1076 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1077 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1078 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1079 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1080 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1081 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1082 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1083 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1084 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1085 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1086 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1087 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1088 & gcorr3_turn(1,i)))
1089 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1090 & gcorr3_turn_max=gcorr3_turn_norm
1091 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1092 & gcorr4_turn(1,i)))
1093 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1094 & gcorr4_turn_max=gcorr4_turn_norm
1095 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1096 if (gradcorr5_norm.gt.gradcorr5_max)
1097 & gradcorr5_max=gradcorr5_norm
1098 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1099 if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1100 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1101 & gcorr6_turn(1,i)))
1102 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1103 & gcorr6_turn_max=gcorr6_turn_norm
1104 gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1105 if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1106 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1107 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1108 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1109 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1110 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1111 if (gradx_scp_norm.gt.gradx_scp_max)
1112 & gradx_scp_max=gradx_scp_norm
1113 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1114 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1115 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1116 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1117 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1118 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1119 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1120 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1123 #if (defined AIX || defined CRAY)
1124 open(istat,file=statname,position="append")
1126 open(istat,file=statname,access="append")
1128 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1129 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1130 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1131 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1132 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1133 & gsccorx_max,gsclocx_max
1135 if (gvdwc_max.gt.1.0d4) then
1136 write (iout,*) "gvdwc gvdwx gradb gradbx"
1138 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1139 & gradb(j,i),gradbx(j,i),j=1,3)
1141 call pdbout(0.0d0,'cipiszcze',iout)
1147 write (iout,*) "gradc gradx gloc"
1149 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1150 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1154 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1158 c-------------------------------------------------------------------------------
1159 subroutine rescale_weights(t_bath)
1160 implicit real*8 (a-h,o-z)
1161 include 'DIMENSIONS'
1162 include 'COMMON.IOUNITS'
1163 include 'COMMON.FFIELD'
1164 include 'COMMON.SBRIDGE'
1165 include 'COMMON.CONTROL'
1166 double precision kfac /2.4d0/
1167 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1169 c facT=2*temp0/(t_bath+temp0)
1170 if (rescale_mode.eq.0) then
1176 else if (rescale_mode.eq.1) then
1177 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1178 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1179 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1180 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1181 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1182 else if (rescale_mode.eq.2) then
1188 facT=licznik/dlog(dexp(x)+dexp(-x))
1189 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1190 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1191 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1192 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1194 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1195 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1197 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1201 if (shield_mode.gt.0) then
1202 wscp=weights(2)*fact
1204 wvdwpp=weights(16)*fact
1206 welec=weights(3)*fact
1207 wcorr=weights(4)*fact3
1208 wcorr5=weights(5)*fact4
1209 wcorr6=weights(6)*fact5
1210 wel_loc=weights(7)*fact2
1211 wturn3=weights(8)*fact2
1212 wturn4=weights(9)*fact3
1213 wturn6=weights(10)*fact5
1214 wtor=weights(13)*fact
1215 wtor_d=weights(14)*fact2
1216 wsccor=weights(21)*fact
1217 if (scale_umb) wumb=t_bath/temp0
1218 c write (iout,*) "scale_umb",scale_umb
1219 c write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1223 C------------------------------------------------------------------------
1224 subroutine enerprint(energia)
1225 implicit real*8 (a-h,o-z)
1226 include 'DIMENSIONS'
1227 include 'COMMON.IOUNITS'
1228 include 'COMMON.FFIELD'
1229 include 'COMMON.SBRIDGE'
1231 double precision energia(0:n_ene)
1236 evdw2=energia(2)+energia(18)
1248 eello_turn3=energia(8)
1249 eello_turn4=energia(9)
1250 eello_turn6=energia(10)
1256 edihcnstr=energia(19)
1260 eliptran=energia(22)
1261 Eafmforce=energia(23)
1262 ethetacnstr=energia(24)
1265 ehomology_constr=energia(27)
1267 edfadis = energia(28)
1268 edfator = energia(29)
1269 edfanei = energia(30)
1270 edfabet = energia(31)
1272 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1273 & estr,wbond,ebe,wang,
1274 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1276 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1277 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1278 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1279 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1280 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1281 & edfabet,wdfa_beta,
1283 10 format (/'Virtual-chain energies:'//
1284 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1285 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1286 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1287 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1288 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1289 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1290 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1291 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1292 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1293 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1294 & ' (SS bridges & dist. cnstr.)'/
1295 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1296 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1297 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1298 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1299 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1300 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1301 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1302 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1303 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1304 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1305 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1306 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1307 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1308 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1309 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1310 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1311 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1312 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1313 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1314 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1315 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1316 & 'ETOT= ',1pE16.6,' (total)')
1319 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1320 & estr,wbond,ebe,wang,
1321 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1323 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1324 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1325 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1326 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1327 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1328 & edfabet,wdfa_beta,
1330 10 format (/'Virtual-chain energies:'//
1331 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1332 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1333 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1334 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1335 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1336 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1337 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1338 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1339 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1340 & ' (SS bridges & dist. restr.)'/
1341 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1342 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1343 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1344 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1345 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1346 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1347 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1348 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1349 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1350 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1351 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1352 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1353 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1354 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1355 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1356 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1357 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1358 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1359 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1360 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1361 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1362 & 'ETOT= ',1pE16.6,' (total)')
1366 C-----------------------------------------------------------------------
1367 subroutine elj(evdw)
1369 C This subroutine calculates the interaction energy of nonbonded side chains
1370 C assuming the LJ potential of interaction.
1372 implicit real*8 (a-h,o-z)
1373 include 'DIMENSIONS'
1374 parameter (accur=1.0d-10)
1375 include 'COMMON.GEO'
1376 include 'COMMON.VAR'
1377 include 'COMMON.LOCAL'
1378 include 'COMMON.CHAIN'
1379 include 'COMMON.DERIV'
1380 include 'COMMON.INTERACT'
1381 include 'COMMON.TORSION'
1382 include 'COMMON.SBRIDGE'
1383 include 'COMMON.NAMES'
1384 include 'COMMON.IOUNITS'
1385 include 'COMMON.CONTACTS'
1387 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1389 do i=iatsc_s,iatsc_e
1390 itypi=iabs(itype(i))
1391 if (itypi.eq.ntyp1) cycle
1392 itypi1=iabs(itype(i+1))
1399 C Calculate SC interaction energy.
1401 do iint=1,nint_gr(i)
1402 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1403 cd & 'iend=',iend(i,iint)
1404 do j=istart(i,iint),iend(i,iint)
1405 itypj=iabs(itype(j))
1406 if (itypj.eq.ntyp1) cycle
1410 C Change 12/1/95 to calculate four-body interactions
1411 rij=xj*xj+yj*yj+zj*zj
1413 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1414 eps0ij=eps(itypi,itypj)
1416 C have you changed here?
1420 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1421 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1422 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1423 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1424 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1425 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1428 C Calculate the components of the gradient in DC and X
1430 fac=-rrij*(e1+evdwij)
1435 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1436 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1437 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1438 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1442 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1446 C 12/1/95, revised on 5/20/97
1448 C Calculate the contact function. The ith column of the array JCONT will
1449 C contain the numbers of atoms that make contacts with the atom I (of numbers
1450 C greater than I). The arrays FACONT and GACONT will contain the values of
1451 C the contact function and its derivative.
1453 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1454 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1455 C Uncomment next line, if the correlation interactions are contact function only
1456 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1458 sigij=sigma(itypi,itypj)
1459 r0ij=rs0(itypi,itypj)
1461 C Check whether the SC's are not too far to make a contact.
1464 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1465 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1467 if (fcont.gt.0.0D0) then
1468 C If the SC-SC distance if close to sigma, apply spline.
1469 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1470 cAdam & fcont1,fprimcont1)
1471 cAdam fcont1=1.0d0-fcont1
1472 cAdam if (fcont1.gt.0.0d0) then
1473 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1474 cAdam fcont=fcont*fcont1
1476 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1477 cga eps0ij=1.0d0/dsqrt(eps0ij)
1479 cga gg(k)=gg(k)*eps0ij
1481 cga eps0ij=-evdwij*eps0ij
1482 C Uncomment for AL's type of SC correlation interactions.
1483 cadam eps0ij=-evdwij
1484 num_conti=num_conti+1
1485 jcont(num_conti,i)=j
1486 facont(num_conti,i)=fcont*eps0ij
1487 fprimcont=eps0ij*fprimcont/rij
1489 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1490 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1491 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1492 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1493 gacont(1,num_conti,i)=-fprimcont*xj
1494 gacont(2,num_conti,i)=-fprimcont*yj
1495 gacont(3,num_conti,i)=-fprimcont*zj
1496 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1497 cd write (iout,'(2i3,3f10.5)')
1498 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1504 num_cont(i)=num_conti
1508 gvdwc(j,i)=expon*gvdwc(j,i)
1509 gvdwx(j,i)=expon*gvdwx(j,i)
1512 C******************************************************************************
1516 C To save time, the factor of EXPON has been extracted from ALL components
1517 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1520 C******************************************************************************
1523 C-----------------------------------------------------------------------------
1524 subroutine eljk(evdw)
1526 C This subroutine calculates the interaction energy of nonbonded side chains
1527 C assuming the LJK potential of interaction.
1529 implicit real*8 (a-h,o-z)
1530 include 'DIMENSIONS'
1531 include 'COMMON.GEO'
1532 include 'COMMON.VAR'
1533 include 'COMMON.LOCAL'
1534 include 'COMMON.CHAIN'
1535 include 'COMMON.DERIV'
1536 include 'COMMON.INTERACT'
1537 include 'COMMON.IOUNITS'
1538 include 'COMMON.NAMES'
1541 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1543 do i=iatsc_s,iatsc_e
1544 itypi=iabs(itype(i))
1545 if (itypi.eq.ntyp1) cycle
1546 itypi1=iabs(itype(i+1))
1551 C Calculate SC interaction energy.
1553 do iint=1,nint_gr(i)
1554 do j=istart(i,iint),iend(i,iint)
1555 itypj=iabs(itype(j))
1556 if (itypj.eq.ntyp1) cycle
1560 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1561 fac_augm=rrij**expon
1562 e_augm=augm(itypi,itypj)*fac_augm
1563 r_inv_ij=dsqrt(rrij)
1565 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1566 fac=r_shift_inv**expon
1567 C have you changed here?
1571 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1572 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1573 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1574 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1575 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1576 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1577 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1580 C Calculate the components of the gradient in DC and X
1582 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1587 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1588 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1589 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1590 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1594 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1602 gvdwc(j,i)=expon*gvdwc(j,i)
1603 gvdwx(j,i)=expon*gvdwx(j,i)
1608 C-----------------------------------------------------------------------------
1609 subroutine ebp(evdw)
1611 C This subroutine calculates the interaction energy of nonbonded side chains
1612 C assuming the Berne-Pechukas potential of interaction.
1614 implicit real*8 (a-h,o-z)
1615 include 'DIMENSIONS'
1616 include 'COMMON.GEO'
1617 include 'COMMON.VAR'
1618 include 'COMMON.LOCAL'
1619 include 'COMMON.CHAIN'
1620 include 'COMMON.DERIV'
1621 include 'COMMON.NAMES'
1622 include 'COMMON.INTERACT'
1623 include 'COMMON.IOUNITS'
1624 include 'COMMON.CALC'
1625 common /srutu/ icall
1626 c double precision rrsave(maxdim)
1629 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1631 c if (icall.eq.0) then
1637 do i=iatsc_s,iatsc_e
1638 itypi=iabs(itype(i))
1639 if (itypi.eq.ntyp1) cycle
1640 itypi1=iabs(itype(i+1))
1644 dxi=dc_norm(1,nres+i)
1645 dyi=dc_norm(2,nres+i)
1646 dzi=dc_norm(3,nres+i)
1647 c dsci_inv=dsc_inv(itypi)
1648 dsci_inv=vbld_inv(i+nres)
1650 C Calculate SC interaction energy.
1652 do iint=1,nint_gr(i)
1653 do j=istart(i,iint),iend(i,iint)
1655 itypj=iabs(itype(j))
1656 if (itypj.eq.ntyp1) cycle
1657 c dscj_inv=dsc_inv(itypj)
1658 dscj_inv=vbld_inv(j+nres)
1659 chi1=chi(itypi,itypj)
1660 chi2=chi(itypj,itypi)
1667 alf12=0.5D0*(alf1+alf2)
1668 C For diagnostics only!!!
1681 dxj=dc_norm(1,nres+j)
1682 dyj=dc_norm(2,nres+j)
1683 dzj=dc_norm(3,nres+j)
1684 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1685 cd if (icall.eq.0) then
1691 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1693 C Calculate whole angle-dependent part of epsilon and contributions
1694 C to its derivatives
1695 C have you changed here?
1696 fac=(rrij*sigsq)**expon2
1699 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1700 eps2der=evdwij*eps3rt
1701 eps3der=evdwij*eps2rt
1702 evdwij=evdwij*eps2rt*eps3rt
1705 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1707 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1708 cd & restyp(itypi),i,restyp(itypj),j,
1709 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1710 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1711 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1714 C Calculate gradient components.
1715 e1=e1*eps1*eps2rt**2*eps3rt**2
1716 fac=-expon*(e1+evdwij)
1719 C Calculate radial part of the gradient
1723 C Calculate the angular part of the gradient and sum add the contributions
1724 C to the appropriate components of the Cartesian gradient.
1732 C-----------------------------------------------------------------------------
1733 subroutine egb(evdw)
1735 C This subroutine calculates the interaction energy of nonbonded side chains
1736 C assuming the Gay-Berne potential of interaction.
1738 implicit real*8 (a-h,o-z)
1739 include 'DIMENSIONS'
1740 include 'COMMON.GEO'
1741 include 'COMMON.VAR'
1742 include 'COMMON.LOCAL'
1743 include 'COMMON.CHAIN'
1744 include 'COMMON.DERIV'
1745 include 'COMMON.NAMES'
1746 include 'COMMON.INTERACT'
1747 include 'COMMON.IOUNITS'
1748 include 'COMMON.CALC'
1749 include 'COMMON.CONTROL'
1750 include 'COMMON.SPLITELE'
1751 include 'COMMON.SBRIDGE'
1753 integer xshift,yshift,zshift
1756 ccccc energy_dec=.false.
1757 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1760 c if (icall.eq.0) lprn=.false.
1762 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1763 C we have the original box)
1767 do i=iatsc_s,iatsc_e
1768 itypi=iabs(itype(i))
1769 if (itypi.eq.ntyp1) cycle
1770 itypi1=iabs(itype(i+1))
1774 C Return atom into box, boxxsize is size of box in x dimension
1776 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1777 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1778 C Condition for being inside the proper box
1779 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1780 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
1784 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1785 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1786 C Condition for being inside the proper box
1787 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1788 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
1792 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1793 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1794 C Condition for being inside the proper box
1795 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1796 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
1800 if (xi.lt.0) xi=xi+boxxsize
1802 if (yi.lt.0) yi=yi+boxysize
1804 if (zi.lt.0) zi=zi+boxzsize
1805 C define scaling factor for lipids
1807 C if (positi.le.0) positi=positi+boxzsize
1809 C first for peptide groups
1810 c for each residue check if it is in lipid or lipid water border area
1811 if ((zi.gt.bordlipbot)
1812 &.and.(zi.lt.bordliptop)) then
1813 C the energy transfer exist
1814 if (zi.lt.buflipbot) then
1815 C what fraction I am in
1817 & ((zi-bordlipbot)/lipbufthick)
1818 C lipbufthick is thickenes of lipid buffore
1819 sslipi=sscalelip(fracinbuf)
1820 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1821 elseif (zi.gt.bufliptop) then
1822 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1823 sslipi=sscalelip(fracinbuf)
1824 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1834 C xi=xi+xshift*boxxsize
1835 C yi=yi+yshift*boxysize
1836 C zi=zi+zshift*boxzsize
1838 dxi=dc_norm(1,nres+i)
1839 dyi=dc_norm(2,nres+i)
1840 dzi=dc_norm(3,nres+i)
1841 c dsci_inv=dsc_inv(itypi)
1842 dsci_inv=vbld_inv(i+nres)
1843 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1844 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1846 C Calculate SC interaction energy.
1848 do iint=1,nint_gr(i)
1849 do j=istart(i,iint),iend(i,iint)
1850 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1852 c write(iout,*) "PRZED ZWYKLE", evdwij
1853 call dyn_ssbond_ene(i,j,evdwij)
1854 c write(iout,*) "PO ZWYKLE", evdwij
1857 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1858 & 'evdw',i,j,evdwij,' ss'
1859 C triple bond artifac removal
1860 do k=j+1,iend(i,iint)
1861 C search over all next residues
1862 if (dyn_ss_mask(k)) then
1863 C check if they are cysteins
1864 C write(iout,*) 'k=',k
1866 c write(iout,*) "PRZED TRI", evdwij
1867 evdwij_przed_tri=evdwij
1868 call triple_ssbond_ene(i,j,k,evdwij)
1869 c if(evdwij_przed_tri.ne.evdwij) then
1870 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1873 c write(iout,*) "PO TRI", evdwij
1874 C call the energy function that removes the artifical triple disulfide
1875 C bond the soubroutine is located in ssMD.F
1877 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1878 & 'evdw',i,j,evdwij,'tss'
1879 endif!dyn_ss_mask(k)
1883 itypj=iabs(itype(j))
1884 if (itypj.eq.ntyp1) cycle
1885 c dscj_inv=dsc_inv(itypj)
1886 dscj_inv=vbld_inv(j+nres)
1887 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1888 c & 1.0d0/vbld(j+nres)
1889 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1890 sig0ij=sigma(itypi,itypj)
1891 chi1=chi(itypi,itypj)
1892 chi2=chi(itypj,itypi)
1899 alf12=0.5D0*(alf1+alf2)
1900 C For diagnostics only!!!
1913 C Return atom J into box the original box
1915 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1916 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1917 C Condition for being inside the proper box
1918 c if ((xj.gt.((0.5d0)*boxxsize)).or.
1919 c & (xj.lt.((-0.5d0)*boxxsize))) then
1923 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1924 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1925 C Condition for being inside the proper box
1926 c if ((yj.gt.((0.5d0)*boxysize)).or.
1927 c & (yj.lt.((-0.5d0)*boxysize))) then
1931 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1932 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1933 C Condition for being inside the proper box
1934 c if ((zj.gt.((0.5d0)*boxzsize)).or.
1935 c & (zj.lt.((-0.5d0)*boxzsize))) then
1939 if (xj.lt.0) xj=xj+boxxsize
1941 if (yj.lt.0) yj=yj+boxysize
1943 if (zj.lt.0) zj=zj+boxzsize
1944 if ((zj.gt.bordlipbot)
1945 &.and.(zj.lt.bordliptop)) then
1946 C the energy transfer exist
1947 if (zj.lt.buflipbot) then
1948 C what fraction I am in
1950 & ((zj-bordlipbot)/lipbufthick)
1951 C lipbufthick is thickenes of lipid buffore
1952 sslipj=sscalelip(fracinbuf)
1953 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1954 elseif (zj.gt.bufliptop) then
1955 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1956 sslipj=sscalelip(fracinbuf)
1957 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1966 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1967 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1968 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1969 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1970 C write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1971 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1972 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1973 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1974 C print *,sslipi,sslipj,bordlipbot,zi,zj
1975 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1983 xj=xj_safe+xshift*boxxsize
1984 yj=yj_safe+yshift*boxysize
1985 zj=zj_safe+zshift*boxzsize
1986 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1987 if(dist_temp.lt.dist_init) then
1997 if (subchap.eq.1) then
2006 dxj=dc_norm(1,nres+j)
2007 dyj=dc_norm(2,nres+j)
2008 dzj=dc_norm(3,nres+j)
2012 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2013 c write (iout,*) "j",j," dc_norm",
2014 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2015 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2017 sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
2018 sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
2020 c write (iout,'(a7,4f8.3)')
2021 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2022 if (sss.gt.0.0d0) then
2023 C Calculate angle-dependent terms of energy and contributions to their
2027 sig=sig0ij*dsqrt(sigsq)
2028 rij_shift=1.0D0/rij-sig+sig0ij
2029 c for diagnostics; uncomment
2030 c rij_shift=1.2*sig0ij
2031 C I hate to put IF's in the loops, but here don't have another choice!!!!
2032 if (rij_shift.le.0.0D0) then
2034 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2035 cd & restyp(itypi),i,restyp(itypj),j,
2036 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2040 c---------------------------------------------------------------
2041 rij_shift=1.0D0/rij_shift
2042 fac=rij_shift**expon
2043 C here to start with
2048 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2049 eps2der=evdwij*eps3rt
2050 eps3der=evdwij*eps2rt
2051 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2052 C &((sslipi+sslipj)/2.0d0+
2053 C &(2.0d0-sslipi-sslipj)/2.0d0)
2054 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2055 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2056 evdwij=evdwij*eps2rt*eps3rt
2057 evdw=evdw+evdwij*sss
2059 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2061 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2062 & restyp(itypi),i,restyp(itypj),j,
2063 & epsi,sigm,chi1,chi2,chip1,chip2,
2064 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2065 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2069 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2072 C Calculate gradient components.
2073 e1=e1*eps1*eps2rt**2*eps3rt**2
2074 fac=-expon*(e1+evdwij)*rij_shift
2077 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
2078 c & evdwij,fac,sigma(itypi,itypj),expon
2079 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2081 C Calculate the radial part of the gradient
2082 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2083 &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2084 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2085 &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2086 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2087 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2093 C Calculate angular part of the gradient.
2103 c write (iout,*) "Number of loop steps in EGB:",ind
2104 cccc energy_dec=.false.
2107 C-----------------------------------------------------------------------------
2108 subroutine egbv(evdw)
2110 C This subroutine calculates the interaction energy of nonbonded side chains
2111 C assuming the Gay-Berne-Vorobjev potential of interaction.
2113 implicit real*8 (a-h,o-z)
2114 include 'DIMENSIONS'
2115 include 'COMMON.GEO'
2116 include 'COMMON.VAR'
2117 include 'COMMON.LOCAL'
2118 include 'COMMON.CHAIN'
2119 include 'COMMON.DERIV'
2120 include 'COMMON.NAMES'
2121 include 'COMMON.INTERACT'
2122 include 'COMMON.IOUNITS'
2123 include 'COMMON.CALC'
2124 integer xshift,yshift,zshift
2125 common /srutu/ icall
2128 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2131 c if (icall.eq.0) lprn=.true.
2133 do i=iatsc_s,iatsc_e
2134 itypi=iabs(itype(i))
2135 if (itypi.eq.ntyp1) cycle
2136 itypi1=iabs(itype(i+1))
2141 if (xi.lt.0) xi=xi+boxxsize
2143 if (yi.lt.0) yi=yi+boxysize
2145 if (zi.lt.0) zi=zi+boxzsize
2146 C define scaling factor for lipids
2148 C if (positi.le.0) positi=positi+boxzsize
2150 C first for peptide groups
2151 c for each residue check if it is in lipid or lipid water border area
2152 if ((zi.gt.bordlipbot)
2153 &.and.(zi.lt.bordliptop)) then
2154 C the energy transfer exist
2155 if (zi.lt.buflipbot) then
2156 C what fraction I am in
2158 & ((zi-bordlipbot)/lipbufthick)
2159 C lipbufthick is thickenes of lipid buffore
2160 sslipi=sscalelip(fracinbuf)
2161 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2162 elseif (zi.gt.bufliptop) then
2163 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2164 sslipi=sscalelip(fracinbuf)
2165 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2175 dxi=dc_norm(1,nres+i)
2176 dyi=dc_norm(2,nres+i)
2177 dzi=dc_norm(3,nres+i)
2178 c dsci_inv=dsc_inv(itypi)
2179 dsci_inv=vbld_inv(i+nres)
2181 C Calculate SC interaction energy.
2183 do iint=1,nint_gr(i)
2184 do j=istart(i,iint),iend(i,iint)
2186 itypj=iabs(itype(j))
2187 if (itypj.eq.ntyp1) cycle
2188 c dscj_inv=dsc_inv(itypj)
2189 dscj_inv=vbld_inv(j+nres)
2190 sig0ij=sigma(itypi,itypj)
2191 r0ij=r0(itypi,itypj)
2192 chi1=chi(itypi,itypj)
2193 chi2=chi(itypj,itypi)
2200 alf12=0.5D0*(alf1+alf2)
2201 C For diagnostics only!!!
2215 if (xj.lt.0) xj=xj+boxxsize
2217 if (yj.lt.0) yj=yj+boxysize
2219 if (zj.lt.0) zj=zj+boxzsize
2220 if ((zj.gt.bordlipbot)
2221 &.and.(zj.lt.bordliptop)) then
2222 C the energy transfer exist
2223 if (zj.lt.buflipbot) then
2224 C what fraction I am in
2226 & ((zj-bordlipbot)/lipbufthick)
2227 C lipbufthick is thickenes of lipid buffore
2228 sslipj=sscalelip(fracinbuf)
2229 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2230 elseif (zj.gt.bufliptop) then
2231 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2232 sslipj=sscalelip(fracinbuf)
2233 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2242 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2243 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2244 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2245 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2246 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2247 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2248 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2249 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2257 xj=xj_safe+xshift*boxxsize
2258 yj=yj_safe+yshift*boxysize
2259 zj=zj_safe+zshift*boxzsize
2260 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2261 if(dist_temp.lt.dist_init) then
2271 if (subchap.eq.1) then
2280 dxj=dc_norm(1,nres+j)
2281 dyj=dc_norm(2,nres+j)
2282 dzj=dc_norm(3,nres+j)
2283 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2285 C Calculate angle-dependent terms of energy and contributions to their
2289 sig=sig0ij*dsqrt(sigsq)
2290 rij_shift=1.0D0/rij-sig+r0ij
2291 C I hate to put IF's in the loops, but here don't have another choice!!!!
2292 if (rij_shift.le.0.0D0) then
2297 c---------------------------------------------------------------
2298 rij_shift=1.0D0/rij_shift
2299 fac=rij_shift**expon
2302 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2303 eps2der=evdwij*eps3rt
2304 eps3der=evdwij*eps2rt
2305 fac_augm=rrij**expon
2306 e_augm=augm(itypi,itypj)*fac_augm
2307 evdwij=evdwij*eps2rt*eps3rt
2308 evdw=evdw+evdwij+e_augm
2310 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2312 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2313 & restyp(itypi),i,restyp(itypj),j,
2314 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2315 & chi1,chi2,chip1,chip2,
2316 & eps1,eps2rt**2,eps3rt**2,
2317 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2320 C Calculate gradient components.
2321 e1=e1*eps1*eps2rt**2*eps3rt**2
2322 fac=-expon*(e1+evdwij)*rij_shift
2324 fac=rij*fac-2*expon*rrij*e_augm
2325 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2326 C Calculate the radial part of the gradient
2330 C Calculate angular part of the gradient.
2336 C-----------------------------------------------------------------------------
2337 subroutine sc_angular
2338 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2339 C om12. Called by ebp, egb, and egbv.
2341 include 'COMMON.CALC'
2342 include 'COMMON.IOUNITS'
2346 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2347 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2348 om12=dxi*dxj+dyi*dyj+dzi*dzj
2350 C Calculate eps1(om12) and its derivative in om12
2351 faceps1=1.0D0-om12*chiom12
2352 faceps1_inv=1.0D0/faceps1
2353 eps1=dsqrt(faceps1_inv)
2354 C Following variable is eps1*deps1/dom12
2355 eps1_om12=faceps1_inv*chiom12
2360 c write (iout,*) "om12",om12," eps1",eps1
2361 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2366 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2367 sigsq=1.0D0-facsig*faceps1_inv
2368 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2369 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2370 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2376 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2377 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2379 C Calculate eps2 and its derivatives in om1, om2, and om12.
2382 chipom12=chip12*om12
2383 facp=1.0D0-om12*chipom12
2385 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2386 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2387 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2388 C Following variable is the square root of eps2
2389 eps2rt=1.0D0-facp1*facp_inv
2390 C Following three variables are the derivatives of the square root of eps
2391 C in om1, om2, and om12.
2392 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2393 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2394 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2395 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2396 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2397 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2398 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2399 c & " eps2rt_om12",eps2rt_om12
2400 C Calculate whole angle-dependent part of epsilon and contributions
2401 C to its derivatives
2404 C----------------------------------------------------------------------------
2406 implicit real*8 (a-h,o-z)
2407 include 'DIMENSIONS'
2408 include 'COMMON.CHAIN'
2409 include 'COMMON.DERIV'
2410 include 'COMMON.CALC'
2411 include 'COMMON.IOUNITS'
2412 double precision dcosom1(3),dcosom2(3)
2413 cc print *,'sss=',sss
2414 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2415 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2416 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2417 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2421 c eom12=evdwij*eps1_om12
2423 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2424 c & " sigder",sigder
2425 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2426 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2428 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2429 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2432 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2434 c write (iout,*) "gg",(gg(k),k=1,3)
2436 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2437 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2438 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2439 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2440 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2441 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2442 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2443 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2444 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2445 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2448 C Calculate the components of the gradient in DC and X
2452 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2456 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2457 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2461 C-----------------------------------------------------------------------
2462 subroutine e_softsphere(evdw)
2464 C This subroutine calculates the interaction energy of nonbonded side chains
2465 C assuming the LJ potential of interaction.
2467 implicit real*8 (a-h,o-z)
2468 include 'DIMENSIONS'
2469 parameter (accur=1.0d-10)
2470 include 'COMMON.GEO'
2471 include 'COMMON.VAR'
2472 include 'COMMON.LOCAL'
2473 include 'COMMON.CHAIN'
2474 include 'COMMON.DERIV'
2475 include 'COMMON.INTERACT'
2476 include 'COMMON.TORSION'
2477 include 'COMMON.SBRIDGE'
2478 include 'COMMON.NAMES'
2479 include 'COMMON.IOUNITS'
2480 include 'COMMON.CONTACTS'
2482 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2484 do i=iatsc_s,iatsc_e
2485 itypi=iabs(itype(i))
2486 if (itypi.eq.ntyp1) cycle
2487 itypi1=iabs(itype(i+1))
2492 C Calculate SC interaction energy.
2494 do iint=1,nint_gr(i)
2495 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2496 cd & 'iend=',iend(i,iint)
2497 do j=istart(i,iint),iend(i,iint)
2498 itypj=iabs(itype(j))
2499 if (itypj.eq.ntyp1) cycle
2503 rij=xj*xj+yj*yj+zj*zj
2504 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2505 r0ij=r0(itypi,itypj)
2507 c print *,i,j,r0ij,dsqrt(rij)
2508 if (rij.lt.r0ijsq) then
2509 evdwij=0.25d0*(rij-r0ijsq)**2
2517 C Calculate the components of the gradient in DC and X
2523 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2524 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2525 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2526 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2530 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2538 C--------------------------------------------------------------------------
2539 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2542 C Soft-sphere potential of p-p interaction
2544 implicit real*8 (a-h,o-z)
2545 include 'DIMENSIONS'
2546 include 'COMMON.CONTROL'
2547 include 'COMMON.IOUNITS'
2548 include 'COMMON.GEO'
2549 include 'COMMON.VAR'
2550 include 'COMMON.LOCAL'
2551 include 'COMMON.CHAIN'
2552 include 'COMMON.DERIV'
2553 include 'COMMON.INTERACT'
2554 include 'COMMON.CONTACTS'
2555 include 'COMMON.TORSION'
2556 include 'COMMON.VECTORS'
2557 include 'COMMON.FFIELD'
2559 integer xshift,yshift,zshift
2560 C write(iout,*) 'In EELEC_soft_sphere'
2567 do i=iatel_s,iatel_e
2568 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2572 xmedi=c(1,i)+0.5d0*dxi
2573 ymedi=c(2,i)+0.5d0*dyi
2574 zmedi=c(3,i)+0.5d0*dzi
2575 xmedi=mod(xmedi,boxxsize)
2576 if (xmedi.lt.0) xmedi=xmedi+boxxsize
2577 ymedi=mod(ymedi,boxysize)
2578 if (ymedi.lt.0) ymedi=ymedi+boxysize
2579 zmedi=mod(zmedi,boxzsize)
2580 if (zmedi.lt.0) zmedi=zmedi+boxzsize
2582 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2583 do j=ielstart(i),ielend(i)
2584 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2588 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2589 r0ij=rpp(iteli,itelj)
2598 if (xj.lt.0) xj=xj+boxxsize
2600 if (yj.lt.0) yj=yj+boxysize
2602 if (zj.lt.0) zj=zj+boxzsize
2603 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2611 xj=xj_safe+xshift*boxxsize
2612 yj=yj_safe+yshift*boxysize
2613 zj=zj_safe+zshift*boxzsize
2614 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2615 if(dist_temp.lt.dist_init) then
2625 if (isubchap.eq.1) then
2634 rij=xj*xj+yj*yj+zj*zj
2635 sss=sscale(sqrt(rij))
2636 sssgrad=sscagrad(sqrt(rij))
2637 if (rij.lt.r0ijsq) then
2638 evdw1ij=0.25d0*(rij-r0ijsq)**2
2644 evdw1=evdw1+evdw1ij*sss
2646 C Calculate contributions to the Cartesian gradient.
2648 ggg(1)=fac*xj*sssgrad
2649 ggg(2)=fac*yj*sssgrad
2650 ggg(3)=fac*zj*sssgrad
2652 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2653 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2656 * Loop over residues i+1 thru j-1.
2660 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2665 cgrad do i=nnt,nct-1
2667 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2669 cgrad do j=i+1,nct-1
2671 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2677 c------------------------------------------------------------------------------
2678 subroutine vec_and_deriv
2679 implicit real*8 (a-h,o-z)
2680 include 'DIMENSIONS'
2684 include 'COMMON.IOUNITS'
2685 include 'COMMON.GEO'
2686 include 'COMMON.VAR'
2687 include 'COMMON.LOCAL'
2688 include 'COMMON.CHAIN'
2689 include 'COMMON.VECTORS'
2690 include 'COMMON.SETUP'
2691 include 'COMMON.TIME1'
2692 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2693 C Compute the local reference systems. For reference system (i), the
2694 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2695 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2697 do i=ivec_start,ivec_end
2701 if (i.eq.nres-1) then
2702 C Case of the last full residue
2703 C Compute the Z-axis
2704 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2705 costh=dcos(pi-theta(nres))
2706 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2710 C Compute the derivatives of uz
2712 uzder(2,1,1)=-dc_norm(3,i-1)
2713 uzder(3,1,1)= dc_norm(2,i-1)
2714 uzder(1,2,1)= dc_norm(3,i-1)
2716 uzder(3,2,1)=-dc_norm(1,i-1)
2717 uzder(1,3,1)=-dc_norm(2,i-1)
2718 uzder(2,3,1)= dc_norm(1,i-1)
2721 uzder(2,1,2)= dc_norm(3,i)
2722 uzder(3,1,2)=-dc_norm(2,i)
2723 uzder(1,2,2)=-dc_norm(3,i)
2725 uzder(3,2,2)= dc_norm(1,i)
2726 uzder(1,3,2)= dc_norm(2,i)
2727 uzder(2,3,2)=-dc_norm(1,i)
2729 C Compute the Y-axis
2732 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2734 C Compute the derivatives of uy
2737 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2738 & -dc_norm(k,i)*dc_norm(j,i-1)
2739 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2741 uyder(j,j,1)=uyder(j,j,1)-costh
2742 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2747 uygrad(l,k,j,i)=uyder(l,k,j)
2748 uzgrad(l,k,j,i)=uzder(l,k,j)
2752 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2753 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2754 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2755 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2758 C Compute the Z-axis
2759 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2760 costh=dcos(pi-theta(i+2))
2761 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2765 C Compute the derivatives of uz
2767 uzder(2,1,1)=-dc_norm(3,i+1)
2768 uzder(3,1,1)= dc_norm(2,i+1)
2769 uzder(1,2,1)= dc_norm(3,i+1)
2771 uzder(3,2,1)=-dc_norm(1,i+1)
2772 uzder(1,3,1)=-dc_norm(2,i+1)
2773 uzder(2,3,1)= dc_norm(1,i+1)
2776 uzder(2,1,2)= dc_norm(3,i)
2777 uzder(3,1,2)=-dc_norm(2,i)
2778 uzder(1,2,2)=-dc_norm(3,i)
2780 uzder(3,2,2)= dc_norm(1,i)
2781 uzder(1,3,2)= dc_norm(2,i)
2782 uzder(2,3,2)=-dc_norm(1,i)
2784 C Compute the Y-axis
2787 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2789 C Compute the derivatives of uy
2792 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2793 & -dc_norm(k,i)*dc_norm(j,i+1)
2794 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2796 uyder(j,j,1)=uyder(j,j,1)-costh
2797 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2802 uygrad(l,k,j,i)=uyder(l,k,j)
2803 uzgrad(l,k,j,i)=uzder(l,k,j)
2807 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2808 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2809 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2810 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2814 vbld_inv_temp(1)=vbld_inv(i+1)
2815 if (i.lt.nres-1) then
2816 vbld_inv_temp(2)=vbld_inv(i+2)
2818 vbld_inv_temp(2)=vbld_inv(i)
2823 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2824 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2829 #if defined(PARVEC) && defined(MPI)
2830 if (nfgtasks1.gt.1) then
2832 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2833 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2834 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2835 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2836 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2838 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2839 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2841 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2842 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2843 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2844 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2845 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2846 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2847 time_gather=time_gather+MPI_Wtime()-time00
2851 if (fg_rank.eq.0) then
2852 write (iout,*) "Arrays UY and UZ"
2854 write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2861 C-----------------------------------------------------------------------------
2862 subroutine check_vecgrad
2863 implicit real*8 (a-h,o-z)
2864 include 'DIMENSIONS'
2865 include 'COMMON.IOUNITS'
2866 include 'COMMON.GEO'
2867 include 'COMMON.VAR'
2868 include 'COMMON.LOCAL'
2869 include 'COMMON.CHAIN'
2870 include 'COMMON.VECTORS'
2871 dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2872 dimension uyt(3,maxres),uzt(3,maxres)
2873 dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2874 double precision delta /1.0d-7/
2877 crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2878 crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2879 crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2880 cd write(iout,'(2i5,2(3f10.5,5x))') i,1,
2881 cd & (dc_norm(if90,i),if90=1,3)
2882 cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2883 cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2884 cd write(iout,'(a)')
2890 uygradt(l,k,j,i)=uygrad(l,k,j,i)
2891 uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2904 cd write (iout,*) 'i=',i
2906 erij(k)=dc_norm(k,i)
2910 dc_norm(k,i)=erij(k)
2912 dc_norm(j,i)=dc_norm(j,i)+delta
2913 c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2915 c dc_norm(k,i)=dc_norm(k,i)/fac
2917 c write (iout,*) (dc_norm(k,i),k=1,3)
2918 c write (iout,*) (erij(k),k=1,3)
2921 uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2922 uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2923 uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2924 uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2926 c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2927 c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2928 c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2931 dc_norm(k,i)=erij(k)
2934 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2935 cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2936 cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2937 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2938 cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2939 cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2940 cd write (iout,'(a)')
2945 C--------------------------------------------------------------------------
2946 subroutine set_matrices
2947 implicit real*8 (a-h,o-z)
2948 include 'DIMENSIONS'
2951 include "COMMON.SETUP"
2953 integer status(MPI_STATUS_SIZE)
2955 include 'COMMON.IOUNITS'
2956 include 'COMMON.GEO'
2957 include 'COMMON.VAR'
2958 include 'COMMON.LOCAL'
2959 include 'COMMON.CHAIN'
2960 include 'COMMON.DERIV'
2961 include 'COMMON.INTERACT'
2962 include 'COMMON.CONTACTS'
2963 include 'COMMON.TORSION'
2964 include 'COMMON.VECTORS'
2965 include 'COMMON.FFIELD'
2966 double precision auxvec(2),auxmat(2,2)
2968 C Compute the virtual-bond-torsional-angle dependent quantities needed
2969 C to calculate the el-loc multibody terms of various order.
2971 c write(iout,*) 'nphi=',nphi,nres
2972 c write(iout,*) "itype2loc",itype2loc
2974 do i=ivec_start+2,ivec_end+2
2978 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2979 iti = itype2loc(itype(i-2))
2983 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2984 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2985 iti1 = itype2loc(itype(i-1))
2991 cost1=dcos(theta(i-1))
2992 sint1=dsin(theta(i-1))
2994 sint1cub=sint1sq*sint1
2995 sint1cost1=2*sint1*cost1
2996 c write (iout,*) "bnew1",i,iti
2997 c write (iout,*) (bnew1(k,1,iti),k=1,3)
2998 c write (iout,*) (bnew1(k,2,iti),k=1,3)
2999 c write (iout,*) "bnew2",i,iti
3000 c write (iout,*) (bnew2(k,1,iti),k=1,3)
3001 c write (iout,*) (bnew2(k,2,iti),k=1,3)
3003 b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3005 gtb1(k,i-2)=cost1*b1k-sint1sq*
3006 & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3007 b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3009 gtb2(k,i-2)=cost1*b2k-sint1sq*
3010 & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3013 aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3014 cc(1,k,i-2)=sint1sq*aux
3015 gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3016 & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3017 aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3018 dd(1,k,i-2)=sint1sq*aux
3019 gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3020 & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3022 cc(2,1,i-2)=cc(1,2,i-2)
3023 cc(2,2,i-2)=-cc(1,1,i-2)
3024 gtcc(2,1,i-2)=gtcc(1,2,i-2)
3025 gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3026 dd(2,1,i-2)=dd(1,2,i-2)
3027 dd(2,2,i-2)=-dd(1,1,i-2)
3028 gtdd(2,1,i-2)=gtdd(1,2,i-2)
3029 gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3032 aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3033 EE(l,k,i-2)=sint1sq*aux
3034 gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3037 EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3038 EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3039 EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3040 EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3041 gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3042 gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3043 gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3044 c b1tilde(1,i-2)=b1(1,i-2)
3045 c b1tilde(2,i-2)=-b1(2,i-2)
3046 c b2tilde(1,i-2)=b2(1,i-2)
3047 c b2tilde(2,i-2)=-b2(2,i-2)
3049 write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3050 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3051 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3052 write (iout,*) 'theta=', theta(i-1)
3055 if (i.gt. nnt+2 .and. i.lt.nct+2) then
3056 iti = itype2loc(itype(i-2))
3060 c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3061 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3062 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3063 iti1 = itype2loc(itype(i-1))
3073 CC(k,l,i-2)=ccold(k,l,iti)
3074 DD(k,l,i-2)=ddold(k,l,iti)
3075 EE(k,l,i-2)=eeold(k,l,iti)
3080 b1tilde(1,i-2)= b1(1,i-2)
3081 b1tilde(2,i-2)=-b1(2,i-2)
3082 b2tilde(1,i-2)= b2(1,i-2)
3083 b2tilde(2,i-2)=-b2(2,i-2)
3085 Ctilde(1,1,i-2)= CC(1,1,i-2)
3086 Ctilde(1,2,i-2)= CC(1,2,i-2)
3087 Ctilde(2,1,i-2)=-CC(2,1,i-2)
3088 Ctilde(2,2,i-2)=-CC(2,2,i-2)
3090 Dtilde(1,1,i-2)= DD(1,1,i-2)
3091 Dtilde(1,2,i-2)= DD(1,2,i-2)
3092 Dtilde(2,1,i-2)=-DD(2,1,i-2)
3093 Dtilde(2,2,i-2)=-DD(2,2,i-2)
3095 write(iout,*) "i",i," iti",iti
3096 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3097 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3101 do i=ivec_start+2,ivec_end+2
3105 if (i .lt. nres+1) then
3142 if (i .gt. 3 .and. i .lt. nres+1) then
3143 obrot_der(1,i-2)=-sin1
3144 obrot_der(2,i-2)= cos1
3145 Ugder(1,1,i-2)= sin1
3146 Ugder(1,2,i-2)=-cos1
3147 Ugder(2,1,i-2)=-cos1
3148 Ugder(2,2,i-2)=-sin1
3151 obrot2_der(1,i-2)=-dwasin2
3152 obrot2_der(2,i-2)= dwacos2
3153 Ug2der(1,1,i-2)= dwasin2
3154 Ug2der(1,2,i-2)=-dwacos2
3155 Ug2der(2,1,i-2)=-dwacos2
3156 Ug2der(2,2,i-2)=-dwasin2
3158 obrot_der(1,i-2)=0.0d0
3159 obrot_der(2,i-2)=0.0d0
3160 Ugder(1,1,i-2)=0.0d0
3161 Ugder(1,2,i-2)=0.0d0
3162 Ugder(2,1,i-2)=0.0d0
3163 Ugder(2,2,i-2)=0.0d0
3164 obrot2_der(1,i-2)=0.0d0
3165 obrot2_der(2,i-2)=0.0d0
3166 Ug2der(1,1,i-2)=0.0d0
3167 Ug2der(1,2,i-2)=0.0d0
3168 Ug2der(2,1,i-2)=0.0d0
3169 Ug2der(2,2,i-2)=0.0d0
3171 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3172 if (i.gt. nnt+2 .and. i.lt.nct+2) then
3173 iti = itype2loc(itype(i-2))
3177 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3178 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3179 iti1 = itype2loc(itype(i-1))
3183 cd write (iout,*) '*******i',i,' iti1',iti
3184 cd write (iout,*) 'b1',b1(:,iti)
3185 cd write (iout,*) 'b2',b2(:,iti)
3186 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3187 c if (i .gt. iatel_s+2) then
3188 if (i .gt. nnt+2) then
3189 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3191 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3192 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3194 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3195 c & EE(1,2,iti),EE(2,2,i)
3196 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3197 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3198 c write(iout,*) "Macierz EUG",
3199 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3201 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3203 call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3204 call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3205 call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3206 call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3207 call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3218 DtUg2(l,k,i-2)=0.0d0
3222 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3223 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3225 muder(k,i-2)=Ub2der(k,i-2)
3227 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3228 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3229 if (itype(i-1).le.ntyp) then
3230 iti1 = itype2loc(itype(i-1))
3238 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3239 c mu(k,i-2)=b1(k,i-1)
3240 c mu(k,i-2)=Ub2(k,i-2)
3243 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3244 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3245 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3246 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3247 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3248 & ((ee(l,k,i-2),l=1,2),k=1,2)
3250 cd write (iout,*) 'mu1',mu1(:,i-2)
3251 cd write (iout,*) 'mu2',mu2(:,i-2)
3252 cd write (iout,*) 'mu',i-2,mu(:,i-2)
3253 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3255 call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3256 call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3257 call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3258 call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3259 call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3260 C Vectors and matrices dependent on a single virtual-bond dihedral.
3261 call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3262 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3263 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3264 call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3265 call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3266 call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3267 call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3268 call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3269 call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3272 C Matrices dependent on two consecutive virtual-bond dihedrals.
3273 C The order of matrices is from left to right.
3274 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3276 c do i=max0(ivec_start,2),ivec_end
3278 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3279 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3280 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3281 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3282 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3283 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3284 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3285 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3288 #if defined(MPI) && defined(PARMAT)
3290 c if (fg_rank.eq.0) then
3291 write (iout,*) "Arrays UG and UGDER before GATHER"
3293 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3294 & ((ug(l,k,i),l=1,2),k=1,2),
3295 & ((ugder(l,k,i),l=1,2),k=1,2)
3297 write (iout,*) "Arrays UG2 and UG2DER"
3299 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3300 & ((ug2(l,k,i),l=1,2),k=1,2),
3301 & ((ug2der(l,k,i),l=1,2),k=1,2)
3303 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3305 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3306 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3307 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3309 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3311 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3312 & costab(i),sintab(i),costab2(i),sintab2(i)
3314 write (iout,*) "Array MUDER"
3316 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3320 if (nfgtasks.gt.1) then
3322 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3323 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3324 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3326 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3327 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3329 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3330 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3332 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3333 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3335 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3336 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3338 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3339 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3341 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3342 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3344 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3345 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3346 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3347 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3348 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3349 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3350 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3351 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3352 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3353 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3354 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3355 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3356 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3358 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3359 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3361 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3362 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3364 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3365 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3367 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3368 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3370 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3371 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3373 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3374 & ivec_count(fg_rank1),
3375 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3377 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3378 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3380 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3381 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3383 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3384 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3386 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3387 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3389 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3390 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3392 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3393 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3395 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3396 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3398 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3399 & ivec_count(fg_rank1),
3400 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3402 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3403 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3405 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3406 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3408 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3409 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3411 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3412 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3414 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3415 & ivec_count(fg_rank1),
3416 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3418 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3419 & ivec_count(fg_rank1),
3420 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3422 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3423 & ivec_count(fg_rank1),
3424 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3425 & MPI_MAT2,FG_COMM1,IERR)
3426 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3427 & ivec_count(fg_rank1),
3428 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3429 & MPI_MAT2,FG_COMM1,IERR)
3432 c Passes matrix info through the ring
3435 if (irecv.lt.0) irecv=nfgtasks1-1
3438 if (inext.ge.nfgtasks1) inext=0
3440 c write (iout,*) "isend",isend," irecv",irecv
3442 lensend=lentyp(isend)
3443 lenrecv=lentyp(irecv)
3444 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3445 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3446 c & MPI_ROTAT1(lensend),inext,2200+isend,
3447 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3448 c & iprev,2200+irecv,FG_COMM,status,IERR)
3449 c write (iout,*) "Gather ROTAT1"
3451 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3452 c & MPI_ROTAT2(lensend),inext,3300+isend,
3453 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3454 c & iprev,3300+irecv,FG_COMM,status,IERR)
3455 c write (iout,*) "Gather ROTAT2"
3457 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3458 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3459 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3460 & iprev,4400+irecv,FG_COMM,status,IERR)
3461 c write (iout,*) "Gather ROTAT_OLD"
3463 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3464 & MPI_PRECOMP11(lensend),inext,5500+isend,
3465 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3466 & iprev,5500+irecv,FG_COMM,status,IERR)
3467 c write (iout,*) "Gather PRECOMP11"
3469 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3470 & MPI_PRECOMP12(lensend),inext,6600+isend,
3471 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3472 & iprev,6600+irecv,FG_COMM,status,IERR)
3473 c write (iout,*) "Gather PRECOMP12"
3475 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3477 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3478 & MPI_ROTAT2(lensend),inext,7700+isend,
3479 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3480 & iprev,7700+irecv,FG_COMM,status,IERR)
3481 c write (iout,*) "Gather PRECOMP21"
3483 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3484 & MPI_PRECOMP22(lensend),inext,8800+isend,
3485 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3486 & iprev,8800+irecv,FG_COMM,status,IERR)
3487 c write (iout,*) "Gather PRECOMP22"
3489 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3490 & MPI_PRECOMP23(lensend),inext,9900+isend,
3491 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3492 & MPI_PRECOMP23(lenrecv),
3493 & iprev,9900+irecv,FG_COMM,status,IERR)
3494 c write (iout,*) "Gather PRECOMP23"
3499 if (irecv.lt.0) irecv=nfgtasks1-1
3502 time_gather=time_gather+MPI_Wtime()-time00
3505 c if (fg_rank.eq.0) then
3506 write (iout,*) "Arrays UG and UGDER"
3508 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3509 & ((ug(l,k,i),l=1,2),k=1,2),
3510 & ((ugder(l,k,i),l=1,2),k=1,2)
3512 write (iout,*) "Arrays UG2 and UG2DER"
3514 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3515 & ((ug2(l,k,i),l=1,2),k=1,2),
3516 & ((ug2der(l,k,i),l=1,2),k=1,2)
3518 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3520 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3521 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3522 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3524 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3526 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3527 & costab(i),sintab(i),costab2(i),sintab2(i)
3529 write (iout,*) "Array MUDER"
3531 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3537 cd iti = itype2loc(itype(i))
3540 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3541 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3546 C--------------------------------------------------------------------------
3547 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3549 C This subroutine calculates the average interaction energy and its gradient
3550 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3551 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3552 C The potential depends both on the distance of peptide-group centers and on
3553 C the orientation of the CA-CA virtual bonds.
3555 implicit real*8 (a-h,o-z)
3559 include 'DIMENSIONS'
3560 include 'COMMON.CONTROL'
3561 include 'COMMON.SETUP'
3562 include 'COMMON.IOUNITS'
3563 include 'COMMON.GEO'
3564 include 'COMMON.VAR'
3565 include 'COMMON.LOCAL'
3566 include 'COMMON.CHAIN'
3567 include 'COMMON.DERIV'
3568 include 'COMMON.INTERACT'
3569 include 'COMMON.CONTACTS'
3570 include 'COMMON.TORSION'
3571 include 'COMMON.VECTORS'
3572 include 'COMMON.FFIELD'
3573 include 'COMMON.TIME1'
3574 include 'COMMON.SPLITELE'
3575 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3576 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3577 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3578 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3579 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3580 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3582 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3584 double precision scal_el /1.0d0/
3586 double precision scal_el /0.5d0/
3589 C 13-go grudnia roku pamietnego...
3590 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3591 & 0.0d0,1.0d0,0.0d0,
3592 & 0.0d0,0.0d0,1.0d0/
3593 cd write(iout,*) 'In EELEC'
3595 cd write(iout,*) 'Type',i
3596 cd write(iout,*) 'B1',B1(:,i)
3597 cd write(iout,*) 'B2',B2(:,i)
3598 cd write(iout,*) 'CC',CC(:,:,i)
3599 cd write(iout,*) 'DD',DD(:,:,i)
3600 cd write(iout,*) 'EE',EE(:,:,i)
3602 cd call check_vecgrad
3604 if (icheckgrad.eq.1) then
3606 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3608 dc_norm(k,i)=dc(k,i)*fac
3610 c write (iout,*) 'i',i,' fac',fac
3613 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3614 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3615 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3616 c call vec_and_deriv
3622 time_mat=time_mat+MPI_Wtime()-time01
3626 cd write (iout,*) 'i=',i
3628 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3631 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3632 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3645 cd print '(a)','Enter EELEC'
3646 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3648 gel_loc_loc(i)=0.0d0
3653 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3655 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3657 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3658 do i=iturn3_start,iturn3_end
3660 C write(iout,*) "tu jest i",i
3661 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3662 C changes suggested by Ana to avoid out of bounds
3663 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3664 c & .or.((i+4).gt.nres)
3665 c & .or.((i-1).le.0)
3666 C end of changes by Ana
3667 & .or. itype(i+2).eq.ntyp1
3668 & .or. itype(i+3).eq.ntyp1) cycle
3669 C Adam: Instructions below will switch off existing interactions
3671 c if(itype(i-1).eq.ntyp1)cycle
3673 c if(i.LT.nres-3)then
3674 c if (itype(i+4).eq.ntyp1) cycle
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 xmedi=mod(xmedi,boxxsize)
3686 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3687 ymedi=mod(ymedi,boxysize)
3688 if (ymedi.lt.0) ymedi=ymedi+boxysize
3689 zmedi=mod(zmedi,boxzsize)
3690 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3692 call eelecij(i,i+2,ees,evdw1,eel_loc)
3693 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3694 num_cont_hb(i)=num_conti
3696 do i=iturn4_start,iturn4_end
3698 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3699 C changes suggested by Ana to avoid out of bounds
3700 c & .or.((i+5).gt.nres)
3701 c & .or.((i-1).le.0)
3702 C end of changes suggested by Ana
3703 & .or. itype(i+3).eq.ntyp1
3704 & .or. itype(i+4).eq.ntyp1
3705 c & .or. itype(i+5).eq.ntyp1
3706 c & .or. itype(i).eq.ntyp1
3707 c & .or. itype(i-1).eq.ntyp1
3712 dx_normi=dc_norm(1,i)
3713 dy_normi=dc_norm(2,i)
3714 dz_normi=dc_norm(3,i)
3715 xmedi=c(1,i)+0.5d0*dxi
3716 ymedi=c(2,i)+0.5d0*dyi
3717 zmedi=c(3,i)+0.5d0*dzi
3718 C Return atom into box, boxxsize is size of box in x dimension
3720 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3721 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3722 C Condition for being inside the proper box
3723 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3724 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3728 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3729 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3730 C Condition for being inside the proper box
3731 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3732 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3736 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3737 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3738 C Condition for being inside the proper box
3739 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3740 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3743 xmedi=mod(xmedi,boxxsize)
3744 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3745 ymedi=mod(ymedi,boxysize)
3746 if (ymedi.lt.0) ymedi=ymedi+boxysize
3747 zmedi=mod(zmedi,boxzsize)
3748 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3750 num_conti=num_cont_hb(i)
3751 c write(iout,*) "JESTEM W PETLI"
3752 call eelecij(i,i+3,ees,evdw1,eel_loc)
3753 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3754 & call eturn4(i,eello_turn4)
3755 num_cont_hb(i)=num_conti
3757 C Loop over all neighbouring boxes
3762 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3765 do i=iatel_s,iatel_e
3768 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3769 C changes suggested by Ana to avoid out of bounds
3770 c & .or.((i+2).gt.nres)
3771 c & .or.((i-1).le.0)
3772 C end of changes by Ana
3773 c & .or. itype(i+2).eq.ntyp1
3774 c & .or. itype(i-1).eq.ntyp1
3779 dx_normi=dc_norm(1,i)
3780 dy_normi=dc_norm(2,i)
3781 dz_normi=dc_norm(3,i)
3782 xmedi=c(1,i)+0.5d0*dxi
3783 ymedi=c(2,i)+0.5d0*dyi
3784 zmedi=c(3,i)+0.5d0*dzi
3785 xmedi=mod(xmedi,boxxsize)
3786 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3787 ymedi=mod(ymedi,boxysize)
3788 if (ymedi.lt.0) ymedi=ymedi+boxysize
3789 zmedi=mod(zmedi,boxzsize)
3790 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3791 C xmedi=xmedi+xshift*boxxsize
3792 C ymedi=ymedi+yshift*boxysize
3793 C zmedi=zmedi+zshift*boxzsize
3795 C Return tom into box, boxxsize is size of box in x dimension
3797 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3798 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3799 C Condition for being inside the proper box
3800 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3801 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3805 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3806 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3807 C Condition for being inside the proper box
3808 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3809 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3813 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3814 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3815 cC Condition for being inside the proper box
3816 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3817 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3821 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3822 num_conti=num_cont_hb(i)
3824 do j=ielstart(i),ielend(i)
3826 C write (iout,*) i,j
3828 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3829 C changes suggested by Ana to avoid out of bounds
3830 c & .or.((j+2).gt.nres)
3831 c & .or.((j-1).le.0)
3832 C end of changes by Ana
3833 c & .or.itype(j+2).eq.ntyp1
3834 c & .or.itype(j-1).eq.ntyp1
3836 call eelecij(i,j,ees,evdw1,eel_loc)
3838 num_cont_hb(i)=num_conti
3844 c write (iout,*) "Number of loop steps in EELEC:",ind
3846 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3847 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3849 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3850 ccc eel_loc=eel_loc+eello_turn3
3851 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3854 C-------------------------------------------------------------------------------
3855 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3856 implicit real*8 (a-h,o-z)
3857 include 'DIMENSIONS'
3861 include 'COMMON.CONTROL'
3862 include 'COMMON.IOUNITS'
3863 include 'COMMON.GEO'
3864 include 'COMMON.VAR'
3865 include 'COMMON.LOCAL'
3866 include 'COMMON.CHAIN'
3867 include 'COMMON.DERIV'
3868 include 'COMMON.INTERACT'
3869 include 'COMMON.CONTACTS'
3870 include 'COMMON.TORSION'
3871 include 'COMMON.VECTORS'
3872 include 'COMMON.FFIELD'
3873 include 'COMMON.TIME1'
3874 include 'COMMON.SPLITELE'
3875 include 'COMMON.SHIELD'
3876 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3877 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3878 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3879 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3880 & gmuij2(4),gmuji2(4)
3881 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3882 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3884 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3886 double precision scal_el /1.0d0/
3888 double precision scal_el /0.5d0/
3891 C 13-go grudnia roku pamietnego...
3892 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3893 & 0.0d0,1.0d0,0.0d0,
3894 & 0.0d0,0.0d0,1.0d0/
3895 integer xshift,yshift,zshift
3896 c time00=MPI_Wtime()
3897 cd write (iout,*) "eelecij",i,j
3901 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3902 aaa=app(iteli,itelj)
3903 bbb=bpp(iteli,itelj)
3904 ael6i=ael6(iteli,itelj)
3905 ael3i=ael3(iteli,itelj)
3909 dx_normj=dc_norm(1,j)
3910 dy_normj=dc_norm(2,j)
3911 dz_normj=dc_norm(3,j)
3912 C xj=c(1,j)+0.5D0*dxj-xmedi
3913 C yj=c(2,j)+0.5D0*dyj-ymedi
3914 C zj=c(3,j)+0.5D0*dzj-zmedi
3919 if (xj.lt.0) xj=xj+boxxsize
3921 if (yj.lt.0) yj=yj+boxysize
3923 if (zj.lt.0) zj=zj+boxzsize
3924 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3925 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3933 xj=xj_safe+xshift*boxxsize
3934 yj=yj_safe+yshift*boxysize
3935 zj=zj_safe+zshift*boxzsize
3936 dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3937 if(dist_temp.lt.dist_init) then
3947 if (isubchap.eq.1) then
3956 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3958 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3959 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3960 C Condition for being inside the proper box
3961 c if ((xj.gt.((0.5d0)*boxxsize)).or.
3962 c & (xj.lt.((-0.5d0)*boxxsize))) then
3966 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3967 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3968 C Condition for being inside the proper box
3969 c if ((yj.gt.((0.5d0)*boxysize)).or.
3970 c & (yj.lt.((-0.5d0)*boxysize))) then
3974 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3975 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3976 C Condition for being inside the proper box
3977 c if ((zj.gt.((0.5d0)*boxzsize)).or.
3978 c & (zj.lt.((-0.5d0)*boxzsize))) then
3981 C endif !endPBC condintion
3985 rij=xj*xj+yj*yj+zj*zj
3987 sss=sscale(sqrt(rij))
3988 sssgrad=sscagrad(sqrt(rij))
3989 c if (sss.gt.0.0d0) then
3995 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3996 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3997 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3998 fac=cosa-3.0D0*cosb*cosg
4000 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4001 if (j.eq.i+2) ev1=scal_el*ev1
4006 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4010 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4011 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4012 if (shield_mode.gt.0) then
4015 el1=el1*fac_shield(i)**2*fac_shield(j)**2
4016 el2=el2*fac_shield(i)**2*fac_shield(j)**2
4025 evdw1=evdw1+evdwij*sss
4026 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4027 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4028 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
4029 cd & xmedi,ymedi,zmedi,xj,yj,zj
4031 if (energy_dec) then
4032 write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
4034 &,iteli,itelj,aaa,evdw1,sss
4035 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4036 &fac_shield(i),fac_shield(j)
4040 C Calculate contributions to the Cartesian gradient.
4043 facvdw=-6*rrmij*(ev1+evdwij)*sss
4044 facel=-3*rrmij*(el1+eesij)
4051 * Radial derivatives. First process both termini of the fragment (i,j)
4056 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4057 & (shield_mode.gt.0)) then
4059 do ilist=1,ishield_list(i)
4060 iresshield=shield_list(ilist,i)
4062 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4064 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4066 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4067 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4068 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4069 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4070 C if (iresshield.gt.i) then
4071 C do ishi=i+1,iresshield-1
4072 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4073 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4077 C do ishi=iresshield,i
4078 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4079 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4085 do ilist=1,ishield_list(j)
4086 iresshield=shield_list(ilist,j)
4088 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4090 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4092 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4093 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4095 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4096 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4097 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4098 C if (iresshield.gt.j) then
4099 C do ishi=j+1,iresshield-1
4100 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4101 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4105 C do ishi=iresshield,j
4106 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4107 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4114 gshieldc(k,i)=gshieldc(k,i)+
4115 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4116 gshieldc(k,j)=gshieldc(k,j)+
4117 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4118 gshieldc(k,i-1)=gshieldc(k,i-1)+
4119 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4120 gshieldc(k,j-1)=gshieldc(k,j-1)+
4121 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4126 c ghalf=0.5D0*ggg(k)
4127 c gelc(k,i)=gelc(k,i)+ghalf
4128 c gelc(k,j)=gelc(k,j)+ghalf
4130 c 9/28/08 AL Gradient compotents will be summed only at the end
4131 C print *,"before", gelc_long(1,i), gelc_long(1,j)
4133 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4134 C & +grad_shield(k,j)*eesij/fac_shield(j)
4135 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4136 C & +grad_shield(k,i)*eesij/fac_shield(i)
4137 C gelc_long(k,i-1)=gelc_long(k,i-1)
4138 C & +grad_shield(k,i)*eesij/fac_shield(i)
4139 C gelc_long(k,j-1)=gelc_long(k,j-1)
4140 C & +grad_shield(k,j)*eesij/fac_shield(j)
4142 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4145 * Loop over residues i+1 thru j-1.
4149 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4152 if (sss.gt.0.0) then
4153 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4154 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4155 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4162 c ghalf=0.5D0*ggg(k)
4163 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4164 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4166 c 9/28/08 AL Gradient compotents will be summed only at the end
4168 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4169 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4172 * Loop over residues i+1 thru j-1.
4176 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4181 facvdw=(ev1+evdwij)*sss
4184 fac=-3*rrmij*(facvdw+facvdw+facel)
4189 * Radial derivatives. First process both termini of the fragment (i,j)
4192 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4194 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4196 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4198 c ghalf=0.5D0*ggg(k)
4199 c gelc(k,i)=gelc(k,i)+ghalf
4200 c gelc(k,j)=gelc(k,j)+ghalf
4202 c 9/28/08 AL Gradient compotents will be summed only at the end
4204 gelc_long(k,j)=gelc(k,j)+ggg(k)
4205 gelc_long(k,i)=gelc(k,i)-ggg(k)
4208 * Loop over residues i+1 thru j-1.
4212 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4215 c 9/28/08 AL Gradient compotents will be summed only at the end
4216 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4217 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4218 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4220 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4221 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4227 ecosa=2.0D0*fac3*fac1+fac4
4230 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4231 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4233 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4234 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4236 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4237 cd & (dcosg(k),k=1,3)
4239 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4240 & fac_shield(i)**2*fac_shield(j)**2
4243 c ghalf=0.5D0*ggg(k)
4244 c gelc(k,i)=gelc(k,i)+ghalf
4245 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4246 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4247 c gelc(k,j)=gelc(k,j)+ghalf
4248 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4249 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4253 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4256 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4259 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4260 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4261 & *fac_shield(i)**2*fac_shield(j)**2
4263 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4264 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4265 & *fac_shield(i)**2*fac_shield(j)**2
4266 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4267 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4269 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4273 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4274 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4275 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4277 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4278 C energy of a peptide unit is assumed in the form of a second-order
4279 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4280 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4281 C are computed for EVERY pair of non-contiguous peptide groups.
4284 if (j.lt.nres-1) then
4296 muij(kkk)=mu(k,i)*mu(l,j)
4297 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4299 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4300 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4301 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4302 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4303 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4304 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4309 write (iout,*) 'EELEC: i',i,' j',j
4310 write (iout,*) 'j',j,' j1',j1,' j2',j2
4311 write(iout,*) 'muij',muij
4313 ury=scalar(uy(1,i),erij)
4314 urz=scalar(uz(1,i),erij)
4315 vry=scalar(uy(1,j),erij)
4316 vrz=scalar(uz(1,j),erij)
4317 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4318 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4319 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4320 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4321 fac=dsqrt(-ael6i)*r3ij
4323 write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4324 write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4325 & "uyvz",scalar(uy(1,i),uz(1,j)),
4326 & "uzvy",scalar(uz(1,i),uy(1,j)),
4327 & "uzvz",scalar(uz(1,i),uz(1,j))
4328 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4329 write (iout,*) "fac",fac
4336 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4339 cd write (iout,'(4i5,4f10.5)')
4340 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4341 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4342 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4343 cd & uy(:,j),uz(:,j)
4344 cd write (iout,'(4f10.5)')
4345 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4346 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4347 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4348 cd write (iout,'(9f10.5/)')
4349 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4350 C Derivatives of the elements of A in virtual-bond vectors
4351 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4353 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4354 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4355 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4356 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4357 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4358 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4359 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4360 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4361 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4362 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4363 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4364 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4366 C Compute radial contributions to the gradient
4384 C Add the contributions coming from er
4387 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4388 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4389 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4390 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4393 C Derivatives in DC(i)
4394 cgrad ghalf1=0.5d0*agg(k,1)
4395 cgrad ghalf2=0.5d0*agg(k,2)
4396 cgrad ghalf3=0.5d0*agg(k,3)
4397 cgrad ghalf4=0.5d0*agg(k,4)
4398 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4399 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4400 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4401 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4402 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4403 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4404 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4405 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4406 C Derivatives in DC(i+1)
4407 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4408 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4409 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4410 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4411 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4412 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4413 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4414 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4415 C Derivatives in DC(j)
4416 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4417 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4418 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4419 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4420 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4421 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4422 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4423 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4424 C Derivatives in DC(j+1) or DC(nres-1)
4425 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4426 & -3.0d0*vryg(k,3)*ury)
4427 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4428 & -3.0d0*vrzg(k,3)*ury)
4429 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4430 & -3.0d0*vryg(k,3)*urz)
4431 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4432 & -3.0d0*vrzg(k,3)*urz)
4433 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4435 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4448 aggi(k,l)=-aggi(k,l)
4449 aggi1(k,l)=-aggi1(k,l)
4450 aggj(k,l)=-aggj(k,l)
4451 aggj1(k,l)=-aggj1(k,l)
4454 if (j.lt.nres-1) then
4460 aggi(k,l)=-aggi(k,l)
4461 aggi1(k,l)=-aggi1(k,l)
4462 aggj(k,l)=-aggj(k,l)
4463 aggj1(k,l)=-aggj1(k,l)
4474 aggi(k,l)=-aggi(k,l)
4475 aggi1(k,l)=-aggi1(k,l)
4476 aggj(k,l)=-aggj(k,l)
4477 aggj1(k,l)=-aggj1(k,l)
4482 IF (wel_loc.gt.0.0d0) THEN
4483 C Contribution to the local-electrostatic energy coming from the i-j pair
4484 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4487 write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4489 write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4490 & " wel_loc",wel_loc
4492 if (shield_mode.eq.0) then
4499 eel_loc_ij=eel_loc_ij
4500 & *fac_shield(i)*fac_shield(j)
4501 c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4502 c & 'eelloc',i,j,eel_loc_ij
4503 C Now derivative over eel_loc
4504 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4505 & (shield_mode.gt.0)) then
4508 do ilist=1,ishield_list(i)
4509 iresshield=shield_list(ilist,i)
4511 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4514 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4516 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4517 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4521 do ilist=1,ishield_list(j)
4522 iresshield=shield_list(ilist,j)
4524 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4527 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4529 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4530 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4537 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4538 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4539 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4540 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4541 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4542 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4543 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4544 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4549 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4550 c & ' eel_loc_ij',eel_loc_ij
4551 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4552 C Calculate patrial derivative for theta angle
4554 geel_loc_ij=(a22*gmuij1(1)
4558 & *fac_shield(i)*fac_shield(j)
4559 c write(iout,*) "derivative over thatai"
4560 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4562 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4563 & geel_loc_ij*wel_loc
4564 c write(iout,*) "derivative over thatai-1"
4565 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4572 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4573 & geel_loc_ij*wel_loc
4574 & *fac_shield(i)*fac_shield(j)
4576 c Derivative over j residue
4577 geel_loc_ji=a22*gmuji1(1)
4581 c write(iout,*) "derivative over thataj"
4582 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4585 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4586 & geel_loc_ji*wel_loc
4587 & *fac_shield(i)*fac_shield(j)
4594 c write(iout,*) "derivative over thataj-1"
4595 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4597 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4598 & geel_loc_ji*wel_loc
4599 & *fac_shield(i)*fac_shield(j)
4601 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4603 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4604 & 'eelloc',i,j,eel_loc_ij
4605 c if (eel_loc_ij.ne.0)
4606 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4607 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4609 eel_loc=eel_loc+eel_loc_ij
4610 C Partial derivatives in virtual-bond dihedral angles gamma
4612 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4613 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4614 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4615 & *fac_shield(i)*fac_shield(j)
4617 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4618 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4619 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4620 & *fac_shield(i)*fac_shield(j)
4621 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4623 ggg(l)=(agg(l,1)*muij(1)+
4624 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4625 & *fac_shield(i)*fac_shield(j)
4626 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4627 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4628 cgrad ghalf=0.5d0*ggg(l)
4629 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4630 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4634 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4637 C Remaining derivatives of eello
4639 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4640 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4641 & *fac_shield(i)*fac_shield(j)
4643 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4644 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4645 & *fac_shield(i)*fac_shield(j)
4647 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4648 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4649 & *fac_shield(i)*fac_shield(j)
4651 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4652 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4653 & *fac_shield(i)*fac_shield(j)
4657 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4658 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4659 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4660 & .and. num_conti.le.maxconts) then
4661 c write (iout,*) i,j," entered corr"
4663 C Calculate the contact function. The ith column of the array JCONT will
4664 C contain the numbers of atoms that make contacts with the atom I (of numbers
4665 C greater than I). The arrays FACONT and GACONT will contain the values of
4666 C the contact function and its derivative.
4667 c r0ij=1.02D0*rpp(iteli,itelj)
4668 c r0ij=1.11D0*rpp(iteli,itelj)
4669 r0ij=2.20D0*rpp(iteli,itelj)
4670 c r0ij=1.55D0*rpp(iteli,itelj)
4671 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4672 if (fcont.gt.0.0D0) then
4673 num_conti=num_conti+1
4674 if (num_conti.gt.maxconts) then
4675 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4676 & ' will skip next contacts for this conf.'
4678 jcont_hb(num_conti,i)=j
4679 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4680 cd & " jcont_hb",jcont_hb(num_conti,i)
4681 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4682 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4683 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4685 d_cont(num_conti,i)=rij
4686 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4687 C --- Electrostatic-interaction matrix ---
4688 a_chuj(1,1,num_conti,i)=a22
4689 a_chuj(1,2,num_conti,i)=a23
4690 a_chuj(2,1,num_conti,i)=a32
4691 a_chuj(2,2,num_conti,i)=a33
4692 C --- Gradient of rij
4694 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4701 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4702 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4703 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4704 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4705 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4710 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4711 C Calculate contact energies
4713 wij=cosa-3.0D0*cosb*cosg
4716 c fac3=dsqrt(-ael6i)/r0ij**3
4717 fac3=dsqrt(-ael6i)*r3ij
4718 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4719 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4720 if (ees0tmp.gt.0) then
4721 ees0pij=dsqrt(ees0tmp)
4725 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4726 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4727 if (ees0tmp.gt.0) then
4728 ees0mij=dsqrt(ees0tmp)
4733 if (shield_mode.eq.0) then
4737 ees0plist(num_conti,i)=j
4738 C fac_shield(i)=0.4d0
4739 C fac_shield(j)=0.6d0
4741 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4742 & *fac_shield(i)*fac_shield(j)
4743 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4744 & *fac_shield(i)*fac_shield(j)
4745 C Diagnostics. Comment out or remove after debugging!
4746 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4747 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4748 c ees0m(num_conti,i)=0.0D0
4750 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4751 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4752 C Angular derivatives of the contact function
4753 ees0pij1=fac3/ees0pij
4754 ees0mij1=fac3/ees0mij
4755 fac3p=-3.0D0*fac3*rrmij
4756 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4757 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4759 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4760 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4761 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4762 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4763 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4764 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4765 ecosap=ecosa1+ecosa2
4766 ecosbp=ecosb1+ecosb2
4767 ecosgp=ecosg1+ecosg2
4768 ecosam=ecosa1-ecosa2
4769 ecosbm=ecosb1-ecosb2
4770 ecosgm=ecosg1-ecosg2
4779 facont_hb(num_conti,i)=fcont
4780 fprimcont=fprimcont/rij
4781 cd facont_hb(num_conti,i)=1.0D0
4782 C Following line is for diagnostics.
4785 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4786 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4789 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4790 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4792 gggp(1)=gggp(1)+ees0pijp*xj
4793 gggp(2)=gggp(2)+ees0pijp*yj
4794 gggp(3)=gggp(3)+ees0pijp*zj
4795 gggm(1)=gggm(1)+ees0mijp*xj
4796 gggm(2)=gggm(2)+ees0mijp*yj
4797 gggm(3)=gggm(3)+ees0mijp*zj
4798 C Derivatives due to the contact function
4799 gacont_hbr(1,num_conti,i)=fprimcont*xj
4800 gacont_hbr(2,num_conti,i)=fprimcont*yj
4801 gacont_hbr(3,num_conti,i)=fprimcont*zj
4804 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4805 c following the change of gradient-summation algorithm.
4807 cgrad ghalfp=0.5D0*gggp(k)
4808 cgrad ghalfm=0.5D0*gggm(k)
4809 gacontp_hb1(k,num_conti,i)=!ghalfp
4810 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4811 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4812 & *fac_shield(i)*fac_shield(j)
4814 gacontp_hb2(k,num_conti,i)=!ghalfp
4815 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4816 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4817 & *fac_shield(i)*fac_shield(j)
4819 gacontp_hb3(k,num_conti,i)=gggp(k)
4820 & *fac_shield(i)*fac_shield(j)
4822 gacontm_hb1(k,num_conti,i)=!ghalfm
4823 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4824 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4825 & *fac_shield(i)*fac_shield(j)
4827 gacontm_hb2(k,num_conti,i)=!ghalfm
4828 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4829 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4830 & *fac_shield(i)*fac_shield(j)
4832 gacontm_hb3(k,num_conti,i)=gggm(k)
4833 & *fac_shield(i)*fac_shield(j)
4836 C Diagnostics. Comment out or remove after debugging!
4838 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4839 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4840 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4841 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4842 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4843 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4846 endif ! num_conti.le.maxconts
4849 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4852 ghalf=0.5d0*agg(l,k)
4853 aggi(l,k)=aggi(l,k)+ghalf
4854 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4855 aggj(l,k)=aggj(l,k)+ghalf
4858 if (j.eq.nres-1 .and. i.lt.j-2) then
4861 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4866 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4869 C-----------------------------------------------------------------------------
4870 subroutine eturn3(i,eello_turn3)
4871 C Third- and fourth-order contributions from turns
4872 implicit real*8 (a-h,o-z)
4873 include 'DIMENSIONS'
4874 include 'COMMON.IOUNITS'
4875 include 'COMMON.GEO'
4876 include 'COMMON.VAR'
4877 include 'COMMON.LOCAL'
4878 include 'COMMON.CHAIN'
4879 include 'COMMON.DERIV'
4880 include 'COMMON.INTERACT'
4881 include 'COMMON.CONTACTS'
4882 include 'COMMON.TORSION'
4883 include 'COMMON.VECTORS'
4884 include 'COMMON.FFIELD'
4885 include 'COMMON.CONTROL'
4886 include 'COMMON.SHIELD'
4888 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4889 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4890 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4891 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4892 & auxgmat2(2,2),auxgmatt2(2,2)
4893 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4894 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4895 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4896 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4899 c write (iout,*) "eturn3",i,j,j1,j2
4904 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4906 C Third-order contributions
4913 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4914 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4915 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4916 c auxalary matices for theta gradient
4917 c auxalary matrix for i+1 and constant i+2
4918 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4919 c auxalary matrix for i+2 and constant i+1
4920 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4921 call transpose2(auxmat(1,1),auxmat1(1,1))
4922 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4923 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4924 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4925 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4926 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4927 if (shield_mode.eq.0) then
4934 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4935 & *fac_shield(i)*fac_shield(j)
4936 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4937 & *fac_shield(i)*fac_shield(j)
4938 if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4941 C Derivatives in theta
4942 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4943 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4944 & *fac_shield(i)*fac_shield(j)
4945 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4946 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4947 & *fac_shield(i)*fac_shield(j)
4950 C Derivatives in shield mode
4951 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4952 & (shield_mode.gt.0)) then
4955 do ilist=1,ishield_list(i)
4956 iresshield=shield_list(ilist,i)
4958 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4960 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4962 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4963 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4967 do ilist=1,ishield_list(j)
4968 iresshield=shield_list(ilist,j)
4970 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4972 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4974 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4975 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4982 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4983 & grad_shield(k,i)*eello_t3/fac_shield(i)
4984 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4985 & grad_shield(k,j)*eello_t3/fac_shield(j)
4986 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4987 & grad_shield(k,i)*eello_t3/fac_shield(i)
4988 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4989 & grad_shield(k,j)*eello_t3/fac_shield(j)
4993 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4994 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
4995 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
4996 cd & ' eello_turn3_num',4*eello_turn3_num
4997 C Derivatives in gamma(i)
4998 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4999 call transpose2(auxmat2(1,1),auxmat3(1,1))
5000 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5001 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5002 & *fac_shield(i)*fac_shield(j)
5003 C Derivatives in gamma(i+1)
5004 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5005 call transpose2(auxmat2(1,1),auxmat3(1,1))
5006 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5007 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5008 & +0.5d0*(pizda(1,1)+pizda(2,2))
5009 & *fac_shield(i)*fac_shield(j)
5010 C Cartesian derivatives
5012 c ghalf1=0.5d0*agg(l,1)
5013 c ghalf2=0.5d0*agg(l,2)
5014 c ghalf3=0.5d0*agg(l,3)
5015 c ghalf4=0.5d0*agg(l,4)
5016 a_temp(1,1)=aggi(l,1)!+ghalf1
5017 a_temp(1,2)=aggi(l,2)!+ghalf2
5018 a_temp(2,1)=aggi(l,3)!+ghalf3
5019 a_temp(2,2)=aggi(l,4)!+ghalf4
5020 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5021 gcorr3_turn(l,i)=gcorr3_turn(l,i)
5022 & +0.5d0*(pizda(1,1)+pizda(2,2))
5023 & *fac_shield(i)*fac_shield(j)
5025 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5026 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5027 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5028 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5029 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5030 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5031 & +0.5d0*(pizda(1,1)+pizda(2,2))
5032 & *fac_shield(i)*fac_shield(j)
5033 a_temp(1,1)=aggj(l,1)!+ghalf1
5034 a_temp(1,2)=aggj(l,2)!+ghalf2
5035 a_temp(2,1)=aggj(l,3)!+ghalf3
5036 a_temp(2,2)=aggj(l,4)!+ghalf4
5037 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5038 gcorr3_turn(l,j)=gcorr3_turn(l,j)
5039 & +0.5d0*(pizda(1,1)+pizda(2,2))
5040 & *fac_shield(i)*fac_shield(j)
5041 a_temp(1,1)=aggj1(l,1)
5042 a_temp(1,2)=aggj1(l,2)
5043 a_temp(2,1)=aggj1(l,3)
5044 a_temp(2,2)=aggj1(l,4)
5045 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5046 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5047 & +0.5d0*(pizda(1,1)+pizda(2,2))
5048 & *fac_shield(i)*fac_shield(j)
5052 C-------------------------------------------------------------------------------
5053 subroutine eturn4(i,eello_turn4)
5054 C Third- and fourth-order contributions from turns
5055 implicit real*8 (a-h,o-z)
5056 include 'DIMENSIONS'
5057 include 'COMMON.IOUNITS'
5058 include 'COMMON.GEO'
5059 include 'COMMON.VAR'
5060 include 'COMMON.LOCAL'
5061 include 'COMMON.CHAIN'
5062 include 'COMMON.DERIV'
5063 include 'COMMON.INTERACT'
5064 include 'COMMON.CONTACTS'
5065 include 'COMMON.TORSION'
5066 include 'COMMON.VECTORS'
5067 include 'COMMON.FFIELD'
5068 include 'COMMON.CONTROL'
5069 include 'COMMON.SHIELD'
5071 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5072 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5073 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5074 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5075 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
5076 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5077 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5078 double precision agg(3,4),aggi(3,4),aggi1(3,4),
5079 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5080 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5081 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5084 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5086 C Fourth-order contributions
5094 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5095 cd call checkint_turn4(i,a_temp,eello_turn4_num)
5096 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5097 c write(iout,*)"WCHODZE W PROGRAM"
5102 iti1=itype2loc(itype(i+1))
5103 iti2=itype2loc(itype(i+2))
5104 iti3=itype2loc(itype(i+3))
5105 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5106 call transpose2(EUg(1,1,i+1),e1t(1,1))
5107 call transpose2(Eug(1,1,i+2),e2t(1,1))
5108 call transpose2(Eug(1,1,i+3),e3t(1,1))
5109 C Ematrix derivative in theta
5110 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5111 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5112 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5113 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5114 c eta1 in derivative theta
5115 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5116 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5117 c auxgvec is derivative of Ub2 so i+3 theta
5118 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5119 c auxalary matrix of E i+1
5120 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5123 s1=scalar2(b1(1,i+2),auxvec(1))
5124 c derivative of theta i+2 with constant i+3
5125 gs23=scalar2(gtb1(1,i+2),auxvec(1))
5126 c derivative of theta i+2 with constant i+2
5127 gs32=scalar2(b1(1,i+2),auxgvec(1))
5128 c derivative of E matix in theta of i+1
5129 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5131 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5132 c ea31 in derivative theta
5133 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5134 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5135 c auxilary matrix auxgvec of Ub2 with constant E matirx
5136 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5137 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5138 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5142 s2=scalar2(b1(1,i+1),auxvec(1))
5143 c derivative of theta i+1 with constant i+3
5144 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5145 c derivative of theta i+2 with constant i+1
5146 gs21=scalar2(b1(1,i+1),auxgvec(1))
5147 c derivative of theta i+3 with constant i+1
5148 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5149 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5151 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5152 c two derivatives over diffetent matrices
5153 c gtae3e2 is derivative over i+3
5154 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5155 c ae3gte2 is derivative over i+2
5156 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5157 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5158 c three possible derivative over theta E matices
5160 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5162 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5164 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5165 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5167 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5168 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5169 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5170 if (shield_mode.eq.0) then
5177 eello_turn4=eello_turn4-(s1+s2+s3)
5178 & *fac_shield(i)*fac_shield(j)
5179 eello_t4=-(s1+s2+s3)
5180 & *fac_shield(i)*fac_shield(j)
5181 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5182 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5183 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5184 C Now derivative over shield:
5185 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5186 & (shield_mode.gt.0)) then
5189 do ilist=1,ishield_list(i)
5190 iresshield=shield_list(ilist,i)
5192 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5194 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5196 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5197 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5201 do ilist=1,ishield_list(j)
5202 iresshield=shield_list(ilist,j)
5204 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5206 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5208 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5209 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5216 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5217 & grad_shield(k,i)*eello_t4/fac_shield(i)
5218 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5219 & grad_shield(k,j)*eello_t4/fac_shield(j)
5220 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5221 & grad_shield(k,i)*eello_t4/fac_shield(i)
5222 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5223 & grad_shield(k,j)*eello_t4/fac_shield(j)
5232 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5233 cd & ' eello_turn4_num',8*eello_turn4_num
5235 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5236 & -(gs13+gsE13+gsEE1)*wturn4
5237 & *fac_shield(i)*fac_shield(j)
5238 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5239 & -(gs23+gs21+gsEE2)*wturn4
5240 & *fac_shield(i)*fac_shield(j)
5242 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5243 & -(gs32+gsE31+gsEE3)*wturn4
5244 & *fac_shield(i)*fac_shield(j)
5246 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5249 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5250 & 'eturn4',i,j,-(s1+s2+s3)
5251 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5252 c & ' eello_turn4_num',8*eello_turn4_num
5253 C Derivatives in gamma(i)
5254 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5255 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5256 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5257 s1=scalar2(b1(1,i+2),auxvec(1))
5258 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5259 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5260 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5261 & *fac_shield(i)*fac_shield(j)
5262 C Derivatives in gamma(i+1)
5263 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5264 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5265 s2=scalar2(b1(1,i+1),auxvec(1))
5266 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5267 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5268 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5269 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5270 & *fac_shield(i)*fac_shield(j)
5271 C Derivatives in gamma(i+2)
5272 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5273 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5274 s1=scalar2(b1(1,i+2),auxvec(1))
5275 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5276 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5277 s2=scalar2(b1(1,i+1),auxvec(1))
5278 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5279 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5280 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5281 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5282 & *fac_shield(i)*fac_shield(j)
5283 C Cartesian derivatives
5284 C Derivatives of this turn contributions in DC(i+2)
5285 if (j.lt.nres-1) then
5287 a_temp(1,1)=agg(l,1)
5288 a_temp(1,2)=agg(l,2)
5289 a_temp(2,1)=agg(l,3)
5290 a_temp(2,2)=agg(l,4)
5291 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5292 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5293 s1=scalar2(b1(1,i+2),auxvec(1))
5294 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5295 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5296 s2=scalar2(b1(1,i+1),auxvec(1))
5297 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5298 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5299 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5301 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5302 & *fac_shield(i)*fac_shield(j)
5305 C Remaining derivatives of this turn contribution
5307 a_temp(1,1)=aggi(l,1)
5308 a_temp(1,2)=aggi(l,2)
5309 a_temp(2,1)=aggi(l,3)
5310 a_temp(2,2)=aggi(l,4)
5311 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5312 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5313 s1=scalar2(b1(1,i+2),auxvec(1))
5314 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5315 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5316 s2=scalar2(b1(1,i+1),auxvec(1))
5317 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5318 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5319 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5320 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5321 & *fac_shield(i)*fac_shield(j)
5322 a_temp(1,1)=aggi1(l,1)
5323 a_temp(1,2)=aggi1(l,2)
5324 a_temp(2,1)=aggi1(l,3)
5325 a_temp(2,2)=aggi1(l,4)
5326 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5327 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5328 s1=scalar2(b1(1,i+2),auxvec(1))
5329 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5330 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5331 s2=scalar2(b1(1,i+1),auxvec(1))
5332 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5333 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5334 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5335 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5336 & *fac_shield(i)*fac_shield(j)
5337 a_temp(1,1)=aggj(l,1)
5338 a_temp(1,2)=aggj(l,2)
5339 a_temp(2,1)=aggj(l,3)
5340 a_temp(2,2)=aggj(l,4)
5341 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5342 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5343 s1=scalar2(b1(1,i+2),auxvec(1))
5344 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5345 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5346 s2=scalar2(b1(1,i+1),auxvec(1))
5347 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5348 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5349 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5350 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5351 & *fac_shield(i)*fac_shield(j)
5352 a_temp(1,1)=aggj1(l,1)
5353 a_temp(1,2)=aggj1(l,2)
5354 a_temp(2,1)=aggj1(l,3)
5355 a_temp(2,2)=aggj1(l,4)
5356 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5357 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5358 s1=scalar2(b1(1,i+2),auxvec(1))
5359 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5360 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5361 s2=scalar2(b1(1,i+1),auxvec(1))
5362 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5363 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5364 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5365 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5366 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5367 & *fac_shield(i)*fac_shield(j)
5371 C-----------------------------------------------------------------------------
5372 subroutine vecpr(u,v,w)
5373 implicit real*8(a-h,o-z)
5374 dimension u(3),v(3),w(3)
5375 w(1)=u(2)*v(3)-u(3)*v(2)
5376 w(2)=-u(1)*v(3)+u(3)*v(1)
5377 w(3)=u(1)*v(2)-u(2)*v(1)
5380 C-----------------------------------------------------------------------------
5381 subroutine unormderiv(u,ugrad,unorm,ungrad)
5382 C This subroutine computes the derivatives of a normalized vector u, given
5383 C the derivatives computed without normalization conditions, ugrad. Returns
5386 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5387 double precision vec(3)
5388 double precision scalar
5390 c write (2,*) 'ugrad',ugrad
5393 vec(i)=scalar(ugrad(1,i),u(1))
5395 c write (2,*) 'vec',vec
5398 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5401 c write (2,*) 'ungrad',ungrad
5404 C-----------------------------------------------------------------------------
5405 subroutine escp_soft_sphere(evdw2,evdw2_14)
5407 C This subroutine calculates the excluded-volume interaction energy between
5408 C peptide-group centers and side chains and its gradient in virtual-bond and
5409 C side-chain vectors.
5411 implicit real*8 (a-h,o-z)
5412 include 'DIMENSIONS'
5413 include 'COMMON.GEO'
5414 include 'COMMON.VAR'
5415 include 'COMMON.LOCAL'
5416 include 'COMMON.CHAIN'
5417 include 'COMMON.DERIV'
5418 include 'COMMON.INTERACT'
5419 include 'COMMON.FFIELD'
5420 include 'COMMON.IOUNITS'
5421 include 'COMMON.CONTROL'
5423 integer xshift,yshift,zshift
5427 cd print '(a)','Enter ESCP'
5428 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5432 do i=iatscp_s,iatscp_e
5433 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5435 xi=0.5D0*(c(1,i)+c(1,i+1))
5436 yi=0.5D0*(c(2,i)+c(2,i+1))
5437 zi=0.5D0*(c(3,i)+c(3,i+1))
5438 C Return atom into box, boxxsize is size of box in x dimension
5440 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5441 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5442 C Condition for being inside the proper box
5443 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5444 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5448 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5449 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5450 C Condition for being inside the proper box
5451 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5452 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5456 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5457 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5458 cC Condition for being inside the proper box
5459 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5460 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5464 if (xi.lt.0) xi=xi+boxxsize
5466 if (yi.lt.0) yi=yi+boxysize
5468 if (zi.lt.0) zi=zi+boxzsize
5469 C xi=xi+xshift*boxxsize
5470 C yi=yi+yshift*boxysize
5471 C zi=zi+zshift*boxzsize
5472 do iint=1,nscp_gr(i)
5474 do j=iscpstart(i,iint),iscpend(i,iint)
5475 if (itype(j).eq.ntyp1) cycle
5476 itypj=iabs(itype(j))
5477 C Uncomment following three lines for SC-p interactions
5481 C Uncomment following three lines for Ca-p interactions
5486 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5487 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5488 C Condition for being inside the proper box
5489 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5490 c & (xj.lt.((-0.5d0)*boxxsize))) then
5494 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5495 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5496 cC Condition for being inside the proper box
5497 c if ((yj.gt.((0.5d0)*boxysize)).or.
5498 c & (yj.lt.((-0.5d0)*boxysize))) then
5502 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5503 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5504 C Condition for being inside the proper box
5505 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5506 c & (zj.lt.((-0.5d0)*boxzsize))) then
5509 if (xj.lt.0) xj=xj+boxxsize
5511 if (yj.lt.0) yj=yj+boxysize
5513 if (zj.lt.0) zj=zj+boxzsize
5514 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5522 xj=xj_safe+xshift*boxxsize
5523 yj=yj_safe+yshift*boxysize
5524 zj=zj_safe+zshift*boxzsize
5525 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5526 if(dist_temp.lt.dist_init) then
5536 if (subchap.eq.1) then
5549 rij=xj*xj+yj*yj+zj*zj
5553 if (rij.lt.r0ijsq) then
5554 evdwij=0.25d0*(rij-r0ijsq)**2
5562 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5567 cgrad if (j.lt.i) then
5568 cd write (iout,*) 'j<i'
5569 C Uncomment following three lines for SC-p interactions
5571 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5574 cd write (iout,*) 'j>i'
5576 cgrad ggg(k)=-ggg(k)
5577 C Uncomment following line for SC-p interactions
5578 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5582 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5584 cgrad kstart=min0(i+1,j)
5585 cgrad kend=max0(i-1,j-1)
5586 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5587 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5588 cgrad do k=kstart,kend
5590 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5594 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5595 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5606 C-----------------------------------------------------------------------------
5607 subroutine escp(evdw2,evdw2_14)
5609 C This subroutine calculates the excluded-volume interaction energy between
5610 C peptide-group centers and side chains and its gradient in virtual-bond and
5611 C side-chain vectors.
5613 implicit real*8 (a-h,o-z)
5614 include 'DIMENSIONS'
5615 include 'COMMON.GEO'
5616 include 'COMMON.VAR'
5617 include 'COMMON.LOCAL'
5618 include 'COMMON.CHAIN'
5619 include 'COMMON.DERIV'
5620 include 'COMMON.INTERACT'
5621 include 'COMMON.FFIELD'
5622 include 'COMMON.IOUNITS'
5623 include 'COMMON.CONTROL'
5624 include 'COMMON.SPLITELE'
5625 integer xshift,yshift,zshift
5629 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5630 cd print '(a)','Enter ESCP'
5631 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5635 if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5636 do i=iatscp_s,iatscp_e
5637 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5639 xi=0.5D0*(c(1,i)+c(1,i+1))
5640 yi=0.5D0*(c(2,i)+c(2,i+1))
5641 zi=0.5D0*(c(3,i)+c(3,i+1))
5643 if (xi.lt.0) xi=xi+boxxsize
5645 if (yi.lt.0) yi=yi+boxysize
5647 if (zi.lt.0) zi=zi+boxzsize
5648 c xi=xi+xshift*boxxsize
5649 c yi=yi+yshift*boxysize
5650 c zi=zi+zshift*boxzsize
5651 c print *,xi,yi,zi,'polozenie i'
5652 C Return atom into box, boxxsize is size of box in x dimension
5654 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5655 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5656 C Condition for being inside the proper box
5657 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5658 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5662 c print *,xi,boxxsize,"pierwszy"
5664 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5665 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5666 C Condition for being inside the proper box
5667 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5668 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5672 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5673 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5674 C Condition for being inside the proper box
5675 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5676 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5679 do iint=1,nscp_gr(i)
5681 do j=iscpstart(i,iint),iscpend(i,iint)
5682 itypj=iabs(itype(j))
5683 if (itypj.eq.ntyp1) cycle
5684 C Uncomment following three lines for SC-p interactions
5688 C Uncomment following three lines for Ca-p interactions
5693 if (xj.lt.0) xj=xj+boxxsize
5695 if (yj.lt.0) yj=yj+boxysize
5697 if (zj.lt.0) zj=zj+boxzsize
5699 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5700 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5701 C Condition for being inside the proper box
5702 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5703 c & (xj.lt.((-0.5d0)*boxxsize))) then
5707 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5708 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5709 cC Condition for being inside the proper box
5710 c if ((yj.gt.((0.5d0)*boxysize)).or.
5711 c & (yj.lt.((-0.5d0)*boxysize))) then
5715 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5716 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5717 C Condition for being inside the proper box
5718 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5719 c & (zj.lt.((-0.5d0)*boxzsize))) then
5722 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5723 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5731 xj=xj_safe+xshift*boxxsize
5732 yj=yj_safe+yshift*boxysize
5733 zj=zj_safe+zshift*boxzsize
5734 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5735 if(dist_temp.lt.dist_init) then
5745 if (subchap.eq.1) then
5754 c print *,xj,yj,zj,'polozenie j'
5755 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5757 sss=sscale(1.0d0/(dsqrt(rrij)))
5758 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5759 c if (sss.eq.0) print *,'czasem jest OK'
5760 if (sss.le.0.0d0) cycle
5761 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5763 e1=fac*fac*aad(itypj,iteli)
5764 e2=fac*bad(itypj,iteli)
5765 if (iabs(j-i) .le. 2) then
5768 evdw2_14=evdw2_14+(e1+e2)*sss
5771 evdw2=evdw2+evdwij*sss
5772 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5773 & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5776 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5778 fac=-(evdwij+e1)*rrij*sss
5779 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5783 cgrad if (j.lt.i) then
5784 cd write (iout,*) 'j<i'
5785 C Uncomment following three lines for SC-p interactions
5787 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5790 cd write (iout,*) 'j>i'
5792 cgrad ggg(k)=-ggg(k)
5793 C Uncomment following line for SC-p interactions
5794 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5795 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5799 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5801 cgrad kstart=min0(i+1,j)
5802 cgrad kend=max0(i-1,j-1)
5803 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5804 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5805 cgrad do k=kstart,kend
5807 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5811 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5812 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5814 c endif !endif for sscale cutoff
5824 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5825 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5826 gradx_scp(j,i)=expon*gradx_scp(j,i)
5829 C******************************************************************************
5833 C To save time the factor EXPON has been extracted from ALL components
5834 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5837 C******************************************************************************
5840 C--------------------------------------------------------------------------
5841 subroutine edis(ehpb)
5843 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5845 implicit real*8 (a-h,o-z)
5846 include 'DIMENSIONS'
5847 include 'COMMON.SBRIDGE'
5848 include 'COMMON.CHAIN'
5849 include 'COMMON.DERIV'
5850 include 'COMMON.VAR'
5851 include 'COMMON.INTERACT'
5852 include 'COMMON.IOUNITS'
5853 include 'COMMON.CONTROL'
5854 dimension ggg(3),ggg_peak(3,1000)
5859 c 8/21/18 AL: added explicit restraints on reference coords
5860 c write (iout,*) "restr_on_coord",restr_on_coord
5861 if (restr_on_coord) then
5865 if (itype(i).eq.ntyp1) cycle
5867 ecoor=ecoor+(c(j,i)-cref(j,i))**2
5868 ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5870 if (itype(i).ne.10) then
5872 ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5873 ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5876 if (energy_dec) write (iout,*)
5877 & "i",i," bfac",bfac(i)," ecoor",ecoor
5878 ehpb=ehpb+0.5d0*bfac(i)*ecoor
5882 C write (iout,*) ,"link_end",link_end,constr_dist
5883 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5884 c write(iout,*)'link_start=',link_start,' link_end=',link_end,
5885 c & " constr_dist",constr_dist," link_start_peak",link_start_peak,
5886 c & " link_end_peak",link_end_peak
5887 if (link_end.eq.0.and.link_end_peak.eq.0) return
5888 do i=link_start_peak,link_end_peak
5890 c print *,"i",i," link_end_peak",link_end_peak," ipeak",
5891 c & ipeak(1,i),ipeak(2,i)
5892 do ip=ipeak(1,i),ipeak(2,i)
5897 C iii and jjj point to the residues for which the distance is assigned.
5898 c if (ii.gt.nres) then
5905 if (ii.gt.nres) then
5910 if (jj.gt.nres) then
5915 aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5916 aux=dexp(-scal_peak*aux)
5917 ehpb_peak=ehpb_peak+aux
5918 fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5919 & forcon_peak(ip))*aux/dd
5921 ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5923 if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5924 & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5925 & forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5927 c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5928 ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5929 do ip=ipeak(1,i),ipeak(2,i)
5932 ggg(j)=ggg_peak(j,iip)/ehpb_peak
5936 C iii and jjj point to the residues for which the distance is assigned.
5937 c if (ii.gt.nres) then
5944 if (ii.gt.nres) then
5949 if (jj.gt.nres) then
5956 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5961 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5965 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5966 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5970 do i=link_start,link_end
5971 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5972 C CA-CA distance used in regularization of structure.
5975 C iii and jjj point to the residues for which the distance is assigned.
5976 if (ii.gt.nres) then
5981 if (jj.gt.nres) then
5986 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5987 c & dhpb(i),dhpb1(i),forcon(i)
5988 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5989 C distance and angle dependent SS bond potential.
5990 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5991 C & iabs(itype(jjj)).eq.1) then
5992 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5993 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5994 if (.not.dyn_ss .and. i.le.nss) then
5995 C 15/02/13 CC dynamic SSbond - additional check
5996 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5997 & iabs(itype(jjj)).eq.1) then
5998 call ssbond_ene(iii,jjj,eij)
6001 cd write (iout,*) "eij",eij
6002 cd & ' waga=',waga,' fac=',fac
6003 ! else if (ii.gt.nres .and. jj.gt.nres) then
6005 C Calculate the distance between the two points and its difference from the
6008 if (irestr_type(i).eq.11) then
6009 ehpb=ehpb+fordepth(i)!**4.0d0
6010 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6011 fac=fordepth(i)!**4.0d0
6012 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6013 if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6014 & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6015 & ehpb,irestr_type(i)
6016 else if (irestr_type(i).eq.10) then
6017 c AL 6//19/2018 cross-link restraints
6018 xdis = 0.5d0*(dd/forcon(i))**2
6019 expdis = dexp(-xdis)
6020 c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6021 aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6022 c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6023 c & " wboltzd",wboltzd
6024 ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6025 c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6026 fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6027 & *expdis/(aux*forcon(i)**2)
6028 if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6029 & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6030 & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6031 else if (irestr_type(i).eq.2) then
6032 c Quartic restraints
6033 ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6034 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6035 & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6036 & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6037 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6039 c Quadratic restraints
6041 C Get the force constant corresponding to this distance.
6043 C Calculate the contribution to energy.
6044 ehpb=ehpb+0.5d0*waga*rdis*rdis
6045 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6046 & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6047 & 0.5d0*waga*rdis*rdis,irestr_type(i)
6049 C Evaluate gradient.
6053 c Calculate Cartesian gradient
6055 ggg(j)=fac*(c(j,jj)-c(j,ii))
6057 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6058 C If this is a SC-SC distance, we need to calculate the contributions to the
6059 C Cartesian gradient in the SC vectors (ghpbx).
6062 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6067 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6071 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6072 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6078 C--------------------------------------------------------------------------
6079 subroutine ssbond_ene(i,j,eij)
6081 C Calculate the distance and angle dependent SS-bond potential energy
6082 C using a free-energy function derived based on RHF/6-31G** ab initio
6083 C calculations of diethyl disulfide.
6085 C A. Liwo and U. Kozlowska, 11/24/03
6087 implicit real*8 (a-h,o-z)
6088 include 'DIMENSIONS'
6089 include 'COMMON.SBRIDGE'
6090 include 'COMMON.CHAIN'
6091 include 'COMMON.DERIV'
6092 include 'COMMON.LOCAL'
6093 include 'COMMON.INTERACT'
6094 include 'COMMON.VAR'
6095 include 'COMMON.IOUNITS'
6096 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6097 itypi=iabs(itype(i))
6101 dxi=dc_norm(1,nres+i)
6102 dyi=dc_norm(2,nres+i)
6103 dzi=dc_norm(3,nres+i)
6104 c dsci_inv=dsc_inv(itypi)
6105 dsci_inv=vbld_inv(nres+i)
6106 itypj=iabs(itype(j))
6107 c dscj_inv=dsc_inv(itypj)
6108 dscj_inv=vbld_inv(nres+j)
6112 dxj=dc_norm(1,nres+j)
6113 dyj=dc_norm(2,nres+j)
6114 dzj=dc_norm(3,nres+j)
6115 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6120 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6121 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6122 om12=dxi*dxj+dyi*dyj+dzi*dzj
6124 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6125 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6131 deltat12=om2-om1+2.0d0
6133 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6134 & +akct*deltad*deltat12
6135 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6136 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6137 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6138 c & " deltat12",deltat12," eij",eij
6139 ed=2*akcm*deltad+akct*deltat12
6141 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6142 eom1=-2*akth*deltat1-pom1-om2*pom2
6143 eom2= 2*akth*deltat2+pom1-om1*pom2
6146 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6147 ghpbx(k,i)=ghpbx(k,i)-ggk
6148 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6149 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6150 ghpbx(k,j)=ghpbx(k,j)+ggk
6151 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6152 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6153 ghpbc(k,i)=ghpbc(k,i)-ggk
6154 ghpbc(k,j)=ghpbc(k,j)+ggk
6157 C Calculate the components of the gradient in DC and X
6161 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
6166 C--------------------------------------------------------------------------
6167 subroutine ebond(estr)
6169 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6171 implicit real*8 (a-h,o-z)
6172 include 'DIMENSIONS'
6173 include 'COMMON.LOCAL'
6174 include 'COMMON.GEO'
6175 include 'COMMON.INTERACT'
6176 include 'COMMON.DERIV'
6177 include 'COMMON.VAR'
6178 include 'COMMON.CHAIN'
6179 include 'COMMON.IOUNITS'
6180 include 'COMMON.NAMES'
6181 include 'COMMON.FFIELD'
6182 include 'COMMON.CONTROL'
6183 include 'COMMON.SETUP'
6184 double precision u(3),ud(3)
6187 do i=ibondp_start,ibondp_end
6188 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6189 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6191 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6192 c & *dc(j,i-1)/vbld(i)
6194 c if (energy_dec) write(iout,*)
6195 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6197 C Checking if it involves dummy (NH3+ or COO-) group
6198 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6199 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
6200 diff = vbld(i)-vbldpDUM
6201 if (energy_dec) write(iout,*) "dum_bond",i,diff
6203 C NO vbldp0 is the equlibrium lenght of spring for peptide group
6204 diff = vbld(i)-vbldp0
6206 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6207 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6210 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6212 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6216 estr=0.5d0*AKP*estr+estr1
6218 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6220 do i=ibond_start,ibond_end
6222 if (iti.ne.10 .and. iti.ne.ntyp1) then
6225 diff=vbld(i+nres)-vbldsc0(1,iti)
6226 if (energy_dec) write (iout,*)
6227 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6228 & AKSC(1,iti),AKSC(1,iti)*diff*diff
6229 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6231 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6235 diff=vbld(i+nres)-vbldsc0(j,iti)
6236 ud(j)=aksc(j,iti)*diff
6237 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6251 uprod2=uprod2*u(k)*u(k)
6255 usumsqder=usumsqder+ud(j)*uprod2
6257 estr=estr+uprod/usum
6259 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6267 C--------------------------------------------------------------------------
6268 subroutine ebend(etheta)
6270 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6271 C angles gamma and its derivatives in consecutive thetas and gammas.
6273 implicit real*8 (a-h,o-z)
6274 include 'DIMENSIONS'
6275 include 'COMMON.LOCAL'
6276 include 'COMMON.GEO'
6277 include 'COMMON.INTERACT'
6278 include 'COMMON.DERIV'
6279 include 'COMMON.VAR'
6280 include 'COMMON.CHAIN'
6281 include 'COMMON.IOUNITS'
6282 include 'COMMON.NAMES'
6283 include 'COMMON.FFIELD'
6284 include 'COMMON.CONTROL'
6285 include 'COMMON.TORCNSTR'
6286 common /calcthet/ term1,term2,termm,diffak,ratak,
6287 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6288 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6289 double precision y(2),z(2)
6291 c time11=dexp(-2*time)
6294 c write (*,'(a,i2)') 'EBEND ICG=',icg
6295 do i=ithet_start,ithet_end
6296 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6297 & .or.itype(i).eq.ntyp1) cycle
6298 C Zero the energy function and its derivative at 0 or pi.
6299 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6301 ichir1=isign(1,itype(i-2))
6302 ichir2=isign(1,itype(i))
6303 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6304 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6305 if (itype(i-1).eq.10) then
6306 itype1=isign(10,itype(i-2))
6307 ichir11=isign(1,itype(i-2))
6308 ichir12=isign(1,itype(i-2))
6309 itype2=isign(10,itype(i))
6310 ichir21=isign(1,itype(i))
6311 ichir22=isign(1,itype(i))
6314 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6317 if (phii.ne.phii) phii=150.0
6327 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6330 if (phii1.ne.phii1) phii1=150.0
6342 C Calculate the "mean" value of theta from the part of the distribution
6343 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6344 C In following comments this theta will be referred to as t_c.
6345 thet_pred_mean=0.0d0
6347 athetk=athet(k,it,ichir1,ichir2)
6348 bthetk=bthet(k,it,ichir1,ichir2)
6350 athetk=athet(k,itype1,ichir11,ichir12)
6351 bthetk=bthet(k,itype2,ichir21,ichir22)
6353 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6354 c write(iout,*) 'chuj tu', y(k),z(k)
6356 dthett=thet_pred_mean*ssd
6357 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6358 C Derivatives of the "mean" values in gamma1 and gamma2.
6359 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6360 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6361 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6362 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6364 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6365 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6366 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6367 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6369 if (theta(i).gt.pi-delta) then
6370 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6372 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6373 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6374 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6376 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6378 else if (theta(i).lt.delta) then
6379 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6380 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6381 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6383 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6384 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6387 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6390 etheta=etheta+ethetai
6391 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6392 & 'ebend',i,ethetai,theta(i),itype(i)
6393 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6394 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6395 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6398 C Ufff.... We've done all this!!!
6401 C---------------------------------------------------------------------------
6402 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6404 implicit real*8 (a-h,o-z)
6405 include 'DIMENSIONS'
6406 include 'COMMON.LOCAL'
6407 include 'COMMON.IOUNITS'
6408 common /calcthet/ term1,term2,termm,diffak,ratak,
6409 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6410 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6411 C Calculate the contributions to both Gaussian lobes.
6412 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6413 C The "polynomial part" of the "standard deviation" of this part of
6414 C the distributioni.
6415 ccc write (iout,*) thetai,thet_pred_mean
6418 sig=sig*thet_pred_mean+polthet(j,it)
6420 C Derivative of the "interior part" of the "standard deviation of the"
6421 C gamma-dependent Gaussian lobe in t_c.
6422 sigtc=3*polthet(3,it)
6424 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6427 C Set the parameters of both Gaussian lobes of the distribution.
6428 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6429 fac=sig*sig+sigc0(it)
6432 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6433 sigsqtc=-4.0D0*sigcsq*sigtc
6434 c print *,i,sig,sigtc,sigsqtc
6435 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6436 sigtc=-sigtc/(fac*fac)
6437 C Following variable is sigma(t_c)**(-2)
6438 sigcsq=sigcsq*sigcsq
6440 sig0inv=1.0D0/sig0i**2
6441 delthec=thetai-thet_pred_mean
6442 delthe0=thetai-theta0i
6443 term1=-0.5D0*sigcsq*delthec*delthec
6444 term2=-0.5D0*sig0inv*delthe0*delthe0
6445 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6446 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6447 C NaNs in taking the logarithm. We extract the largest exponent which is added
6448 C to the energy (this being the log of the distribution) at the end of energy
6449 C term evaluation for this virtual-bond angle.
6450 if (term1.gt.term2) then
6452 term2=dexp(term2-termm)
6456 term1=dexp(term1-termm)
6459 C The ratio between the gamma-independent and gamma-dependent lobes of
6460 C the distribution is a Gaussian function of thet_pred_mean too.
6461 diffak=gthet(2,it)-thet_pred_mean
6462 ratak=diffak/gthet(3,it)**2
6463 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6464 C Let's differentiate it in thet_pred_mean NOW.
6466 C Now put together the distribution terms to make complete distribution.
6467 termexp=term1+ak*term2
6468 termpre=sigc+ak*sig0i
6469 C Contribution of the bending energy from this theta is just the -log of
6470 C the sum of the contributions from the two lobes and the pre-exponential
6471 C factor. Simple enough, isn't it?
6472 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6473 C write (iout,*) 'termexp',termexp,termm,termpre,i
6474 C NOW the derivatives!!!
6475 C 6/6/97 Take into account the deformation.
6476 E_theta=(delthec*sigcsq*term1
6477 & +ak*delthe0*sig0inv*term2)/termexp
6478 E_tc=((sigtc+aktc*sig0i)/termpre
6479 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6480 & aktc*term2)/termexp)
6483 c-----------------------------------------------------------------------------
6484 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6485 implicit real*8 (a-h,o-z)
6486 include 'DIMENSIONS'
6487 include 'COMMON.LOCAL'
6488 include 'COMMON.IOUNITS'
6489 common /calcthet/ term1,term2,termm,diffak,ratak,
6490 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6491 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6492 delthec=thetai-thet_pred_mean
6493 delthe0=thetai-theta0i
6494 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6495 t3 = thetai-thet_pred_mean
6499 t14 = t12+t6*sigsqtc
6501 t21 = thetai-theta0i
6507 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6508 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6509 & *(-t12*t9-ak*sig0inv*t27)
6513 C--------------------------------------------------------------------------
6514 subroutine ebend(etheta)
6516 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6517 C angles gamma and its derivatives in consecutive thetas and gammas.
6518 C ab initio-derived potentials from
6519 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6521 implicit real*8 (a-h,o-z)
6522 include 'DIMENSIONS'
6523 include 'COMMON.LOCAL'
6524 include 'COMMON.GEO'
6525 include 'COMMON.INTERACT'
6526 include 'COMMON.DERIV'
6527 include 'COMMON.VAR'
6528 include 'COMMON.CHAIN'
6529 include 'COMMON.IOUNITS'
6530 include 'COMMON.NAMES'
6531 include 'COMMON.FFIELD'
6532 include 'COMMON.CONTROL'
6533 include 'COMMON.TORCNSTR'
6534 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6535 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6536 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6537 & sinph1ph2(maxdouble,maxdouble)
6538 logical lprn /.false./, lprn1 /.false./
6540 do i=ithet_start,ithet_end
6541 c print *,i,itype(i-1),itype(i),itype(i-2)
6542 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6543 & .or.itype(i).eq.ntyp1) cycle
6544 C print *,i,theta(i)
6545 if (iabs(itype(i+1)).eq.20) iblock=2
6546 if (iabs(itype(i+1)).ne.20) iblock=1
6550 theti2=0.5d0*theta(i)
6551 ityp2=ithetyp((itype(i-1)))
6553 coskt(k)=dcos(k*theti2)
6554 sinkt(k)=dsin(k*theti2)
6557 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6560 if (phii.ne.phii) phii=150.0
6564 ityp1=ithetyp((itype(i-2)))
6565 C propagation of chirality for glycine type
6567 cosph1(k)=dcos(k*phii)
6568 sinph1(k)=dsin(k*phii)
6573 ityp1=ithetyp((itype(i-2)))
6578 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6581 if (phii1.ne.phii1) phii1=150.0
6586 ityp3=ithetyp((itype(i)))
6588 cosph2(k)=dcos(k*phii1)
6589 sinph2(k)=dsin(k*phii1)
6593 ityp3=ithetyp((itype(i)))
6599 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6602 ccl=cosph1(l)*cosph2(k-l)
6603 ssl=sinph1(l)*sinph2(k-l)
6604 scl=sinph1(l)*cosph2(k-l)
6605 csl=cosph1(l)*sinph2(k-l)
6606 cosph1ph2(l,k)=ccl-ssl
6607 cosph1ph2(k,l)=ccl+ssl
6608 sinph1ph2(l,k)=scl+csl
6609 sinph1ph2(k,l)=scl-csl
6613 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6614 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6615 write (iout,*) "coskt and sinkt"
6617 write (iout,*) k,coskt(k),sinkt(k)
6621 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6622 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6625 & write (iout,*) "k",k,"
6626 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6627 & " ethetai",ethetai
6630 write (iout,*) "cosph and sinph"
6632 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6634 write (iout,*) "cosph1ph2 and sinph2ph2"
6637 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6638 & sinph1ph2(l,k),sinph1ph2(k,l)
6641 write(iout,*) "ethetai",ethetai
6646 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6647 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6648 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6649 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6650 ethetai=ethetai+sinkt(m)*aux
6651 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6652 dephii=dephii+k*sinkt(m)*(
6653 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6654 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6655 dephii1=dephii1+k*sinkt(m)*(
6656 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6657 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6659 & write (iout,*) "m",m," k",k," bbthet",
6660 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6661 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6662 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6663 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6664 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6667 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6668 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6669 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6670 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6672 & write(iout,*) "ethetai",ethetai
6673 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6677 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6678 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6679 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6680 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6681 ethetai=ethetai+sinkt(m)*aux
6682 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6683 dephii=dephii+l*sinkt(m)*(
6684 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6685 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6686 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6687 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6688 dephii1=dephii1+(k-l)*sinkt(m)*(
6689 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6690 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6691 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6692 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6694 write (iout,*) "m",m," k",k," l",l," ffthet",
6695 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6696 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6697 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6698 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6699 & " ethetai",ethetai
6700 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6701 & cosph1ph2(k,l)*sinkt(m),
6702 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6711 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6712 & i,theta(i)*rad2deg,phii*rad2deg,
6713 & phii1*rad2deg,ethetai
6715 etheta=etheta+ethetai
6716 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6718 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6719 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6720 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6727 c-----------------------------------------------------------------------------
6728 subroutine esc(escloc)
6729 C Calculate the local energy of a side chain and its derivatives in the
6730 C corresponding virtual-bond valence angles THETA and the spherical angles
6732 implicit real*8 (a-h,o-z)
6733 include 'DIMENSIONS'
6734 include 'COMMON.GEO'
6735 include 'COMMON.LOCAL'
6736 include 'COMMON.VAR'
6737 include 'COMMON.INTERACT'
6738 include 'COMMON.DERIV'
6739 include 'COMMON.CHAIN'
6740 include 'COMMON.IOUNITS'
6741 include 'COMMON.NAMES'
6742 include 'COMMON.FFIELD'
6743 include 'COMMON.CONTROL'
6744 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6745 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6746 common /sccalc/ time11,time12,time112,theti,it,nlobit
6749 c write (iout,'(a)') 'ESC'
6750 do i=loc_start,loc_end
6752 if (it.eq.ntyp1) cycle
6753 if (it.eq.10) goto 1
6754 nlobit=nlob(iabs(it))
6755 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6756 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6757 theti=theta(i+1)-pipol
6762 if (x(2).gt.pi-delta) then
6766 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6768 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6769 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6771 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6772 & ddersc0(1),dersc(1))
6773 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6774 & ddersc0(3),dersc(3))
6776 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6778 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6779 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6780 & dersc0(2),esclocbi,dersc02)
6781 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6783 call splinthet(x(2),0.5d0*delta,ss,ssd)
6788 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6790 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6791 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6793 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6795 c write (iout,*) escloci
6796 else if (x(2).lt.delta) then
6800 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6802 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6803 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6805 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6806 & ddersc0(1),dersc(1))
6807 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6808 & ddersc0(3),dersc(3))
6810 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6812 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6813 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6814 & dersc0(2),esclocbi,dersc02)
6815 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6820 call splinthet(x(2),0.5d0*delta,ss,ssd)
6822 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6824 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6825 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6827 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6828 c write (iout,*) escloci
6830 call enesc(x,escloci,dersc,ddummy,.false.)
6833 escloc=escloc+escloci
6834 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6835 & 'escloc',i,escloci
6836 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6838 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6840 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6841 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6846 C---------------------------------------------------------------------------
6847 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6848 implicit real*8 (a-h,o-z)
6849 include 'DIMENSIONS'
6850 include 'COMMON.GEO'
6851 include 'COMMON.LOCAL'
6852 include 'COMMON.IOUNITS'
6853 common /sccalc/ time11,time12,time112,theti,it,nlobit
6854 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6855 double precision contr(maxlob,-1:1)
6857 c write (iout,*) 'it=',it,' nlobit=',nlobit
6861 if (mixed) ddersc(j)=0.0d0
6865 C Because of periodicity of the dependence of the SC energy in omega we have
6866 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6867 C To avoid underflows, first compute & store the exponents.
6875 z(k)=x(k)-censc(k,j,it)
6880 Axk=Axk+gaussc(l,k,j,it)*z(l)
6886 expfac=expfac+Ax(k,j,iii)*z(k)
6894 C As in the case of ebend, we want to avoid underflows in exponentiation and
6895 C subsequent NaNs and INFs in energy calculation.
6896 C Find the largest exponent
6900 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6904 cd print *,'it=',it,' emin=',emin
6906 C Compute the contribution to SC energy and derivatives
6911 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6912 if(adexp.ne.adexp) adexp=1.0
6915 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6917 cd print *,'j=',j,' expfac=',expfac
6918 escloc_i=escloc_i+expfac
6920 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6924 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6925 & +gaussc(k,2,j,it))*expfac
6932 dersc(1)=dersc(1)/cos(theti)**2
6933 ddersc(1)=ddersc(1)/cos(theti)**2
6936 escloci=-(dlog(escloc_i)-emin)
6938 dersc(j)=dersc(j)/escloc_i
6942 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6947 C------------------------------------------------------------------------------
6948 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6949 implicit real*8 (a-h,o-z)
6950 include 'DIMENSIONS'
6951 include 'COMMON.GEO'
6952 include 'COMMON.LOCAL'
6953 include 'COMMON.IOUNITS'
6954 common /sccalc/ time11,time12,time112,theti,it,nlobit
6955 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6956 double precision contr(maxlob)
6967 z(k)=x(k)-censc(k,j,it)
6973 Axk=Axk+gaussc(l,k,j,it)*z(l)
6979 expfac=expfac+Ax(k,j)*z(k)
6984 C As in the case of ebend, we want to avoid underflows in exponentiation and
6985 C subsequent NaNs and INFs in energy calculation.
6986 C Find the largest exponent
6989 if (emin.gt.contr(j)) emin=contr(j)
6993 C Compute the contribution to SC energy and derivatives
6997 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6998 escloc_i=escloc_i+expfac
7000 dersc(k)=dersc(k)+Ax(k,j)*expfac
7002 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7003 & +gaussc(1,2,j,it))*expfac
7007 dersc(1)=dersc(1)/cos(theti)**2
7008 dersc12=dersc12/cos(theti)**2
7009 escloci=-(dlog(escloc_i)-emin)
7011 dersc(j)=dersc(j)/escloc_i
7013 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7017 c----------------------------------------------------------------------------------
7018 subroutine esc(escloc)
7019 C Calculate the local energy of a side chain and its derivatives in the
7020 C corresponding virtual-bond valence angles THETA and the spherical angles
7021 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7022 C added by Urszula Kozlowska. 07/11/2007
7024 implicit real*8 (a-h,o-z)
7025 include 'DIMENSIONS'
7026 include 'COMMON.GEO'
7027 include 'COMMON.LOCAL'
7028 include 'COMMON.VAR'
7029 include 'COMMON.SCROT'
7030 include 'COMMON.INTERACT'
7031 include 'COMMON.DERIV'
7032 include 'COMMON.CHAIN'
7033 include 'COMMON.IOUNITS'
7034 include 'COMMON.NAMES'
7035 include 'COMMON.FFIELD'
7036 include 'COMMON.CONTROL'
7037 include 'COMMON.VECTORS'
7038 double precision x_prime(3),y_prime(3),z_prime(3)
7039 & , sumene,dsc_i,dp2_i,x(65),
7040 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7041 & de_dxx,de_dyy,de_dzz,de_dt
7042 double precision s1_t,s1_6_t,s2_t,s2_6_t
7044 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7045 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7046 & dt_dCi(3),dt_dCi1(3)
7047 common /sccalc/ time11,time12,time112,theti,it,nlobit
7050 do i=loc_start,loc_end
7051 if (itype(i).eq.ntyp1) cycle
7052 costtab(i+1) =dcos(theta(i+1))
7053 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7054 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7055 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7056 cosfac2=0.5d0/(1.0d0+costtab(i+1))
7057 cosfac=dsqrt(cosfac2)
7058 sinfac2=0.5d0/(1.0d0-costtab(i+1))
7059 sinfac=dsqrt(sinfac2)
7061 if (it.eq.10) goto 1
7063 C Compute the axes of tghe local cartesian coordinates system; store in
7064 c x_prime, y_prime and z_prime
7071 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7072 C & dc_norm(3,i+nres)
7074 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7075 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7078 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7081 c write (2,*) "x_prime",(x_prime(j),j=1,3)
7082 c write (2,*) "y_prime",(y_prime(j),j=1,3)
7083 c write (2,*) "z_prime",(z_prime(j),j=1,3)
7084 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7085 c & " xy",scalar(x_prime(1),y_prime(1)),
7086 c & " xz",scalar(x_prime(1),z_prime(1)),
7087 c & " yy",scalar(y_prime(1),y_prime(1)),
7088 c & " yz",scalar(y_prime(1),z_prime(1)),
7089 c & " zz",scalar(z_prime(1),z_prime(1))
7091 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7092 C to local coordinate system. Store in xx, yy, zz.
7098 xx = xx + x_prime(j)*dc_norm(j,i+nres)
7099 yy = yy + y_prime(j)*dc_norm(j,i+nres)
7100 zz = zz + z_prime(j)*dc_norm(j,i+nres)
7107 C Compute the energy of the ith side cbain
7109 c write (2,*) "xx",xx," yy",yy," zz",zz
7112 x(j) = sc_parmin(j,it)
7115 Cc diagnostics - remove later
7117 yy1 = dsin(alph(2))*dcos(omeg(2))
7118 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7119 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7120 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7122 C," --- ", xx_w,yy_w,zz_w
7125 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7126 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7128 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7129 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7131 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7132 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7133 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7134 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7135 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7137 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7138 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7139 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7140 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7141 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7143 dsc_i = 0.743d0+x(61)
7145 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7146 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7147 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7148 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7149 s1=(1+x(63))/(0.1d0 + dscp1)
7150 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7151 s2=(1+x(65))/(0.1d0 + dscp2)
7152 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7153 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7154 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7155 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7157 c & dscp1,dscp2,sumene
7158 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7159 escloc = escloc + sumene
7160 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7162 c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7167 C This section to check the numerical derivatives of the energy of ith side
7168 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7169 C #define DEBUG in the code to turn it on.
7171 write (2,*) "sumene =",sumene
7175 write (2,*) xx,yy,zz
7176 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7177 de_dxx_num=(sumenep-sumene)/aincr
7179 write (2,*) "xx+ sumene from enesc=",sumenep
7182 write (2,*) xx,yy,zz
7183 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7184 de_dyy_num=(sumenep-sumene)/aincr
7186 write (2,*) "yy+ sumene from enesc=",sumenep
7189 write (2,*) xx,yy,zz
7190 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7191 de_dzz_num=(sumenep-sumene)/aincr
7193 write (2,*) "zz+ sumene from enesc=",sumenep
7194 costsave=cost2tab(i+1)
7195 sintsave=sint2tab(i+1)
7196 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7197 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7198 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7199 de_dt_num=(sumenep-sumene)/aincr
7200 write (2,*) " t+ sumene from enesc=",sumenep
7201 cost2tab(i+1)=costsave
7202 sint2tab(i+1)=sintsave
7203 C End of diagnostics section.
7206 C Compute the gradient of esc
7208 c zz=zz*dsign(1.0,dfloat(itype(i)))
7209 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7210 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7211 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7212 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7213 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7214 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7215 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7216 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7217 pom1=(sumene3*sint2tab(i+1)+sumene1)
7218 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7219 pom2=(sumene4*cost2tab(i+1)+sumene2)
7220 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7221 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7222 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7223 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7225 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7226 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7227 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7229 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7230 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7231 & +(pom1+pom2)*pom_dx
7233 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7236 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7237 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7238 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7240 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7241 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7242 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7243 & +x(59)*zz**2 +x(60)*xx*zz
7244 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7245 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7246 & +(pom1-pom2)*pom_dy
7248 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7251 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7252 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7253 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7254 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7255 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7256 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7257 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7258 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7260 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7263 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7264 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7265 & +pom1*pom_dt1+pom2*pom_dt2
7267 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7272 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7273 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7274 cosfac2xx=cosfac2*xx
7275 sinfac2yy=sinfac2*yy
7277 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7279 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7281 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7282 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7283 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7284 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7285 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7286 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7287 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7288 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7289 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7290 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7294 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7295 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7296 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7297 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7300 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7301 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7302 dZZ_XYZ(k)=vbld_inv(i+nres)*
7303 & (z_prime(k)-zz*dC_norm(k,i+nres))
7305 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7306 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7310 dXX_Ctab(k,i)=dXX_Ci(k)
7311 dXX_C1tab(k,i)=dXX_Ci1(k)
7312 dYY_Ctab(k,i)=dYY_Ci(k)
7313 dYY_C1tab(k,i)=dYY_Ci1(k)
7314 dZZ_Ctab(k,i)=dZZ_Ci(k)
7315 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7316 dXX_XYZtab(k,i)=dXX_XYZ(k)
7317 dYY_XYZtab(k,i)=dYY_XYZ(k)
7318 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7322 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7323 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7324 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7325 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7326 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7328 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7329 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7330 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7331 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7332 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7333 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7334 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7335 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7337 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7338 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7340 C to check gradient call subroutine check_grad
7346 c------------------------------------------------------------------------------
7347 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7349 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7350 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7351 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7352 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7354 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7355 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7357 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7358 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7359 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7360 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7361 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7363 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7364 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7365 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7366 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7367 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7369 dsc_i = 0.743d0+x(61)
7371 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7372 & *(xx*cost2+yy*sint2))
7373 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7374 & *(xx*cost2-yy*sint2))
7375 s1=(1+x(63))/(0.1d0 + dscp1)
7376 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7377 s2=(1+x(65))/(0.1d0 + dscp2)
7378 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7379 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7380 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7385 c------------------------------------------------------------------------------
7386 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7388 C This procedure calculates two-body contact function g(rij) and its derivative:
7391 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7394 C where x=(rij-r0ij)/delta
7396 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7399 double precision rij,r0ij,eps0ij,fcont,fprimcont
7400 double precision x,x2,x4,delta
7404 if (x.lt.-1.0D0) then
7407 else if (x.le.1.0D0) then
7410 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7411 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7418 c------------------------------------------------------------------------------
7419 subroutine splinthet(theti,delta,ss,ssder)
7420 implicit real*8 (a-h,o-z)
7421 include 'DIMENSIONS'
7422 include 'COMMON.VAR'
7423 include 'COMMON.GEO'
7426 if (theti.gt.pipol) then
7427 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7429 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7434 c------------------------------------------------------------------------------
7435 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7437 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7438 double precision ksi,ksi2,ksi3,a1,a2,a3
7439 a1=fprim0*delta/(f1-f0)
7445 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7446 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7449 c------------------------------------------------------------------------------
7450 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7452 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7453 double precision ksi,ksi2,ksi3,a1,a2,a3
7458 a2=3*(f1x-f0x)-2*fprim0x*delta
7459 a3=fprim0x*delta-2*(f1x-f0x)
7460 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7463 C-----------------------------------------------------------------------------
7465 C-----------------------------------------------------------------------------
7466 subroutine etor(etors)
7467 implicit real*8 (a-h,o-z)
7468 include 'DIMENSIONS'
7469 include 'COMMON.VAR'
7470 include 'COMMON.GEO'
7471 include 'COMMON.LOCAL'
7472 include 'COMMON.TORSION'
7473 include 'COMMON.INTERACT'
7474 include 'COMMON.DERIV'
7475 include 'COMMON.CHAIN'
7476 include 'COMMON.NAMES'
7477 include 'COMMON.IOUNITS'
7478 include 'COMMON.FFIELD'
7479 include 'COMMON.TORCNSTR'
7480 include 'COMMON.CONTROL'
7482 C Set lprn=.true. for debugging
7486 do i=iphi_start,iphi_end
7488 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7489 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7490 itori=itortyp(itype(i-2))
7491 itori1=itortyp(itype(i-1))
7494 C Proline-Proline pair is a special case...
7495 if (itori.eq.3 .and. itori1.eq.3) then
7496 if (phii.gt.-dwapi3) then
7498 fac=1.0D0/(1.0D0-cosphi)
7499 etorsi=v1(1,3,3)*fac
7500 etorsi=etorsi+etorsi
7501 etors=etors+etorsi-v1(1,3,3)
7502 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7503 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7506 v1ij=v1(j+1,itori,itori1)
7507 v2ij=v2(j+1,itori,itori1)
7510 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7511 if (energy_dec) etors_ii=etors_ii+
7512 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7513 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7517 v1ij=v1(j,itori,itori1)
7518 v2ij=v2(j,itori,itori1)
7521 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7522 if (energy_dec) etors_ii=etors_ii+
7523 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7524 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7527 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7530 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7531 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7532 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7533 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7534 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7538 c------------------------------------------------------------------------------
7539 subroutine etor_d(etors_d)
7543 c----------------------------------------------------------------------------
7544 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7545 subroutine e_modeller(ehomology_constr)
7546 ehomology_constr=0.0d0
7547 write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7550 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7552 c------------------------------------------------------------------------------
7553 subroutine etor_d(etors_d)
7557 c----------------------------------------------------------------------------
7559 subroutine etor(etors)
7560 implicit real*8 (a-h,o-z)
7561 include 'DIMENSIONS'
7562 include 'COMMON.VAR'
7563 include 'COMMON.GEO'
7564 include 'COMMON.LOCAL'
7565 include 'COMMON.TORSION'
7566 include 'COMMON.INTERACT'
7567 include 'COMMON.DERIV'
7568 include 'COMMON.CHAIN'
7569 include 'COMMON.NAMES'
7570 include 'COMMON.IOUNITS'
7571 include 'COMMON.FFIELD'
7572 include 'COMMON.TORCNSTR'
7573 include 'COMMON.CONTROL'
7575 C Set lprn=.true. for debugging
7579 do i=iphi_start,iphi_end
7580 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7581 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7582 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7583 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7584 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7585 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7586 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7587 C For introducing the NH3+ and COO- group please check the etor_d for reference
7590 if (iabs(itype(i)).eq.20) then
7595 itori=itortyp(itype(i-2))
7596 itori1=itortyp(itype(i-1))
7599 C Regular cosine and sine terms
7600 do j=1,nterm(itori,itori1,iblock)
7601 v1ij=v1(j,itori,itori1,iblock)
7602 v2ij=v2(j,itori,itori1,iblock)
7605 etors=etors+v1ij*cosphi+v2ij*sinphi
7606 if (energy_dec) etors_ii=etors_ii+
7607 & v1ij*cosphi+v2ij*sinphi
7608 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7612 C E = SUM ----------------------------------- - v1
7613 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7615 cosphi=dcos(0.5d0*phii)
7616 sinphi=dsin(0.5d0*phii)
7617 do j=1,nlor(itori,itori1,iblock)
7618 vl1ij=vlor1(j,itori,itori1)
7619 vl2ij=vlor2(j,itori,itori1)
7620 vl3ij=vlor3(j,itori,itori1)
7621 pom=vl2ij*cosphi+vl3ij*sinphi
7622 pom1=1.0d0/(pom*pom+1.0d0)
7623 etors=etors+vl1ij*pom1
7624 if (energy_dec) etors_ii=etors_ii+
7627 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7629 C Subtract the constant term
7630 etors=etors-v0(itori,itori1,iblock)
7631 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7632 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7634 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7635 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7636 & (v1(j,itori,itori1,iblock),j=1,6),
7637 & (v2(j,itori,itori1,iblock),j=1,6)
7638 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7639 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7643 c----------------------------------------------------------------------------
7644 subroutine etor_d(etors_d)
7645 C 6/23/01 Compute double torsional energy
7646 implicit real*8 (a-h,o-z)
7647 include 'DIMENSIONS'
7648 include 'COMMON.VAR'
7649 include 'COMMON.GEO'
7650 include 'COMMON.LOCAL'
7651 include 'COMMON.TORSION'
7652 include 'COMMON.INTERACT'
7653 include 'COMMON.DERIV'
7654 include 'COMMON.CHAIN'
7655 include 'COMMON.NAMES'
7656 include 'COMMON.IOUNITS'
7657 include 'COMMON.FFIELD'
7658 include 'COMMON.TORCNSTR'
7659 include 'COMMON.CONTROL'
7661 C Set lprn=.true. for debugging
7665 c write(iout,*) "a tu??"
7666 do i=iphid_start,iphid_end
7667 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7668 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7669 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7670 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7671 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7672 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7673 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7674 & (itype(i+1).eq.ntyp1)) cycle
7675 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7677 itori=itortyp(itype(i-2))
7678 itori1=itortyp(itype(i-1))
7679 itori2=itortyp(itype(i))
7685 if (iabs(itype(i+1)).eq.20) iblock=2
7686 C Iblock=2 Proline type
7687 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7688 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7689 C if (itype(i+1).eq.ntyp1) iblock=3
7690 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7691 C IS or IS NOT need for this
7692 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7693 C is (itype(i-3).eq.ntyp1) ntblock=2
7694 C ntblock is N-terminal blocking group
7696 C Regular cosine and sine terms
7697 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7698 C Example of changes for NH3+ blocking group
7699 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7700 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7701 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7702 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7703 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7704 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7705 cosphi1=dcos(j*phii)
7706 sinphi1=dsin(j*phii)
7707 cosphi2=dcos(j*phii1)
7708 sinphi2=dsin(j*phii1)
7709 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7710 & v2cij*cosphi2+v2sij*sinphi2
7711 if (energy_dec) etors_d_ii=etors_d_ii+
7712 & v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7713 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7714 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7716 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7718 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7719 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7720 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7721 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7722 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7723 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7724 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7725 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7726 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7727 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7728 if (energy_dec) etors_d_ii=etors_d_ii+
7729 & v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7730 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7731 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7732 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7733 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7734 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7737 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7738 & 'etor_d',i,etors_d_ii
7739 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7740 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7745 C----------------------------------------------------------------------------------
7746 C The rigorous attempt to derive energy function
7747 subroutine etor_kcc(etors)
7748 implicit real*8 (a-h,o-z)
7749 include 'DIMENSIONS'
7750 include 'COMMON.VAR'
7751 include 'COMMON.GEO'
7752 include 'COMMON.LOCAL'
7753 include 'COMMON.TORSION'
7754 include 'COMMON.INTERACT'
7755 include 'COMMON.DERIV'
7756 include 'COMMON.CHAIN'
7757 include 'COMMON.NAMES'
7758 include 'COMMON.IOUNITS'
7759 include 'COMMON.FFIELD'
7760 include 'COMMON.TORCNSTR'
7761 include 'COMMON.CONTROL'
7762 double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7764 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7765 C Set lprn=.true. for debugging
7768 C print *,"wchodze kcc"
7769 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7771 do i=iphi_start,iphi_end
7772 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7773 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7774 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7775 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7776 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7777 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7778 itori=itortyp(itype(i-2))
7779 itori1=itortyp(itype(i-1))
7784 C to avoid multiple devision by 2
7785 c theti22=0.5d0*theta(i)
7786 C theta 12 is the theta_1 /2
7787 C theta 22 is theta_2 /2
7788 c theti12=0.5d0*theta(i-1)
7789 C and appropriate sinus function
7790 sinthet1=dsin(theta(i-1))
7791 sinthet2=dsin(theta(i))
7792 costhet1=dcos(theta(i-1))
7793 costhet2=dcos(theta(i))
7794 C to speed up lets store its mutliplication
7795 sint1t2=sinthet2*sinthet1
7797 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7798 C +d_n*sin(n*gamma)) *
7799 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7800 C we have two sum 1) Non-Chebyshev which is with n and gamma
7801 nval=nterm_kcc_Tb(itori,itori1)
7807 c1(j)=c1(j-1)*costhet1
7808 c2(j)=c2(j-1)*costhet2
7811 do j=1,nterm_kcc(itori,itori1)
7815 sint1t2n=sint1t2n*sint1t2
7821 sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7822 gradvalct1=gradvalct1+
7823 & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7824 gradvalct2=gradvalct2+
7825 & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7828 gradvalct1=-gradvalct1*sinthet1
7829 gradvalct2=-gradvalct2*sinthet2
7835 sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7836 gradvalst1=gradvalst1+
7837 & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7838 gradvalst2=gradvalst2+
7839 & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7842 gradvalst1=-gradvalst1*sinthet1
7843 gradvalst2=-gradvalst2*sinthet2
7844 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7845 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7846 C glocig is the gradient local i site in gamma
7847 glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7848 C now gradient over theta_1
7849 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7850 & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7851 glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7852 & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7855 C derivative over gamma
7856 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7857 C derivative over theta1
7858 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7859 C now derivative over theta2
7860 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7862 write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7863 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7864 write (iout,*) "c1",(c1(k),k=0,nval),
7865 & " c2",(c2(k),k=0,nval)
7870 c---------------------------------------------------------------------------------------------
7871 subroutine etor_constr(edihcnstr)
7872 implicit real*8 (a-h,o-z)
7873 include 'DIMENSIONS'
7874 include 'COMMON.VAR'
7875 include 'COMMON.GEO'
7876 include 'COMMON.LOCAL'
7877 include 'COMMON.TORSION'
7878 include 'COMMON.INTERACT'
7879 include 'COMMON.DERIV'
7880 include 'COMMON.CHAIN'
7881 include 'COMMON.NAMES'
7882 include 'COMMON.IOUNITS'
7883 include 'COMMON.FFIELD'
7884 include 'COMMON.TORCNSTR'
7885 include 'COMMON.BOUNDS'
7886 include 'COMMON.CONTROL'
7887 ! 6/20/98 - dihedral angle constraints
7889 c do i=1,ndih_constr
7890 if (raw_psipred) then
7891 do i=idihconstr_start,idihconstr_end
7892 itori=idih_constr(i)
7894 gaudih_i=vpsipred(1,i)
7898 cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7899 dexpcos_i=dexp(-cos_i*cos_i)
7900 gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7901 gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7902 & *cos_i*dexpcos_i/s**2
7904 edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7905 gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7907 & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7908 & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7909 & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7910 & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7911 & -wdihc*dlog(gaudih_i)
7915 do i=idihconstr_start,idihconstr_end
7916 itori=idih_constr(i)
7918 difi=pinorm(phii-phi0(i))
7919 if (difi.gt.drange(i)) then
7921 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7922 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7923 else if (difi.lt.-drange(i)) then
7925 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7926 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7936 c----------------------------------------------------------------------------
7937 c MODELLER restraint function
7938 subroutine e_modeller(ehomology_constr)
7939 implicit real*8 (a-h,o-z)
7940 include 'DIMENSIONS'
7942 integer nnn, i, j, k, ki, irec, l
7943 integer katy, odleglosci, test7
7944 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7946 real*8 distance(max_template),distancek(max_template),
7947 & min_odl,godl(max_template),dih_diff(max_template)
7950 c FP - 30/10/2014 Temporary specifications for homology restraints
7952 double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7954 double precision, dimension (maxres) :: guscdiff,usc_diff
7955 double precision, dimension (max_template) ::
7956 & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7960 include 'COMMON.SBRIDGE'
7961 include 'COMMON.CHAIN'
7962 include 'COMMON.GEO'
7963 include 'COMMON.DERIV'
7964 include 'COMMON.LOCAL'
7965 include 'COMMON.INTERACT'
7966 include 'COMMON.VAR'
7967 include 'COMMON.IOUNITS'
7969 include 'COMMON.CONTROL'
7971 c From subroutine Econstr_back
7973 include 'COMMON.NAMES'
7974 include 'COMMON.TIME1'
7979 distancek(i)=9999999.9
7985 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7987 C AL 5/2/14 - Introduce list of restraints
7988 c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7990 write(iout,*) "------- dist restrs start -------"
7992 do ii = link_start_homo,link_end_homo
7996 c write (iout,*) "dij(",i,j,") =",dij
7998 do k=1,constr_homology
7999 c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
8000 if(.not.l_homo(k,ii)) then
8004 distance(k)=odl(k,ii)-dij
8005 c write (iout,*) "distance(",k,") =",distance(k)
8007 c For Gaussian-type Urestr
8009 distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
8010 c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
8011 c write (iout,*) "distancek(",k,") =",distancek(k)
8012 c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8014 c For Lorentzian-type Urestr
8016 if (waga_dist.lt.0.0d0) then
8017 sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8018 distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8019 & (distance(k)**2+sigma_odlir(k,ii)**2))
8023 c min_odl=minval(distancek)
8024 do kk=1,constr_homology
8025 if(l_homo(kk,ii)) then
8026 min_odl=distancek(kk)
8030 do kk=1,constr_homology
8031 if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8032 & min_odl=distancek(kk)
8035 c write (iout,* )"min_odl",min_odl
8037 write (iout,*) "ij dij",i,j,dij
8038 write (iout,*) "distance",(distance(k),k=1,constr_homology)
8039 write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8040 write (iout,* )"min_odl",min_odl
8045 if (waga_dist.ge.0.0d0) then
8051 do k=1,constr_homology
8052 c Nie wiem po co to liczycie jeszcze raz!
8053 c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8054 c & (2*(sigma_odl(i,j,k))**2))
8055 if(.not.l_homo(k,ii)) cycle
8056 if (waga_dist.ge.0.0d0) then
8058 c For Gaussian-type Urestr
8060 godl(k)=dexp(-distancek(k)+min_odl)
8061 odleg2=odleg2+godl(k)
8063 c For Lorentzian-type Urestr
8066 odleg2=odleg2+distancek(k)
8069 ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8070 ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8071 ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8072 ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8075 c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8076 c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8078 write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8079 write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8081 if (waga_dist.ge.0.0d0) then
8083 c For Gaussian-type Urestr
8085 odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8087 c For Lorentzian-type Urestr
8090 odleg=odleg+odleg2/constr_homology
8093 c write (iout,*) "odleg",odleg ! sum of -ln-s
8096 c For Gaussian-type Urestr
8098 if (waga_dist.ge.0.0d0) sum_godl=odleg2
8100 do k=1,constr_homology
8101 c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8102 c & *waga_dist)+min_odl
8103 c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8105 if(.not.l_homo(k,ii)) cycle
8106 if (waga_dist.ge.0.0d0) then
8107 c For Gaussian-type Urestr
8109 sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8111 c For Lorentzian-type Urestr
8114 sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8115 & sigma_odlir(k,ii)**2)**2)
8117 sum_sgodl=sum_sgodl+sgodl
8119 c sgodl2=sgodl2+sgodl
8120 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8121 c write(iout,*) "constr_homology=",constr_homology
8122 c write(iout,*) i, j, k, "TEST K"
8124 if (waga_dist.ge.0.0d0) then
8126 c For Gaussian-type Urestr
8128 grad_odl3=waga_homology(iset)*waga_dist
8129 & *sum_sgodl/(sum_godl*dij)
8131 c For Lorentzian-type Urestr
8134 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8135 c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8136 grad_odl3=-waga_homology(iset)*waga_dist*
8137 & sum_sgodl/(constr_homology*dij)
8140 c grad_odl3=sum_sgodl/(sum_godl*dij)
8143 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8144 c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8145 c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8147 ccc write(iout,*) godl, sgodl, grad_odl3
8149 c grad_odl=grad_odl+grad_odl3
8152 ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8153 ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8154 ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8155 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8156 ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8157 ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8158 ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8159 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8160 c if (i.eq.25.and.j.eq.27) then
8161 c write(iout,*) "jik",jik,"i",i,"j",j
8162 c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8163 c write(iout,*) "grad_odl3",grad_odl3
8164 c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8165 c write(iout,*) "ggodl",ggodl
8166 c write(iout,*) "ghpbc(",jik,i,")",
8167 c & ghpbc(jik,i),"ghpbc(",jik,j,")",
8171 ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8172 ccc & dLOG(odleg2),"-odleg=", -odleg
8174 enddo ! ii-loop for dist
8176 write(iout,*) "------- dist restrs end -------"
8177 c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8178 c & waga_d.eq.1.0d0) call sum_gradient
8180 c Pseudo-energy and gradient from dihedral-angle restraints from
8181 c homology templates
8182 c write (iout,*) "End of distance loop"
8185 c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8187 write(iout,*) "------- dih restrs start -------"
8188 do i=idihconstr_start_homo,idihconstr_end_homo
8189 write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8192 do i=idihconstr_start_homo,idihconstr_end_homo
8194 c betai=beta(i,i+1,i+2,i+3)
8196 c write (iout,*) "betai =",betai
8197 do k=1,constr_homology
8198 dih_diff(k)=pinorm(dih(k,i)-betai)
8199 cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8200 cd & ,sigma_dih(k,i)
8201 c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8202 c & -(6.28318-dih_diff(i,k))
8203 c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8204 c & 6.28318+dih_diff(i,k)
8206 kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8208 kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8210 c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8213 c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8216 c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8217 c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8219 write (iout,*) "i",i," betai",betai," kat2",kat2
8220 write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8222 if (kat2.le.1.0d-14) cycle
8223 kat=kat-dLOG(kat2/constr_homology)
8224 c write (iout,*) "kat",kat ! sum of -ln-s
8226 ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8227 ccc & dLOG(kat2), "-kat=", -kat
8229 c ----------------------------------------------------------------------
8231 c ----------------------------------------------------------------------
8235 do k=1,constr_homology
8237 sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
8239 sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd
8241 c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8242 sum_sgdih=sum_sgdih+sgdih
8244 c grad_dih3=sum_sgdih/sum_gdih
8245 grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8247 c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8248 ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8249 ccc & gloc(nphi+i-3,icg)
8250 gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8252 c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8254 ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8255 ccc & gloc(nphi+i-3,icg)
8257 enddo ! i-loop for dih
8259 write(iout,*) "------- dih restrs end -------"
8262 c Pseudo-energy and gradient for theta angle restraints from
8263 c homology templates
8264 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8268 c For constr_homology reference structures (FP)
8270 c Uconst_back_tot=0.0d0
8273 c Econstr_back legacy
8275 c do i=ithet_start,ithet_end
8278 c do i=loc_start,loc_end
8281 duscdiffx(j,i)=0.0d0
8286 c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8287 c write (iout,*) "waga_theta",waga_theta
8288 if (waga_theta.gt.0.0d0) then
8290 write (iout,*) "usampl",usampl
8291 write(iout,*) "------- theta restrs start -------"
8292 c do i=ithet_start,ithet_end
8293 c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8296 c write (iout,*) "maxres",maxres,"nres",nres
8298 do i=ithet_start,ithet_end
8301 c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8303 c Deviation of theta angles wrt constr_homology ref structures
8305 utheta_i=0.0d0 ! argument of Gaussian for single k
8306 gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8307 c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8308 c over residues in a fragment
8309 c write (iout,*) "theta(",i,")=",theta(i)
8310 do k=1,constr_homology
8312 c dtheta_i=theta(j)-thetaref(j,iref)
8313 c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8314 theta_diff(k)=thetatpl(k,i)-theta(i)
8315 cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8316 cd & ,sigma_theta(k,i)
8319 utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8320 c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8321 gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8322 gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk)
8323 c Gradient for single Gaussian restraint in subr Econstr_back
8324 c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8327 c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8328 c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8331 c Gradient for multiple Gaussian restraint
8332 sum_gtheta=gutheta_i
8334 do k=1,constr_homology
8335 c New generalized expr for multiple Gaussian from Econstr_back
8336 sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8338 c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8339 sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8341 c Final value of gradient using same var as in Econstr_back
8342 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8343 & +sum_sgtheta/sum_gtheta*waga_theta
8344 & *waga_homology(iset)
8345 c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8346 c & *waga_homology(iset)
8347 c dutheta(i)=sum_sgtheta/sum_gtheta
8349 c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8350 Eval=Eval-dLOG(gutheta_i/constr_homology)
8351 c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8352 c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8353 c Uconst_back=Uconst_back+utheta(i)
8354 enddo ! (i-loop for theta)
8356 write(iout,*) "------- theta restrs end -------"
8360 c Deviation of local SC geometry
8362 c Separation of two i-loops (instructed by AL - 11/3/2014)
8364 c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8365 c write (iout,*) "waga_d",waga_d
8368 write(iout,*) "------- SC restrs start -------"
8369 write (iout,*) "Initial duscdiff,duscdiffx"
8370 do i=loc_start,loc_end
8371 write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8372 & (duscdiffx(jik,i),jik=1,3)
8375 do i=loc_start,loc_end
8376 usc_diff_i=0.0d0 ! argument of Gaussian for single k
8377 guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8378 c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8379 c write(iout,*) "xxtab, yytab, zztab"
8380 c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8381 do k=1,constr_homology
8383 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8384 c Original sign inverted for calc of gradients (s. Econstr_back)
8385 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8386 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8387 c write(iout,*) "dxx, dyy, dzz"
8388 cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8390 usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
8391 c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8392 c uscdiffk(k)=usc_diff(i)
8393 guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8394 c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8395 c & " guscdiff2",guscdiff2(k)
8396 guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk)
8397 c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8398 c & xxref(j),yyref(j),zzref(j)
8403 c Generalized expression for multiple Gaussian acc to that for a single
8404 c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8406 c Original implementation
8407 c sum_guscdiff=guscdiff(i)
8409 c sum_sguscdiff=0.0d0
8410 c do k=1,constr_homology
8411 c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8412 c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8413 c sum_sguscdiff=sum_sguscdiff+sguscdiff
8416 c Implementation of new expressions for gradient (Jan. 2015)
8418 c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8419 do k=1,constr_homology
8421 c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8422 c before. Now the drivatives should be correct
8424 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8425 c Original sign inverted for calc of gradients (s. Econstr_back)
8426 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8427 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8429 c New implementation
8431 sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8432 & sigma_d(k,i) ! for the grad wrt r'
8433 c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8436 c New implementation
8437 sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8439 duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8440 & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8441 & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8442 duscdiff(jik,i)=duscdiff(jik,i)+
8443 & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8444 & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8445 duscdiffx(jik,i)=duscdiffx(jik,i)+
8446 & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8447 & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8450 write(iout,*) "jik",jik,"i",i
8451 write(iout,*) "dxx, dyy, dzz"
8452 write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8453 write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8454 c write(iout,*) "sum_sguscdiff",sum_sguscdiff
8455 cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8456 c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8457 c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8458 c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8459 c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8460 c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8461 c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8462 c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8463 c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8464 c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8465 c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8466 c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8472 c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
8473 c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8475 c write (iout,*) i," uscdiff",uscdiff(i)
8477 c Put together deviations from local geometry
8479 c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8480 c & wfrag_back(3,i,iset)*uscdiff(i)
8481 Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8482 c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8483 c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8484 c Uconst_back=Uconst_back+usc_diff(i)
8486 c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8488 c New implment: multiplied by sum_sguscdiff
8491 enddo ! (i-loop for dscdiff)
8496 write(iout,*) "------- SC restrs end -------"
8497 write (iout,*) "------ After SC loop in e_modeller ------"
8498 do i=loc_start,loc_end
8499 write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8500 write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8502 if (waga_theta.eq.1.0d0) then
8503 write (iout,*) "in e_modeller after SC restr end: dutheta"
8504 do i=ithet_start,ithet_end
8505 write (iout,*) i,dutheta(i)
8508 if (waga_d.eq.1.0d0) then
8509 write (iout,*) "e_modeller after SC loop: duscdiff/x"
8511 write (iout,*) i,(duscdiff(j,i),j=1,3)
8512 write (iout,*) i,(duscdiffx(j,i),j=1,3)
8517 c Total energy from homology restraints
8519 write (iout,*) "odleg",odleg," kat",kat
8522 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8524 c ehomology_constr=odleg+kat
8526 c For Lorentzian-type Urestr
8529 if (waga_dist.ge.0.0d0) then
8531 c For Gaussian-type Urestr
8533 ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8534 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8535 c write (iout,*) "ehomology_constr=",ehomology_constr
8538 c For Lorentzian-type Urestr
8540 ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8541 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8542 c write (iout,*) "ehomology_constr=",ehomology_constr
8545 write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8546 & "Eval",waga_theta,eval,
8547 & "Erot",waga_d,Erot
8548 write (iout,*) "ehomology_constr",ehomology_constr
8554 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8555 747 format(a12,i4,i4,i4,f8.3,f8.3)
8556 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8557 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8558 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8559 & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8561 c----------------------------------------------------------------------------
8562 C The rigorous attempt to derive energy function
8563 subroutine ebend_kcc(etheta)
8565 implicit real*8 (a-h,o-z)
8566 include 'DIMENSIONS'
8567 include 'COMMON.VAR'
8568 include 'COMMON.GEO'
8569 include 'COMMON.LOCAL'
8570 include 'COMMON.TORSION'
8571 include 'COMMON.INTERACT'
8572 include 'COMMON.DERIV'
8573 include 'COMMON.CHAIN'
8574 include 'COMMON.NAMES'
8575 include 'COMMON.IOUNITS'
8576 include 'COMMON.FFIELD'
8577 include 'COMMON.TORCNSTR'
8578 include 'COMMON.CONTROL'
8580 double precision thybt1(maxang_kcc)
8581 C Set lprn=.true. for debugging
8584 C print *,"wchodze kcc"
8585 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8587 do i=ithet_start,ithet_end
8588 c print *,i,itype(i-1),itype(i),itype(i-2)
8589 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8590 & .or.itype(i).eq.ntyp1) cycle
8591 iti=iabs(itortyp(itype(i-1)))
8592 sinthet=dsin(theta(i))
8593 costhet=dcos(theta(i))
8594 do j=1,nbend_kcc_Tb(iti)
8595 thybt1(j)=v1bend_chyb(j,iti)
8597 sumth1thyb=v1bend_chyb(0,iti)+
8598 & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8599 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8601 ihelp=nbend_kcc_Tb(iti)-1
8602 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8603 etheta=etheta+sumth1thyb
8604 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8605 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8609 c-------------------------------------------------------------------------------------
8610 subroutine etheta_constr(ethetacnstr)
8612 implicit real*8 (a-h,o-z)
8613 include 'DIMENSIONS'
8614 include 'COMMON.VAR'
8615 include 'COMMON.GEO'
8616 include 'COMMON.LOCAL'
8617 include 'COMMON.TORSION'
8618 include 'COMMON.INTERACT'
8619 include 'COMMON.DERIV'
8620 include 'COMMON.CHAIN'
8621 include 'COMMON.NAMES'
8622 include 'COMMON.IOUNITS'
8623 include 'COMMON.FFIELD'
8624 include 'COMMON.TORCNSTR'
8625 include 'COMMON.CONTROL'
8627 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8628 do i=ithetaconstr_start,ithetaconstr_end
8629 itheta=itheta_constr(i)
8630 thetiii=theta(itheta)
8631 difi=pinorm(thetiii-theta_constr0(i))
8632 if (difi.gt.theta_drange(i)) then
8633 difi=difi-theta_drange(i)
8634 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8635 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8636 & +for_thet_constr(i)*difi**3
8637 else if (difi.lt.-drange(i)) then
8639 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8640 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8641 & +for_thet_constr(i)*difi**3
8645 if (energy_dec) then
8646 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8647 & i,itheta,rad2deg*thetiii,
8648 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8649 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8650 & gloc(itheta+nphi-2,icg)
8655 c------------------------------------------------------------------------------
8656 subroutine eback_sc_corr(esccor)
8657 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8658 c conformational states; temporarily implemented as differences
8659 c between UNRES torsional potentials (dependent on three types of
8660 c residues) and the torsional potentials dependent on all 20 types
8661 c of residues computed from AM1 energy surfaces of terminally-blocked
8662 c amino-acid residues.
8663 implicit real*8 (a-h,o-z)
8664 include 'DIMENSIONS'
8665 include 'COMMON.VAR'
8666 include 'COMMON.GEO'
8667 include 'COMMON.LOCAL'
8668 include 'COMMON.TORSION'
8669 include 'COMMON.SCCOR'
8670 include 'COMMON.INTERACT'
8671 include 'COMMON.DERIV'
8672 include 'COMMON.CHAIN'
8673 include 'COMMON.NAMES'
8674 include 'COMMON.IOUNITS'
8675 include 'COMMON.FFIELD'
8676 include 'COMMON.CONTROL'
8678 C Set lprn=.true. for debugging
8681 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8683 do i=itau_start,itau_end
8684 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8685 isccori=isccortyp(itype(i-2))
8686 isccori1=isccortyp(itype(i-1))
8687 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8689 do intertyp=1,3 !intertyp
8691 cc Added 09 May 2012 (Adasko)
8692 cc Intertyp means interaction type of backbone mainchain correlation:
8693 c 1 = SC...Ca...Ca...Ca
8694 c 2 = Ca...Ca...Ca...SC
8695 c 3 = SC...Ca...Ca...SCi
8697 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8698 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8699 & (itype(i-1).eq.ntyp1)))
8700 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8701 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8702 & .or.(itype(i).eq.ntyp1)))
8703 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8704 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8705 & (itype(i-3).eq.ntyp1)))) cycle
8706 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8707 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8709 do j=1,nterm_sccor(isccori,isccori1)
8710 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8711 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8712 cosphi=dcos(j*tauangle(intertyp,i))
8713 sinphi=dsin(j*tauangle(intertyp,i))
8714 if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
8715 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8716 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8718 if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
8719 & 'esccor',i,intertyp,esccor_ii
8720 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8721 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8723 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8724 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8725 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8726 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8727 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8733 c----------------------------------------------------------------------------
8734 subroutine multibody(ecorr)
8735 C This subroutine calculates multi-body contributions to energy following
8736 C the idea of Skolnick et al. If side chains I and J make a contact and
8737 C at the same time side chains I+1 and J+1 make a contact, an extra
8738 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8739 implicit real*8 (a-h,o-z)
8740 include 'DIMENSIONS'
8741 include 'COMMON.IOUNITS'
8742 include 'COMMON.DERIV'
8743 include 'COMMON.INTERACT'
8744 include 'COMMON.CONTACTS'
8745 double precision gx(3),gx1(3)
8748 C Set lprn=.true. for debugging
8752 write (iout,'(a)') 'Contact function values:'
8754 write (iout,'(i2,20(1x,i2,f10.5))')
8755 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8770 num_conti=num_cont(i)
8771 num_conti1=num_cont(i1)
8776 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8777 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8778 cd & ' ishift=',ishift
8779 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8780 C The system gains extra energy.
8781 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8782 endif ! j1==j+-ishift
8791 c------------------------------------------------------------------------------
8792 double precision function esccorr(i,j,k,l,jj,kk)
8793 implicit real*8 (a-h,o-z)
8794 include 'DIMENSIONS'
8795 include 'COMMON.IOUNITS'
8796 include 'COMMON.DERIV'
8797 include 'COMMON.INTERACT'
8798 include 'COMMON.CONTACTS'
8799 include 'COMMON.SHIELD'
8800 double precision gx(3),gx1(3)
8805 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8806 C Calculate the multi-body contribution to energy.
8807 C Calculate multi-body contributions to the gradient.
8808 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8809 cd & k,l,(gacont(m,kk,k),m=1,3)
8811 gx(m) =ekl*gacont(m,jj,i)
8812 gx1(m)=eij*gacont(m,kk,k)
8813 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8814 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8815 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8816 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8820 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8825 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8831 c------------------------------------------------------------------------------
8832 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8833 C This subroutine calculates multi-body contributions to hydrogen-bonding
8834 implicit real*8 (a-h,o-z)
8835 include 'DIMENSIONS'
8836 include 'COMMON.IOUNITS'
8839 parameter (max_cont=maxconts)
8840 parameter (max_dim=26)
8841 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8842 double precision zapas(max_dim,maxconts,max_fg_procs),
8843 & zapas_recv(max_dim,maxconts,max_fg_procs)
8844 common /przechowalnia/ zapas
8845 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8846 & status_array(MPI_STATUS_SIZE,maxconts*2)
8848 include 'COMMON.SETUP'
8849 include 'COMMON.FFIELD'
8850 include 'COMMON.DERIV'
8851 include 'COMMON.INTERACT'
8852 include 'COMMON.CONTACTS'
8853 include 'COMMON.CONTROL'
8854 include 'COMMON.LOCAL'
8855 double precision gx(3),gx1(3),time00
8858 C Set lprn=.true. for debugging
8863 if (nfgtasks.le.1) goto 30
8865 write (iout,'(a)') 'Contact function values before RECEIVE:'
8867 write (iout,'(2i3,50(1x,i2,f5.2))')
8868 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8869 & j=1,num_cont_hb(i))
8873 do i=1,ntask_cont_from
8876 do i=1,ntask_cont_to
8879 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8881 C Make the list of contacts to send to send to other procesors
8882 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8884 do i=iturn3_start,iturn3_end
8885 c write (iout,*) "make contact list turn3",i," num_cont",
8887 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8889 do i=iturn4_start,iturn4_end
8890 c write (iout,*) "make contact list turn4",i," num_cont",
8892 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8896 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8898 do j=1,num_cont_hb(i)
8901 iproc=iint_sent_local(k,jjc,ii)
8902 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8903 if (iproc.gt.0) then
8904 ncont_sent(iproc)=ncont_sent(iproc)+1
8905 nn=ncont_sent(iproc)
8907 zapas(2,nn,iproc)=jjc
8908 zapas(3,nn,iproc)=facont_hb(j,i)
8909 zapas(4,nn,iproc)=ees0p(j,i)
8910 zapas(5,nn,iproc)=ees0m(j,i)
8911 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8912 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8913 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8914 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8915 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8916 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8917 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8918 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8919 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8920 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8921 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8922 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8923 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8924 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8925 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8926 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8927 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8928 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8929 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8930 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8931 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8938 & "Numbers of contacts to be sent to other processors",
8939 & (ncont_sent(i),i=1,ntask_cont_to)
8940 write (iout,*) "Contacts sent"
8941 do ii=1,ntask_cont_to
8943 iproc=itask_cont_to(ii)
8944 write (iout,*) nn," contacts to processor",iproc,
8945 & " of CONT_TO_COMM group"
8947 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8955 CorrelID1=nfgtasks+fg_rank+1
8957 C Receive the numbers of needed contacts from other processors
8958 do ii=1,ntask_cont_from
8959 iproc=itask_cont_from(ii)
8961 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8962 & FG_COMM,req(ireq),IERR)
8964 c write (iout,*) "IRECV ended"
8966 C Send the number of contacts needed by other processors
8967 do ii=1,ntask_cont_to
8968 iproc=itask_cont_to(ii)
8970 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8971 & FG_COMM,req(ireq),IERR)
8973 c write (iout,*) "ISEND ended"
8974 c write (iout,*) "number of requests (nn)",ireq
8977 & call MPI_Waitall(ireq,req,status_array,ierr)
8979 c & "Numbers of contacts to be received from other processors",
8980 c & (ncont_recv(i),i=1,ntask_cont_from)
8984 do ii=1,ntask_cont_from
8985 iproc=itask_cont_from(ii)
8987 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8988 c & " of CONT_TO_COMM group"
8992 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8993 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8994 c write (iout,*) "ireq,req",ireq,req(ireq)
8997 C Send the contacts to processors that need them
8998 do ii=1,ntask_cont_to
8999 iproc=itask_cont_to(ii)
9001 c write (iout,*) nn," contacts to processor",iproc,
9002 c & " of CONT_TO_COMM group"
9005 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9006 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9007 c write (iout,*) "ireq,req",ireq,req(ireq)
9009 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9013 c write (iout,*) "number of requests (contacts)",ireq
9014 c write (iout,*) "req",(req(i),i=1,4)
9017 & call MPI_Waitall(ireq,req,status_array,ierr)
9018 do iii=1,ntask_cont_from
9019 iproc=itask_cont_from(iii)
9022 write (iout,*) "Received",nn," contacts from processor",iproc,
9023 & " of CONT_FROM_COMM group"
9026 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9031 ii=zapas_recv(1,i,iii)
9032 c Flag the received contacts to prevent double-counting
9033 jj=-zapas_recv(2,i,iii)
9034 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9036 nnn=num_cont_hb(ii)+1
9039 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9040 ees0p(nnn,ii)=zapas_recv(4,i,iii)
9041 ees0m(nnn,ii)=zapas_recv(5,i,iii)
9042 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9043 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9044 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9045 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9046 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9047 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9048 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9049 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9050 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9051 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9052 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9053 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9054 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9055 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9056 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9057 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9058 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9059 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9060 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9061 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9062 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9066 write (iout,'(a)') 'Contact function values after receive:'
9068 write (iout,'(2i3,50(1x,i3,f5.2))')
9069 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9070 & j=1,num_cont_hb(i))
9077 write (iout,'(a)') 'Contact function values:'
9079 write (iout,'(2i3,50(1x,i3,f5.2))')
9080 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9081 & j=1,num_cont_hb(i))
9086 C Remove the loop below after debugging !!!
9093 C Calculate the local-electrostatic correlation terms
9094 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9096 num_conti=num_cont_hb(i)
9097 num_conti1=num_cont_hb(i+1)
9104 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9105 c & ' jj=',jj,' kk=',kk
9107 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9108 & .or. j.lt.0 .and. j1.gt.0) .and.
9109 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9110 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9111 C The system gains extra energy.
9112 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9113 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9114 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9116 else if (j1.eq.j) then
9117 C Contacts I-J and I-(J+1) occur simultaneously.
9118 C The system loses extra energy.
9119 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9124 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9125 c & ' jj=',jj,' kk=',kk
9127 C Contacts I-J and (I+1)-J occur simultaneously.
9128 C The system loses extra energy.
9129 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9136 c------------------------------------------------------------------------------
9137 subroutine add_hb_contact(ii,jj,itask)
9138 implicit real*8 (a-h,o-z)
9139 include "DIMENSIONS"
9140 include "COMMON.IOUNITS"
9143 parameter (max_cont=maxconts)
9144 parameter (max_dim=26)
9145 include "COMMON.CONTACTS"
9146 double precision zapas(max_dim,maxconts,max_fg_procs),
9147 & zapas_recv(max_dim,maxconts,max_fg_procs)
9148 common /przechowalnia/ zapas
9149 integer i,j,ii,jj,iproc,itask(4),nn
9150 c write (iout,*) "itask",itask
9153 if (iproc.gt.0) then
9154 do j=1,num_cont_hb(ii)
9156 c write (iout,*) "i",ii," j",jj," jjc",jjc
9158 ncont_sent(iproc)=ncont_sent(iproc)+1
9159 nn=ncont_sent(iproc)
9160 zapas(1,nn,iproc)=ii
9161 zapas(2,nn,iproc)=jjc
9162 zapas(3,nn,iproc)=facont_hb(j,ii)
9163 zapas(4,nn,iproc)=ees0p(j,ii)
9164 zapas(5,nn,iproc)=ees0m(j,ii)
9165 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9166 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9167 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9168 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9169 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9170 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9171 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9172 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9173 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9174 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9175 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9176 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9177 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9178 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9179 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9180 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9181 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9182 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9183 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9184 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9185 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9193 c------------------------------------------------------------------------------
9194 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9196 C This subroutine calculates multi-body contributions to hydrogen-bonding
9197 implicit real*8 (a-h,o-z)
9198 include 'DIMENSIONS'
9199 include 'COMMON.IOUNITS'
9202 parameter (max_cont=maxconts)
9203 parameter (max_dim=70)
9204 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9205 double precision zapas(max_dim,maxconts,max_fg_procs),
9206 & zapas_recv(max_dim,maxconts,max_fg_procs)
9207 common /przechowalnia/ zapas
9208 integer status(MPI_STATUS_SIZE),req(maxconts*2),
9209 & status_array(MPI_STATUS_SIZE,maxconts*2)
9211 include 'COMMON.SETUP'
9212 include 'COMMON.FFIELD'
9213 include 'COMMON.DERIV'
9214 include 'COMMON.LOCAL'
9215 include 'COMMON.INTERACT'
9216 include 'COMMON.CONTACTS'
9217 include 'COMMON.CHAIN'
9218 include 'COMMON.CONTROL'
9219 include 'COMMON.SHIELD'
9220 double precision gx(3),gx1(3)
9221 integer num_cont_hb_old(maxres)
9223 double precision eello4,eello5,eelo6,eello_turn6
9224 external eello4,eello5,eello6,eello_turn6
9225 C Set lprn=.true. for debugging
9230 num_cont_hb_old(i)=num_cont_hb(i)
9234 if (nfgtasks.le.1) goto 30
9236 write (iout,'(a)') 'Contact function values before RECEIVE:'
9238 write (iout,'(2i3,50(1x,i2,f5.2))')
9239 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9240 & j=1,num_cont_hb(i))
9243 do i=1,ntask_cont_from
9246 do i=1,ntask_cont_to
9249 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9251 C Make the list of contacts to send to send to other procesors
9252 do i=iturn3_start,iturn3_end
9253 c write (iout,*) "make contact list turn3",i," num_cont",
9255 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9257 do i=iturn4_start,iturn4_end
9258 c write (iout,*) "make contact list turn4",i," num_cont",
9260 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9264 c write (iout,*) "make contact list longrange",i,ii," num_cont",
9266 do j=1,num_cont_hb(i)
9269 iproc=iint_sent_local(k,jjc,ii)
9270 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9271 if (iproc.ne.0) then
9272 ncont_sent(iproc)=ncont_sent(iproc)+1
9273 nn=ncont_sent(iproc)
9275 zapas(2,nn,iproc)=jjc
9276 zapas(3,nn,iproc)=d_cont(j,i)
9280 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9285 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9293 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9304 & "Numbers of contacts to be sent to other processors",
9305 & (ncont_sent(i),i=1,ntask_cont_to)
9306 write (iout,*) "Contacts sent"
9307 do ii=1,ntask_cont_to
9309 iproc=itask_cont_to(ii)
9310 write (iout,*) nn," contacts to processor",iproc,
9311 & " of CONT_TO_COMM group"
9313 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9321 CorrelID1=nfgtasks+fg_rank+1
9323 C Receive the numbers of needed contacts from other processors
9324 do ii=1,ntask_cont_from
9325 iproc=itask_cont_from(ii)
9327 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9328 & FG_COMM,req(ireq),IERR)
9330 c write (iout,*) "IRECV ended"
9332 C Send the number of contacts needed by other processors
9333 do ii=1,ntask_cont_to
9334 iproc=itask_cont_to(ii)
9336 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9337 & FG_COMM,req(ireq),IERR)
9339 c write (iout,*) "ISEND ended"
9340 c write (iout,*) "number of requests (nn)",ireq
9343 & call MPI_Waitall(ireq,req,status_array,ierr)
9345 c & "Numbers of contacts to be received from other processors",
9346 c & (ncont_recv(i),i=1,ntask_cont_from)
9350 do ii=1,ntask_cont_from
9351 iproc=itask_cont_from(ii)
9353 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9354 c & " of CONT_TO_COMM group"
9358 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9359 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9360 c write (iout,*) "ireq,req",ireq,req(ireq)
9363 C Send the contacts to processors that need them
9364 do ii=1,ntask_cont_to
9365 iproc=itask_cont_to(ii)
9367 c write (iout,*) nn," contacts to processor",iproc,
9368 c & " of CONT_TO_COMM group"
9371 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9372 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9373 c write (iout,*) "ireq,req",ireq,req(ireq)
9375 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9379 c write (iout,*) "number of requests (contacts)",ireq
9380 c write (iout,*) "req",(req(i),i=1,4)
9383 & call MPI_Waitall(ireq,req,status_array,ierr)
9384 do iii=1,ntask_cont_from
9385 iproc=itask_cont_from(iii)
9388 write (iout,*) "Received",nn," contacts from processor",iproc,
9389 & " of CONT_FROM_COMM group"
9392 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9397 ii=zapas_recv(1,i,iii)
9398 c Flag the received contacts to prevent double-counting
9399 jj=-zapas_recv(2,i,iii)
9400 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9402 nnn=num_cont_hb(ii)+1
9405 d_cont(nnn,ii)=zapas_recv(3,i,iii)
9409 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9414 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9422 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9430 write (iout,'(a)') 'Contact function values after receive:'
9432 write (iout,'(2i3,50(1x,i3,5f6.3))')
9433 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9434 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9441 write (iout,'(a)') 'Contact function values:'
9443 write (iout,'(2i3,50(1x,i2,5f6.3))')
9444 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9445 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9451 C Remove the loop below after debugging !!!
9458 C Calculate the dipole-dipole interaction energies
9459 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9460 do i=iatel_s,iatel_e+1
9461 num_conti=num_cont_hb(i)
9470 C Calculate the local-electrostatic correlation terms
9471 c write (iout,*) "gradcorr5 in eello5 before loop"
9473 c write (iout,'(i5,3f10.5)')
9474 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9476 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9477 c write (iout,*) "corr loop i",i
9479 num_conti=num_cont_hb(i)
9480 num_conti1=num_cont_hb(i+1)
9487 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9488 c & ' jj=',jj,' kk=',kk
9489 c if (j1.eq.j+1 .or. j1.eq.j-1) then
9490 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9491 & .or. j.lt.0 .and. j1.gt.0) .and.
9492 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9493 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9494 C The system gains extra energy.
9496 sqd1=dsqrt(d_cont(jj,i))
9497 sqd2=dsqrt(d_cont(kk,i1))
9498 sred_geom = sqd1*sqd2
9499 IF (sred_geom.lt.cutoff_corr) THEN
9500 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9502 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9503 cd & ' jj=',jj,' kk=',kk
9504 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9505 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9507 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9508 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9511 cd write (iout,*) 'sred_geom=',sred_geom,
9512 cd & ' ekont=',ekont,' fprim=',fprimcont,
9513 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9514 cd write (iout,*) "g_contij",g_contij
9515 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9516 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9517 call calc_eello(i,jp,i+1,jp1,jj,kk)
9518 if (wcorr4.gt.0.0d0)
9519 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9520 CC & *fac_shield(i)**2*fac_shield(j)**2
9521 if (energy_dec.and.wcorr4.gt.0.0d0)
9522 1 write (iout,'(a6,4i5,0pf7.3)')
9523 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9524 c write (iout,*) "gradcorr5 before eello5"
9526 c write (iout,'(i5,3f10.5)')
9527 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9529 if (wcorr5.gt.0.0d0)
9530 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9531 c write (iout,*) "gradcorr5 after eello5"
9533 c write (iout,'(i5,3f10.5)')
9534 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9536 if (energy_dec.and.wcorr5.gt.0.0d0)
9537 1 write (iout,'(a6,4i5,0pf7.3)')
9538 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9539 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9540 cd write(2,*)'ijkl',i,jp,i+1,jp1
9541 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9542 & .or. wturn6.eq.0.0d0))then
9543 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9544 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9545 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9546 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9547 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9548 cd & 'ecorr6=',ecorr6
9549 cd write (iout,'(4e15.5)') sred_geom,
9550 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9551 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9552 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9553 else if (wturn6.gt.0.0d0
9554 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9555 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9556 eturn6=eturn6+eello_turn6(i,jj,kk)
9557 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9558 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9559 cd write (2,*) 'multibody_eello:eturn6',eturn6
9568 num_cont_hb(i)=num_cont_hb_old(i)
9570 c write (iout,*) "gradcorr5 in eello5"
9572 c write (iout,'(i5,3f10.5)')
9573 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9577 c------------------------------------------------------------------------------
9578 subroutine add_hb_contact_eello(ii,jj,itask)
9579 implicit real*8 (a-h,o-z)
9580 include "DIMENSIONS"
9581 include "COMMON.IOUNITS"
9584 parameter (max_cont=maxconts)
9585 parameter (max_dim=70)
9586 include "COMMON.CONTACTS"
9587 double precision zapas(max_dim,maxconts,max_fg_procs),
9588 & zapas_recv(max_dim,maxconts,max_fg_procs)
9589 common /przechowalnia/ zapas
9590 integer i,j,ii,jj,iproc,itask(4),nn
9591 c write (iout,*) "itask",itask
9594 if (iproc.gt.0) then
9595 do j=1,num_cont_hb(ii)
9597 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9599 ncont_sent(iproc)=ncont_sent(iproc)+1
9600 nn=ncont_sent(iproc)
9601 zapas(1,nn,iproc)=ii
9602 zapas(2,nn,iproc)=jjc
9603 zapas(3,nn,iproc)=d_cont(j,ii)
9607 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9612 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9620 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9632 c------------------------------------------------------------------------------
9633 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9634 implicit real*8 (a-h,o-z)
9635 include 'DIMENSIONS'
9636 include 'COMMON.IOUNITS'
9637 include 'COMMON.DERIV'
9638 include 'COMMON.INTERACT'
9639 include 'COMMON.CONTACTS'
9640 include 'COMMON.SHIELD'
9641 include 'COMMON.CONTROL'
9642 double precision gx(3),gx1(3)
9645 C print *,"wchodze",fac_shield(i),shield_mode
9653 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9655 C & fac_shield(i)**2*fac_shield(j)**2
9656 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9657 C Following 4 lines for diagnostics.
9662 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9663 c & 'Contacts ',i,j,
9664 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9665 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9667 C Calculate the multi-body contribution to energy.
9668 C ecorr=ecorr+ekont*ees
9669 C Calculate multi-body contributions to the gradient.
9670 coeffpees0pij=coeffp*ees0pij
9671 coeffmees0mij=coeffm*ees0mij
9672 coeffpees0pkl=coeffp*ees0pkl
9673 coeffmees0mkl=coeffm*ees0mkl
9675 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9676 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9677 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9678 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9679 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9680 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9681 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9682 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9683 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9684 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9685 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9686 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9687 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9688 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9689 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9690 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9691 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9692 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9693 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9694 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9695 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9696 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9697 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9698 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9699 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9704 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9705 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9706 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9707 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9712 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9713 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9714 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9715 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9718 c write (iout,*) "ehbcorr",ekont*ees
9719 C print *,ekont,ees,i,k
9721 C now gradient over shielding
9723 if (shield_mode.gt.0) then
9726 C print *,i,j,fac_shield(i),fac_shield(j),
9727 C &fac_shield(k),fac_shield(l)
9728 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9729 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9730 do ilist=1,ishield_list(i)
9731 iresshield=shield_list(ilist,i)
9733 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9735 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9737 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9738 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9742 do ilist=1,ishield_list(j)
9743 iresshield=shield_list(ilist,j)
9745 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9747 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9749 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9750 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9755 do ilist=1,ishield_list(k)
9756 iresshield=shield_list(ilist,k)
9758 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9760 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9762 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9763 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9767 do ilist=1,ishield_list(l)
9768 iresshield=shield_list(ilist,l)
9770 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9772 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9774 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9775 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9779 C print *,gshieldx(m,iresshield)
9781 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9782 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9783 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9784 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9785 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9786 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9787 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9788 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9790 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9791 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9792 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9793 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9794 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9795 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9796 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9797 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9805 C---------------------------------------------------------------------------
9806 subroutine dipole(i,j,jj)
9807 implicit real*8 (a-h,o-z)
9808 include 'DIMENSIONS'
9809 include 'COMMON.IOUNITS'
9810 include 'COMMON.CHAIN'
9811 include 'COMMON.FFIELD'
9812 include 'COMMON.DERIV'
9813 include 'COMMON.INTERACT'
9814 include 'COMMON.CONTACTS'
9815 include 'COMMON.TORSION'
9816 include 'COMMON.VAR'
9817 include 'COMMON.GEO'
9818 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9820 iti1 = itortyp(itype(i+1))
9821 if (j.lt.nres-1) then
9822 itj1 = itype2loc(itype(j+1))
9827 dipi(iii,1)=Ub2(iii,i)
9828 dipderi(iii)=Ub2der(iii,i)
9829 dipi(iii,2)=b1(iii,i+1)
9830 dipj(iii,1)=Ub2(iii,j)
9831 dipderj(iii)=Ub2der(iii,j)
9832 dipj(iii,2)=b1(iii,j+1)
9836 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9839 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9846 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9850 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9855 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9856 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9858 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9860 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9862 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9867 C---------------------------------------------------------------------------
9868 subroutine calc_eello(i,j,k,l,jj,kk)
9870 C This subroutine computes matrices and vectors needed to calculate
9871 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9873 implicit real*8 (a-h,o-z)
9874 include 'DIMENSIONS'
9875 include 'COMMON.IOUNITS'
9876 include 'COMMON.CHAIN'
9877 include 'COMMON.DERIV'
9878 include 'COMMON.INTERACT'
9879 include 'COMMON.CONTACTS'
9880 include 'COMMON.TORSION'
9881 include 'COMMON.VAR'
9882 include 'COMMON.GEO'
9883 include 'COMMON.FFIELD'
9884 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9885 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9888 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9889 cd & ' jj=',jj,' kk=',kk
9890 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9891 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9892 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9895 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9896 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9899 call transpose2(aa1(1,1),aa1t(1,1))
9900 call transpose2(aa2(1,1),aa2t(1,1))
9903 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9904 & aa1tder(1,1,lll,kkk))
9905 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9906 & aa2tder(1,1,lll,kkk))
9910 C parallel orientation of the two CA-CA-CA frames.
9912 iti=itype2loc(itype(i))
9916 itk1=itype2loc(itype(k+1))
9917 itj=itype2loc(itype(j))
9918 if (l.lt.nres-1) then
9919 itl1=itype2loc(itype(l+1))
9923 C A1 kernel(j+1) A2T
9925 cd write (iout,'(3f10.5,5x,3f10.5)')
9926 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9928 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9929 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9930 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9931 C Following matrices are needed only for 6-th order cumulants
9932 IF (wcorr6.gt.0.0d0) THEN
9933 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9934 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9935 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9936 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9937 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9938 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9939 & ADtEAderx(1,1,1,1,1,1))
9941 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9942 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9943 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9944 & ADtEA1derx(1,1,1,1,1,1))
9946 C End 6-th order cumulants
9949 cd write (2,*) 'In calc_eello6'
9951 cd write (2,*) 'iii=',iii
9953 cd write (2,*) 'kkk=',kkk
9955 cd write (2,'(3(2f10.5),5x)')
9956 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9961 call transpose2(EUgder(1,1,k),auxmat(1,1))
9962 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9963 call transpose2(EUg(1,1,k),auxmat(1,1))
9964 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9965 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9966 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9967 c in theta; to be sriten later.
9969 c call transpose2(gtEE(1,1,k),auxmat(1,1))
9970 c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9971 c call transpose2(EUg(1,1,k),auxmat(1,1))
9972 c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9977 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9978 & EAEAderx(1,1,lll,kkk,iii,1))
9982 C A1T kernel(i+1) A2
9983 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9984 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9985 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9986 C Following matrices are needed only for 6-th order cumulants
9987 IF (wcorr6.gt.0.0d0) THEN
9988 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9989 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9990 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9991 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9992 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9993 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9994 & ADtEAderx(1,1,1,1,1,2))
9995 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9996 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9997 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9998 & ADtEA1derx(1,1,1,1,1,2))
10000 C End 6-th order cumulants
10001 call transpose2(EUgder(1,1,l),auxmat(1,1))
10002 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
10003 call transpose2(EUg(1,1,l),auxmat(1,1))
10004 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10005 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10009 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10010 & EAEAderx(1,1,lll,kkk,iii,2))
10015 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10016 C They are needed only when the fifth- or the sixth-order cumulants are
10018 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10019 call transpose2(AEA(1,1,1),auxmat(1,1))
10020 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10021 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10022 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10023 call transpose2(AEAderg(1,1,1),auxmat(1,1))
10024 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10025 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10026 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10027 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10028 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10029 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10030 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10031 call transpose2(AEA(1,1,2),auxmat(1,1))
10032 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10033 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10034 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10035 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10036 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10037 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10038 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10039 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10040 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10041 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10042 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10043 C Calculate the Cartesian derivatives of the vectors.
10047 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10048 call matvec2(auxmat(1,1),b1(1,i),
10049 & AEAb1derx(1,lll,kkk,iii,1,1))
10050 call matvec2(auxmat(1,1),Ub2(1,i),
10051 & AEAb2derx(1,lll,kkk,iii,1,1))
10052 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10053 & AEAb1derx(1,lll,kkk,iii,2,1))
10054 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10055 & AEAb2derx(1,lll,kkk,iii,2,1))
10056 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10057 call matvec2(auxmat(1,1),b1(1,j),
10058 & AEAb1derx(1,lll,kkk,iii,1,2))
10059 call matvec2(auxmat(1,1),Ub2(1,j),
10060 & AEAb2derx(1,lll,kkk,iii,1,2))
10061 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10062 & AEAb1derx(1,lll,kkk,iii,2,2))
10063 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10064 & AEAb2derx(1,lll,kkk,iii,2,2))
10071 C Antiparallel orientation of the two CA-CA-CA frames.
10073 iti=itype2loc(itype(i))
10077 itk1=itype2loc(itype(k+1))
10078 itl=itype2loc(itype(l))
10079 itj=itype2loc(itype(j))
10080 if (j.lt.nres-1) then
10081 itj1=itype2loc(itype(j+1))
10085 C A2 kernel(j-1)T A1T
10086 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10087 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10088 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10089 C Following matrices are needed only for 6-th order cumulants
10090 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10091 & j.eq.i+4 .and. l.eq.i+3)) THEN
10092 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10093 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10094 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10095 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10096 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10097 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10098 & ADtEAderx(1,1,1,1,1,1))
10099 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10100 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10101 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10102 & ADtEA1derx(1,1,1,1,1,1))
10104 C End 6-th order cumulants
10105 call transpose2(EUgder(1,1,k),auxmat(1,1))
10106 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10107 call transpose2(EUg(1,1,k),auxmat(1,1))
10108 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10109 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10113 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10114 & EAEAderx(1,1,lll,kkk,iii,1))
10118 C A2T kernel(i+1)T A1
10119 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10120 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10121 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10122 C Following matrices are needed only for 6-th order cumulants
10123 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10124 & j.eq.i+4 .and. l.eq.i+3)) THEN
10125 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10126 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10127 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10128 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10129 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10130 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10131 & ADtEAderx(1,1,1,1,1,2))
10132 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10133 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10134 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10135 & ADtEA1derx(1,1,1,1,1,2))
10137 C End 6-th order cumulants
10138 call transpose2(EUgder(1,1,j),auxmat(1,1))
10139 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10140 call transpose2(EUg(1,1,j),auxmat(1,1))
10141 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10142 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10146 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10147 & EAEAderx(1,1,lll,kkk,iii,2))
10152 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10153 C They are needed only when the fifth- or the sixth-order cumulants are
10155 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10156 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10157 call transpose2(AEA(1,1,1),auxmat(1,1))
10158 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10159 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10160 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10161 call transpose2(AEAderg(1,1,1),auxmat(1,1))
10162 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10163 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10164 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10165 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10166 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10167 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10168 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10169 call transpose2(AEA(1,1,2),auxmat(1,1))
10170 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10171 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10172 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10173 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10174 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10175 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10176 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10177 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10178 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10179 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10180 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10181 C Calculate the Cartesian derivatives of the vectors.
10185 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10186 call matvec2(auxmat(1,1),b1(1,i),
10187 & AEAb1derx(1,lll,kkk,iii,1,1))
10188 call matvec2(auxmat(1,1),Ub2(1,i),
10189 & AEAb2derx(1,lll,kkk,iii,1,1))
10190 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10191 & AEAb1derx(1,lll,kkk,iii,2,1))
10192 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10193 & AEAb2derx(1,lll,kkk,iii,2,1))
10194 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10195 call matvec2(auxmat(1,1),b1(1,l),
10196 & AEAb1derx(1,lll,kkk,iii,1,2))
10197 call matvec2(auxmat(1,1),Ub2(1,l),
10198 & AEAb2derx(1,lll,kkk,iii,1,2))
10199 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10200 & AEAb1derx(1,lll,kkk,iii,2,2))
10201 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10202 & AEAb2derx(1,lll,kkk,iii,2,2))
10211 C---------------------------------------------------------------------------
10212 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10213 & KK,KKderg,AKA,AKAderg,AKAderx)
10217 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10218 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10219 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10220 integer iii,kkk,lll
10223 common /kutas/ lprn
10224 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10226 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10227 & AKAderg(1,1,iii))
10229 cd if (lprn) write (2,*) 'In kernel'
10231 cd if (lprn) write (2,*) 'kkk=',kkk
10233 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10234 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10236 cd write (2,*) 'lll=',lll
10237 cd write (2,*) 'iii=1'
10239 cd write (2,'(3(2f10.5),5x)')
10240 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10243 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10244 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10246 cd write (2,*) 'lll=',lll
10247 cd write (2,*) 'iii=2'
10249 cd write (2,'(3(2f10.5),5x)')
10250 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10257 C---------------------------------------------------------------------------
10258 double precision function eello4(i,j,k,l,jj,kk)
10259 implicit real*8 (a-h,o-z)
10260 include 'DIMENSIONS'
10261 include 'COMMON.IOUNITS'
10262 include 'COMMON.CHAIN'
10263 include 'COMMON.DERIV'
10264 include 'COMMON.INTERACT'
10265 include 'COMMON.CONTACTS'
10266 include 'COMMON.TORSION'
10267 include 'COMMON.VAR'
10268 include 'COMMON.GEO'
10269 double precision pizda(2,2),ggg1(3),ggg2(3)
10270 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10274 cd print *,'eello4:',i,j,k,l,jj,kk
10275 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
10276 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
10277 cold eij=facont_hb(jj,i)
10278 cold ekl=facont_hb(kk,k)
10280 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10281 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10282 gcorr_loc(k-1)=gcorr_loc(k-1)
10283 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10285 gcorr_loc(l-1)=gcorr_loc(l-1)
10286 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10287 C Al 4/16/16: Derivatives in theta, to be added later.
10289 c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10290 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10293 gcorr_loc(j-1)=gcorr_loc(j-1)
10294 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10296 c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10297 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10303 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10304 & -EAEAderx(2,2,lll,kkk,iii,1)
10305 cd derx(lll,kkk,iii)=0.0d0
10309 cd gcorr_loc(l-1)=0.0d0
10310 cd gcorr_loc(j-1)=0.0d0
10311 cd gcorr_loc(k-1)=0.0d0
10313 cd write (iout,*)'Contacts have occurred for peptide groups',
10314 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
10315 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10316 if (j.lt.nres-1) then
10323 if (l.lt.nres-1) then
10331 cgrad ggg1(ll)=eel4*g_contij(ll,1)
10332 cgrad ggg2(ll)=eel4*g_contij(ll,2)
10333 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10334 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10335 cgrad ghalf=0.5d0*ggg1(ll)
10336 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10337 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10338 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10339 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10340 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10341 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10342 cgrad ghalf=0.5d0*ggg2(ll)
10343 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10344 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10345 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10346 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10347 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10348 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10352 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10357 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10362 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10367 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10371 cd write (2,*) iii,gcorr_loc(iii)
10374 cd write (2,*) 'ekont',ekont
10375 cd write (iout,*) 'eello4',ekont*eel4
10378 C---------------------------------------------------------------------------
10379 double precision function eello5(i,j,k,l,jj,kk)
10380 implicit real*8 (a-h,o-z)
10381 include 'DIMENSIONS'
10382 include 'COMMON.IOUNITS'
10383 include 'COMMON.CHAIN'
10384 include 'COMMON.DERIV'
10385 include 'COMMON.INTERACT'
10386 include 'COMMON.CONTACTS'
10387 include 'COMMON.TORSION'
10388 include 'COMMON.VAR'
10389 include 'COMMON.GEO'
10390 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10391 double precision ggg1(3),ggg2(3)
10392 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10394 C Parallel chains C
10397 C /l\ / \ \ / \ / \ / C
10398 C / \ / \ \ / \ / \ / C
10399 C j| o |l1 | o | o| o | | o |o C
10400 C \ |/k\| |/ \| / |/ \| |/ \| C
10401 C \i/ \ / \ / / \ / \ C
10403 C (I) (II) (III) (IV) C
10405 C eello5_1 eello5_2 eello5_3 eello5_4 C
10407 C Antiparallel chains C
10410 C /j\ / \ \ / \ / \ / C
10411 C / \ / \ \ / \ / \ / C
10412 C j1| o |l | o | o| o | | o |o C
10413 C \ |/k\| |/ \| / |/ \| |/ \| C
10414 C \i/ \ / \ / / \ / \ C
10416 C (I) (II) (III) (IV) C
10418 C eello5_1 eello5_2 eello5_3 eello5_4 C
10420 C o denotes a local interaction, vertical lines an electrostatic interaction. C
10422 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10423 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10428 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
10430 itk=itype2loc(itype(k))
10431 itl=itype2loc(itype(l))
10432 itj=itype2loc(itype(j))
10437 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10438 cd & eel5_3_num,eel5_4_num)
10442 derx(lll,kkk,iii)=0.0d0
10446 cd eij=facont_hb(jj,i)
10447 cd ekl=facont_hb(kk,k)
10449 cd write (iout,*)'Contacts have occurred for peptide groups',
10450 cd & i,j,' fcont:',eij,' eij',' and ',k,l
10452 C Contribution from the graph I.
10453 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10454 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10455 call transpose2(EUg(1,1,k),auxmat(1,1))
10456 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10457 vv(1)=pizda(1,1)-pizda(2,2)
10458 vv(2)=pizda(1,2)+pizda(2,1)
10459 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10460 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10461 C Explicit gradient in virtual-dihedral angles.
10462 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10463 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10464 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10465 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10466 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10467 vv(1)=pizda(1,1)-pizda(2,2)
10468 vv(2)=pizda(1,2)+pizda(2,1)
10469 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10470 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10471 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10472 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10473 vv(1)=pizda(1,1)-pizda(2,2)
10474 vv(2)=pizda(1,2)+pizda(2,1)
10476 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10477 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10478 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10480 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10481 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10482 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10484 C Cartesian gradient
10488 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10490 vv(1)=pizda(1,1)-pizda(2,2)
10491 vv(2)=pizda(1,2)+pizda(2,1)
10492 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10493 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10494 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10500 C Contribution from graph II
10501 call transpose2(EE(1,1,k),auxmat(1,1))
10502 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10503 vv(1)=pizda(1,1)+pizda(2,2)
10504 vv(2)=pizda(2,1)-pizda(1,2)
10505 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10506 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10507 C Explicit gradient in virtual-dihedral angles.
10508 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10509 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10510 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10511 vv(1)=pizda(1,1)+pizda(2,2)
10512 vv(2)=pizda(2,1)-pizda(1,2)
10514 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10515 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10516 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10518 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10519 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10520 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10522 C Cartesian gradient
10526 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10528 vv(1)=pizda(1,1)+pizda(2,2)
10529 vv(2)=pizda(2,1)-pizda(1,2)
10530 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10531 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10532 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10540 C Parallel orientation
10541 C Contribution from graph III
10542 call transpose2(EUg(1,1,l),auxmat(1,1))
10543 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10544 vv(1)=pizda(1,1)-pizda(2,2)
10545 vv(2)=pizda(1,2)+pizda(2,1)
10546 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10547 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10548 C Explicit gradient in virtual-dihedral angles.
10549 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10550 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10551 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10552 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10553 vv(1)=pizda(1,1)-pizda(2,2)
10554 vv(2)=pizda(1,2)+pizda(2,1)
10555 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10556 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10557 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10558 call transpose2(EUgder(1,1,l),auxmat1(1,1))
10559 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10560 vv(1)=pizda(1,1)-pizda(2,2)
10561 vv(2)=pizda(1,2)+pizda(2,1)
10562 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10563 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10564 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10565 C Cartesian gradient
10569 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10571 vv(1)=pizda(1,1)-pizda(2,2)
10572 vv(2)=pizda(1,2)+pizda(2,1)
10573 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10574 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10575 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10580 C Contribution from graph IV
10582 call transpose2(EE(1,1,l),auxmat(1,1))
10583 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10584 vv(1)=pizda(1,1)+pizda(2,2)
10585 vv(2)=pizda(2,1)-pizda(1,2)
10586 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10587 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10588 C Explicit gradient in virtual-dihedral angles.
10589 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10590 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10591 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10592 vv(1)=pizda(1,1)+pizda(2,2)
10593 vv(2)=pizda(2,1)-pizda(1,2)
10594 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10595 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10596 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10597 C Cartesian gradient
10601 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10603 vv(1)=pizda(1,1)+pizda(2,2)
10604 vv(2)=pizda(2,1)-pizda(1,2)
10605 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10606 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10607 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10612 C Antiparallel orientation
10613 C Contribution from graph III
10615 call transpose2(EUg(1,1,j),auxmat(1,1))
10616 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10617 vv(1)=pizda(1,1)-pizda(2,2)
10618 vv(2)=pizda(1,2)+pizda(2,1)
10619 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10620 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10621 C Explicit gradient in virtual-dihedral angles.
10622 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10623 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10624 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10625 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10626 vv(1)=pizda(1,1)-pizda(2,2)
10627 vv(2)=pizda(1,2)+pizda(2,1)
10628 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10629 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10630 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10631 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10632 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10633 vv(1)=pizda(1,1)-pizda(2,2)
10634 vv(2)=pizda(1,2)+pizda(2,1)
10635 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10636 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10637 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10638 C Cartesian gradient
10642 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10644 vv(1)=pizda(1,1)-pizda(2,2)
10645 vv(2)=pizda(1,2)+pizda(2,1)
10646 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10647 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10648 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10653 C Contribution from graph IV
10655 call transpose2(EE(1,1,j),auxmat(1,1))
10656 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10657 vv(1)=pizda(1,1)+pizda(2,2)
10658 vv(2)=pizda(2,1)-pizda(1,2)
10659 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10660 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10661 C Explicit gradient in virtual-dihedral angles.
10662 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10663 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10664 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10665 vv(1)=pizda(1,1)+pizda(2,2)
10666 vv(2)=pizda(2,1)-pizda(1,2)
10667 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10668 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10669 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10670 C Cartesian gradient
10674 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10676 vv(1)=pizda(1,1)+pizda(2,2)
10677 vv(2)=pizda(2,1)-pizda(1,2)
10678 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10679 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10680 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10686 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10687 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10688 cd write (2,*) 'ijkl',i,j,k,l
10689 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10690 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10692 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10693 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10694 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10695 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10696 if (j.lt.nres-1) then
10703 if (l.lt.nres-1) then
10713 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10714 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10715 C summed up outside the subrouine as for the other subroutines
10716 C handling long-range interactions. The old code is commented out
10717 C with "cgrad" to keep track of changes.
10719 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10720 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10721 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10722 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10723 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10724 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10725 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10726 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10727 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10728 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10730 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10731 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10732 cgrad ghalf=0.5d0*ggg1(ll)
10734 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10735 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10736 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10737 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10738 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10739 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10740 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10741 cgrad ghalf=0.5d0*ggg2(ll)
10743 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10744 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10745 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10746 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10747 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10748 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10753 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10754 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10759 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10760 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10766 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10771 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10775 cd write (2,*) iii,g_corr5_loc(iii)
10778 cd write (2,*) 'ekont',ekont
10779 cd write (iout,*) 'eello5',ekont*eel5
10782 c--------------------------------------------------------------------------
10783 double precision function eello6(i,j,k,l,jj,kk)
10784 implicit real*8 (a-h,o-z)
10785 include 'DIMENSIONS'
10786 include 'COMMON.IOUNITS'
10787 include 'COMMON.CHAIN'
10788 include 'COMMON.DERIV'
10789 include 'COMMON.INTERACT'
10790 include 'COMMON.CONTACTS'
10791 include 'COMMON.TORSION'
10792 include 'COMMON.VAR'
10793 include 'COMMON.GEO'
10794 include 'COMMON.FFIELD'
10795 double precision ggg1(3),ggg2(3)
10796 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10801 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10809 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10810 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10814 derx(lll,kkk,iii)=0.0d0
10818 cd eij=facont_hb(jj,i)
10819 cd ekl=facont_hb(kk,k)
10825 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10826 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10827 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10828 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10829 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10830 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10832 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10833 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10834 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10835 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10836 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10837 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10841 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10843 C If turn contributions are considered, they will be handled separately.
10844 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10845 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10846 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10847 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10848 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10849 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10850 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10852 if (j.lt.nres-1) then
10859 if (l.lt.nres-1) then
10867 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10868 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10869 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10870 cgrad ghalf=0.5d0*ggg1(ll)
10872 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10873 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10874 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10875 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10876 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10877 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10878 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10879 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10880 cgrad ghalf=0.5d0*ggg2(ll)
10881 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10883 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10884 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10885 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10886 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10887 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10888 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10893 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10894 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10899 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10900 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10906 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10911 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10915 cd write (2,*) iii,g_corr6_loc(iii)
10918 cd write (2,*) 'ekont',ekont
10919 cd write (iout,*) 'eello6',ekont*eel6
10922 c--------------------------------------------------------------------------
10923 double precision function eello6_graph1(i,j,k,l,imat,swap)
10924 implicit real*8 (a-h,o-z)
10925 include 'DIMENSIONS'
10926 include 'COMMON.IOUNITS'
10927 include 'COMMON.CHAIN'
10928 include 'COMMON.DERIV'
10929 include 'COMMON.INTERACT'
10930 include 'COMMON.CONTACTS'
10931 include 'COMMON.TORSION'
10932 include 'COMMON.VAR'
10933 include 'COMMON.GEO'
10934 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10937 common /kutas/ lprn
10938 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10940 C Parallel Antiparallel C
10946 C \ j|/k\| / \ |/k\|l / C
10947 C \ / \ / \ / \ / C
10951 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10952 itk=itype2loc(itype(k))
10953 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10954 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10955 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10956 call transpose2(EUgC(1,1,k),auxmat(1,1))
10957 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10958 vv1(1)=pizda1(1,1)-pizda1(2,2)
10959 vv1(2)=pizda1(1,2)+pizda1(2,1)
10960 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10961 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10962 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10963 s5=scalar2(vv(1),Dtobr2(1,i))
10964 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10965 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10966 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10967 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10968 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10969 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10970 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10971 & +scalar2(vv(1),Dtobr2der(1,i)))
10972 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10973 vv1(1)=pizda1(1,1)-pizda1(2,2)
10974 vv1(2)=pizda1(1,2)+pizda1(2,1)
10975 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10976 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10978 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10979 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10980 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10981 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10982 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10984 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10985 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10986 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10987 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10988 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10990 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10991 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10992 vv1(1)=pizda1(1,1)-pizda1(2,2)
10993 vv1(2)=pizda1(1,2)+pizda1(2,1)
10994 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10995 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10996 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10997 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
11006 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
11007 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
11008 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
11009 call transpose2(EUgC(1,1,k),auxmat(1,1))
11010 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11012 vv1(1)=pizda1(1,1)-pizda1(2,2)
11013 vv1(2)=pizda1(1,2)+pizda1(2,1)
11014 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11015 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11016 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11017 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11018 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11019 s5=scalar2(vv(1),Dtobr2(1,i))
11020 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11026 c----------------------------------------------------------------------------
11027 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11028 implicit real*8 (a-h,o-z)
11029 include 'DIMENSIONS'
11030 include 'COMMON.IOUNITS'
11031 include 'COMMON.CHAIN'
11032 include 'COMMON.DERIV'
11033 include 'COMMON.INTERACT'
11034 include 'COMMON.CONTACTS'
11035 include 'COMMON.TORSION'
11036 include 'COMMON.VAR'
11037 include 'COMMON.GEO'
11039 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11040 & auxvec1(2),auxvec2(2),auxmat1(2,2)
11042 common /kutas/ lprn
11043 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11045 C Parallel Antiparallel C
11051 C \ j|/k\| \ |/k\|l C
11056 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11057 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11058 C AL 7/4/01 s1 would occur in the sixth-order moment,
11059 C but not in a cluster cumulant
11061 s1=dip(1,jj,i)*dip(1,kk,k)
11063 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11064 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11065 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11066 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11067 call transpose2(EUg(1,1,k),auxmat(1,1))
11068 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11069 vv(1)=pizda(1,1)-pizda(2,2)
11070 vv(2)=pizda(1,2)+pizda(2,1)
11071 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11072 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11074 eello6_graph2=-(s1+s2+s3+s4)
11076 eello6_graph2=-(s2+s3+s4)
11078 c eello6_graph2=-s3
11079 C Derivatives in gamma(i-1)
11082 s1=dipderg(1,jj,i)*dip(1,kk,k)
11084 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11085 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11086 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11087 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11089 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11091 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11093 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11095 C Derivatives in gamma(k-1)
11097 s1=dip(1,jj,i)*dipderg(1,kk,k)
11099 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11100 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11101 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11102 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11103 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11104 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11105 vv(1)=pizda(1,1)-pizda(2,2)
11106 vv(2)=pizda(1,2)+pizda(2,1)
11107 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11109 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11111 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11113 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11114 C Derivatives in gamma(j-1) or gamma(l-1)
11117 s1=dipderg(3,jj,i)*dip(1,kk,k)
11119 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11120 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11121 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11122 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11123 vv(1)=pizda(1,1)-pizda(2,2)
11124 vv(2)=pizda(1,2)+pizda(2,1)
11125 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11128 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11130 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11133 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11134 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11136 C Derivatives in gamma(l-1) or gamma(j-1)
11139 s1=dip(1,jj,i)*dipderg(3,kk,k)
11141 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11142 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11143 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11144 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11145 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11146 vv(1)=pizda(1,1)-pizda(2,2)
11147 vv(2)=pizda(1,2)+pizda(2,1)
11148 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11151 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11153 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11156 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11157 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11159 C Cartesian derivatives.
11161 write (2,*) 'In eello6_graph2'
11163 write (2,*) 'iii=',iii
11165 write (2,*) 'kkk=',kkk
11167 write (2,'(3(2f10.5),5x)')
11168 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11178 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11180 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11183 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11185 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11186 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11188 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11189 call transpose2(EUg(1,1,k),auxmat(1,1))
11190 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11192 vv(1)=pizda(1,1)-pizda(2,2)
11193 vv(2)=pizda(1,2)+pizda(2,1)
11194 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11195 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11197 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11199 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11202 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11204 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11211 c----------------------------------------------------------------------------
11212 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11213 implicit real*8 (a-h,o-z)
11214 include 'DIMENSIONS'
11215 include 'COMMON.IOUNITS'
11216 include 'COMMON.CHAIN'
11217 include 'COMMON.DERIV'
11218 include 'COMMON.INTERACT'
11219 include 'COMMON.CONTACTS'
11220 include 'COMMON.TORSION'
11221 include 'COMMON.VAR'
11222 include 'COMMON.GEO'
11223 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11225 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11227 C Parallel Antiparallel C
11232 C /| o |o o| o |\ C
11233 C j|/k\| / |/k\|l / C
11238 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11240 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11241 C energy moment and not to the cluster cumulant.
11242 iti=itortyp(itype(i))
11243 if (j.lt.nres-1) then
11244 itj1=itype2loc(itype(j+1))
11248 itk=itype2loc(itype(k))
11249 itk1=itype2loc(itype(k+1))
11250 if (l.lt.nres-1) then
11251 itl1=itype2loc(itype(l+1))
11256 s1=dip(4,jj,i)*dip(4,kk,k)
11258 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11259 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11260 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11261 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11262 call transpose2(EE(1,1,k),auxmat(1,1))
11263 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11264 vv(1)=pizda(1,1)+pizda(2,2)
11265 vv(2)=pizda(2,1)-pizda(1,2)
11266 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11267 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11268 cd & "sum",-(s2+s3+s4)
11270 eello6_graph3=-(s1+s2+s3+s4)
11272 eello6_graph3=-(s2+s3+s4)
11274 c eello6_graph3=-s4
11275 C Derivatives in gamma(k-1)
11276 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11277 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11278 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11279 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11280 C Derivatives in gamma(l-1)
11281 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11282 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11283 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11284 vv(1)=pizda(1,1)+pizda(2,2)
11285 vv(2)=pizda(2,1)-pizda(1,2)
11286 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11287 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11288 C Cartesian derivatives.
11294 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11296 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11299 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11301 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11302 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11304 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11305 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11307 vv(1)=pizda(1,1)+pizda(2,2)
11308 vv(2)=pizda(2,1)-pizda(1,2)
11309 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11311 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11313 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11316 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11318 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11320 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11326 c----------------------------------------------------------------------------
11327 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11328 implicit real*8 (a-h,o-z)
11329 include 'DIMENSIONS'
11330 include 'COMMON.IOUNITS'
11331 include 'COMMON.CHAIN'
11332 include 'COMMON.DERIV'
11333 include 'COMMON.INTERACT'
11334 include 'COMMON.CONTACTS'
11335 include 'COMMON.TORSION'
11336 include 'COMMON.VAR'
11337 include 'COMMON.GEO'
11338 include 'COMMON.FFIELD'
11339 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11340 & auxvec1(2),auxmat1(2,2)
11342 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11344 C Parallel Antiparallel C
11349 C /| o |o o| o |\ C
11350 C \ j|/k\| \ |/k\|l C
11355 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11357 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11358 C energy moment and not to the cluster cumulant.
11359 cd write (2,*) 'eello_graph4: wturn6',wturn6
11360 iti=itype2loc(itype(i))
11361 itj=itype2loc(itype(j))
11362 if (j.lt.nres-1) then
11363 itj1=itype2loc(itype(j+1))
11367 itk=itype2loc(itype(k))
11368 if (k.lt.nres-1) then
11369 itk1=itype2loc(itype(k+1))
11373 itl=itype2loc(itype(l))
11374 if (l.lt.nres-1) then
11375 itl1=itype2loc(itype(l+1))
11379 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11380 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11381 cd & ' itl',itl,' itl1',itl1
11383 if (imat.eq.1) then
11384 s1=dip(3,jj,i)*dip(3,kk,k)
11386 s1=dip(2,jj,j)*dip(2,kk,l)
11389 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11390 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11392 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11393 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11395 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11396 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11398 call transpose2(EUg(1,1,k),auxmat(1,1))
11399 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11400 vv(1)=pizda(1,1)-pizda(2,2)
11401 vv(2)=pizda(2,1)+pizda(1,2)
11402 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11403 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11405 eello6_graph4=-(s1+s2+s3+s4)
11407 eello6_graph4=-(s2+s3+s4)
11409 C Derivatives in gamma(i-1)
11412 if (imat.eq.1) then
11413 s1=dipderg(2,jj,i)*dip(3,kk,k)
11415 s1=dipderg(4,jj,j)*dip(2,kk,l)
11418 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11420 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11421 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11423 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11424 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11426 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11427 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11428 cd write (2,*) 'turn6 derivatives'
11430 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11432 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11436 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11438 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11442 C Derivatives in gamma(k-1)
11444 if (imat.eq.1) then
11445 s1=dip(3,jj,i)*dipderg(2,kk,k)
11447 s1=dip(2,jj,j)*dipderg(4,kk,l)
11450 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11451 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11453 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11454 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11456 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11457 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11459 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11460 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11461 vv(1)=pizda(1,1)-pizda(2,2)
11462 vv(2)=pizda(2,1)+pizda(1,2)
11463 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11464 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11466 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11468 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11472 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11474 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11477 C Derivatives in gamma(j-1) or gamma(l-1)
11478 if (l.eq.j+1 .and. l.gt.1) then
11479 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11480 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11481 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11482 vv(1)=pizda(1,1)-pizda(2,2)
11483 vv(2)=pizda(2,1)+pizda(1,2)
11484 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11485 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11486 else if (j.gt.1) then
11487 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11488 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11489 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11490 vv(1)=pizda(1,1)-pizda(2,2)
11491 vv(2)=pizda(2,1)+pizda(1,2)
11492 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11493 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11494 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11496 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11499 C Cartesian derivatives.
11505 if (imat.eq.1) then
11506 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11508 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11511 if (imat.eq.1) then
11512 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11514 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11518 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11520 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11522 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11523 & b1(1,j+1),auxvec(1))
11524 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11526 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11527 & b1(1,l+1),auxvec(1))
11528 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11530 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11532 vv(1)=pizda(1,1)-pizda(2,2)
11533 vv(2)=pizda(2,1)+pizda(1,2)
11534 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11536 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11538 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11541 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11544 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11547 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11549 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11551 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11555 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11557 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11560 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11562 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11570 c----------------------------------------------------------------------------
11571 double precision function eello_turn6(i,jj,kk)
11572 implicit real*8 (a-h,o-z)
11573 include 'DIMENSIONS'
11574 include 'COMMON.IOUNITS'
11575 include 'COMMON.CHAIN'
11576 include 'COMMON.DERIV'
11577 include 'COMMON.INTERACT'
11578 include 'COMMON.CONTACTS'
11579 include 'COMMON.TORSION'
11580 include 'COMMON.VAR'
11581 include 'COMMON.GEO'
11582 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11583 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11585 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11586 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11587 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11588 C the respective energy moment and not to the cluster cumulant.
11597 iti=itype2loc(itype(i))
11598 itk=itype2loc(itype(k))
11599 itk1=itype2loc(itype(k+1))
11600 itl=itype2loc(itype(l))
11601 itj=itype2loc(itype(j))
11602 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11603 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11604 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11609 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11611 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11615 derx_turn(lll,kkk,iii)=0.0d0
11622 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11624 cd write (2,*) 'eello6_5',eello6_5
11626 call transpose2(AEA(1,1,1),auxmat(1,1))
11627 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11628 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11629 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11631 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11632 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11633 s2 = scalar2(b1(1,k),vtemp1(1))
11635 call transpose2(AEA(1,1,2),atemp(1,1))
11636 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11637 call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11638 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11640 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11641 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11642 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11644 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11645 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11646 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11647 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11648 ss13 = scalar2(b1(1,k),vtemp4(1))
11649 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11651 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11657 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11658 C Derivatives in gamma(i+2)
11662 call transpose2(AEA(1,1,1),auxmatd(1,1))
11663 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11664 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11665 call transpose2(AEAderg(1,1,2),atempd(1,1))
11666 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11667 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11669 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11670 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11671 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11677 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11678 C Derivatives in gamma(i+3)
11680 call transpose2(AEA(1,1,1),auxmatd(1,1))
11681 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11682 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11683 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11685 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11686 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11687 s2d = scalar2(b1(1,k),vtemp1d(1))
11689 call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11690 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11692 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11694 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11695 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11696 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11704 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11705 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11707 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11708 & -0.5d0*ekont*(s2d+s12d)
11710 C Derivatives in gamma(i+4)
11711 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11712 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11713 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11715 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11716 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11717 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11725 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11727 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11729 C Derivatives in gamma(i+5)
11731 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11732 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11733 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11735 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11736 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11737 s2d = scalar2(b1(1,k),vtemp1d(1))
11739 call transpose2(AEA(1,1,2),atempd(1,1))
11740 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11741 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11743 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11744 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11746 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11747 ss13d = scalar2(b1(1,k),vtemp4d(1))
11748 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11756 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11757 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11759 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11760 & -0.5d0*ekont*(s2d+s12d)
11762 C Cartesian derivatives
11767 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11768 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11769 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11771 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11772 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11774 s2d = scalar2(b1(1,k),vtemp1d(1))
11776 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11777 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11778 s8d = -(atempd(1,1)+atempd(2,2))*
11779 & scalar2(cc(1,1,l),vtemp2(1))
11781 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11783 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11784 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11791 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11792 & - 0.5d0*(s1d+s2d)
11794 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11798 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11799 & - 0.5d0*(s8d+s12d)
11801 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11810 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11811 & achuj_tempd(1,1))
11812 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11813 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11814 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11815 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11816 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11818 ss13d = scalar2(b1(1,k),vtemp4d(1))
11819 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11820 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11824 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11825 cd & 16*eel_turn6_num
11827 if (j.lt.nres-1) then
11834 if (l.lt.nres-1) then
11842 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11843 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11844 cgrad ghalf=0.5d0*ggg1(ll)
11846 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11847 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11848 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11849 & +ekont*derx_turn(ll,2,1)
11850 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11851 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11852 & +ekont*derx_turn(ll,4,1)
11853 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11854 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11855 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11856 cgrad ghalf=0.5d0*ggg2(ll)
11858 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11859 & +ekont*derx_turn(ll,2,2)
11860 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11861 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11862 & +ekont*derx_turn(ll,4,2)
11863 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11864 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11865 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11870 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11875 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11881 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11886 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11890 cd write (2,*) iii,g_corr6_loc(iii)
11892 eello_turn6=ekont*eel_turn6
11893 cd write (2,*) 'ekont',ekont
11894 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11898 C-----------------------------------------------------------------------------
11899 double precision function scalar(u,v)
11900 !DIR$ INLINEALWAYS scalar
11902 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11905 double precision u(3),v(3)
11906 cd double precision sc
11914 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11917 crc-------------------------------------------------
11918 SUBROUTINE MATVEC2(A1,V1,V2)
11919 !DIR$ INLINEALWAYS MATVEC2
11921 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11923 implicit real*8 (a-h,o-z)
11924 include 'DIMENSIONS'
11925 DIMENSION A1(2,2),V1(2),V2(2)
11929 c 3 VI=VI+A1(I,K)*V1(K)
11933 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11934 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11939 C---------------------------------------
11940 SUBROUTINE MATMAT2(A1,A2,A3)
11942 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11944 implicit real*8 (a-h,o-z)
11945 include 'DIMENSIONS'
11946 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11947 c DIMENSION AI3(2,2)
11951 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11957 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11958 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11959 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11960 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11968 c-------------------------------------------------------------------------
11969 double precision function scalar2(u,v)
11970 !DIR$ INLINEALWAYS scalar2
11972 double precision u(2),v(2)
11973 double precision sc
11975 scalar2=u(1)*v(1)+u(2)*v(2)
11979 C-----------------------------------------------------------------------------
11981 subroutine transpose2(a,at)
11982 !DIR$ INLINEALWAYS transpose2
11984 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11987 double precision a(2,2),at(2,2)
11994 c--------------------------------------------------------------------------
11995 subroutine transpose(n,a,at)
11998 double precision a(n,n),at(n,n)
12006 C---------------------------------------------------------------------------
12007 subroutine prodmat3(a1,a2,kk,transp,prod)
12008 !DIR$ INLINEALWAYS prodmat3
12010 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12014 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12016 crc double precision auxmat(2,2),prod_(2,2)
12019 crc call transpose2(kk(1,1),auxmat(1,1))
12020 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12021 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12023 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12024 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12025 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12026 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12027 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12028 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12029 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12030 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12033 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12034 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12036 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12037 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12038 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12039 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12040 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12041 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12042 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12043 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12046 c call transpose2(a2(1,1),a2t(1,1))
12049 crc print *,((prod_(i,j),i=1,2),j=1,2)
12050 crc print *,((prod(i,j),i=1,2),j=1,2)
12054 CCC----------------------------------------------
12055 subroutine Eliptransfer(eliptran)
12056 implicit real*8 (a-h,o-z)
12057 include 'DIMENSIONS'
12058 include 'COMMON.GEO'
12059 include 'COMMON.VAR'
12060 include 'COMMON.LOCAL'
12061 include 'COMMON.CHAIN'
12062 include 'COMMON.DERIV'
12063 include 'COMMON.NAMES'
12064 include 'COMMON.INTERACT'
12065 include 'COMMON.IOUNITS'
12066 include 'COMMON.CALC'
12067 include 'COMMON.CONTROL'
12068 include 'COMMON.SPLITELE'
12069 include 'COMMON.SBRIDGE'
12070 C this is done by Adasko
12071 C print *,"wchodze"
12072 C structure of box:
12074 C--bordliptop-- buffore starts
12075 C--bufliptop--- here true lipid starts
12077 C--buflipbot--- lipid ends buffore starts
12078 C--bordlipbot--buffore ends
12080 do i=ilip_start,ilip_end
12082 if (itype(i).eq.ntyp1) cycle
12084 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12085 if (positi.le.0.0) positi=positi+boxzsize
12087 C first for peptide groups
12088 c for each residue check if it is in lipid or lipid water border area
12089 if ((positi.gt.bordlipbot)
12090 &.and.(positi.lt.bordliptop)) then
12091 C the energy transfer exist
12092 if (positi.lt.buflipbot) then
12093 C what fraction I am in
12095 & ((positi-bordlipbot)/lipbufthick)
12096 C lipbufthick is thickenes of lipid buffore
12097 sslip=sscalelip(fracinbuf)
12098 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12099 eliptran=eliptran+sslip*pepliptran
12100 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12101 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12102 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12104 C print *,"doing sccale for lower part"
12105 C print *,i,sslip,fracinbuf,ssgradlip
12106 elseif (positi.gt.bufliptop) then
12107 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12108 sslip=sscalelip(fracinbuf)
12109 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12110 eliptran=eliptran+sslip*pepliptran
12111 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12112 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12113 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12114 C print *, "doing sscalefor top part"
12115 C print *,i,sslip,fracinbuf,ssgradlip
12117 eliptran=eliptran+pepliptran
12118 C print *,"I am in true lipid"
12121 C eliptran=elpitran+0.0 ! I am in water
12124 C print *, "nic nie bylo w lipidzie?"
12125 C now multiply all by the peptide group transfer factor
12126 C eliptran=eliptran*pepliptran
12127 C now the same for side chains
12129 do i=ilip_start,ilip_end
12130 if (itype(i).eq.ntyp1) cycle
12131 positi=(mod(c(3,i+nres),boxzsize))
12132 if (positi.le.0) positi=positi+boxzsize
12133 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12134 c for each residue check if it is in lipid or lipid water border area
12135 C respos=mod(c(3,i+nres),boxzsize)
12136 C print *,positi,bordlipbot,buflipbot
12137 if ((positi.gt.bordlipbot)
12138 & .and.(positi.lt.bordliptop)) then
12139 C the energy transfer exist
12140 if (positi.lt.buflipbot) then
12142 & ((positi-bordlipbot)/lipbufthick)
12143 C lipbufthick is thickenes of lipid buffore
12144 sslip=sscalelip(fracinbuf)
12145 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12146 eliptran=eliptran+sslip*liptranene(itype(i))
12147 gliptranx(3,i)=gliptranx(3,i)
12148 &+ssgradlip*liptranene(itype(i))
12149 gliptranc(3,i-1)= gliptranc(3,i-1)
12150 &+ssgradlip*liptranene(itype(i))
12151 C print *,"doing sccale for lower part"
12152 elseif (positi.gt.bufliptop) then
12154 &((bordliptop-positi)/lipbufthick)
12155 sslip=sscalelip(fracinbuf)
12156 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12157 eliptran=eliptran+sslip*liptranene(itype(i))
12158 gliptranx(3,i)=gliptranx(3,i)
12159 &+ssgradlip*liptranene(itype(i))
12160 gliptranc(3,i-1)= gliptranc(3,i-1)
12161 &+ssgradlip*liptranene(itype(i))
12162 C print *, "doing sscalefor top part",sslip,fracinbuf
12164 eliptran=eliptran+liptranene(itype(i))
12165 C print *,"I am in true lipid"
12167 endif ! if in lipid or buffor
12169 C eliptran=elpitran+0.0 ! I am in water
12173 C---------------------------------------------------------
12174 C AFM soubroutine for constant force
12175 subroutine AFMforce(Eafmforce)
12176 implicit real*8 (a-h,o-z)
12177 include 'DIMENSIONS'
12178 include 'COMMON.GEO'
12179 include 'COMMON.VAR'
12180 include 'COMMON.LOCAL'
12181 include 'COMMON.CHAIN'
12182 include 'COMMON.DERIV'
12183 include 'COMMON.NAMES'
12184 include 'COMMON.INTERACT'
12185 include 'COMMON.IOUNITS'
12186 include 'COMMON.CALC'
12187 include 'COMMON.CONTROL'
12188 include 'COMMON.SPLITELE'
12189 include 'COMMON.SBRIDGE'
12194 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12195 dist=dist+diffafm(i)**2
12198 Eafmforce=-forceAFMconst*(dist-distafminit)
12200 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12201 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12203 C print *,'AFM',Eafmforce
12206 C---------------------------------------------------------
12207 C AFM subroutine with pseudoconstant velocity
12208 subroutine AFMvel(Eafmforce)
12209 implicit real*8 (a-h,o-z)
12210 include 'DIMENSIONS'
12211 include 'COMMON.GEO'
12212 include 'COMMON.VAR'
12213 include 'COMMON.LOCAL'
12214 include 'COMMON.CHAIN'
12215 include 'COMMON.DERIV'
12216 include 'COMMON.NAMES'
12217 include 'COMMON.INTERACT'
12218 include 'COMMON.IOUNITS'
12219 include 'COMMON.CALC'
12220 include 'COMMON.CONTROL'
12221 include 'COMMON.SPLITELE'
12222 include 'COMMON.SBRIDGE'
12224 C Only for check grad COMMENT if not used for checkgrad
12226 C--------------------------------------------------------
12227 C print *,"wchodze"
12231 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12232 dist=dist+diffafm(i)**2
12235 Eafmforce=0.5d0*forceAFMconst
12236 & *(distafminit+totTafm*velAFMconst-dist)**2
12237 C Eafmforce=-forceAFMconst*(dist-distafminit)
12239 gradafm(i,afmend-1)=-forceAFMconst*
12240 &(distafminit+totTafm*velAFMconst-dist)
12242 gradafm(i,afmbeg-1)=forceAFMconst*
12243 &(distafminit+totTafm*velAFMconst-dist)
12246 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12249 C-----------------------------------------------------------
12250 C first for shielding is setting of function of side-chains
12251 subroutine set_shield_fac
12252 implicit real*8 (a-h,o-z)
12253 include 'DIMENSIONS'
12254 include 'COMMON.CHAIN'
12255 include 'COMMON.DERIV'
12256 include 'COMMON.IOUNITS'
12257 include 'COMMON.SHIELD'
12258 include 'COMMON.INTERACT'
12259 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12260 double precision div77_81/0.974996043d0/,
12261 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12263 C the vector between center of side_chain and peptide group
12264 double precision pep_side(3),long,side_calf(3),
12265 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12266 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12267 C the line belowe needs to be changed for FGPROC>1
12269 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12271 Cif there two consequtive dummy atoms there is no peptide group between them
12272 C the line below has to be changed for FGPROC>1
12275 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12279 C first lets set vector conecting the ithe side-chain with kth side-chain
12280 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12281 C pep_side(j)=2.0d0
12282 C and vector conecting the side-chain with its proper calfa
12283 side_calf(j)=c(j,k+nres)-c(j,k)
12284 C side_calf(j)=2.0d0
12285 pept_group(j)=c(j,i)-c(j,i+1)
12286 C lets have their lenght
12287 dist_pep_side=pep_side(j)**2+dist_pep_side
12288 dist_side_calf=dist_side_calf+side_calf(j)**2
12289 dist_pept_group=dist_pept_group+pept_group(j)**2
12291 dist_pep_side=dsqrt(dist_pep_side)
12292 dist_pept_group=dsqrt(dist_pept_group)
12293 dist_side_calf=dsqrt(dist_side_calf)
12295 pep_side_norm(j)=pep_side(j)/dist_pep_side
12296 side_calf_norm(j)=dist_side_calf
12298 C now sscale fraction
12299 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12300 C print *,buff_shield,"buff"
12302 if (sh_frac_dist.le.0.0) cycle
12303 C If we reach here it means that this side chain reaches the shielding sphere
12304 C Lets add him to the list for gradient
12305 ishield_list(i)=ishield_list(i)+1
12306 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12307 C this list is essential otherwise problem would be O3
12308 shield_list(ishield_list(i),i)=k
12309 C Lets have the sscale value
12310 if (sh_frac_dist.gt.1.0) then
12311 scale_fac_dist=1.0d0
12313 sh_frac_dist_grad(j)=0.0d0
12316 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12317 & *(2.0*sh_frac_dist-3.0d0)
12318 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12319 & /dist_pep_side/buff_shield*0.5
12320 C remember for the final gradient multiply sh_frac_dist_grad(j)
12321 C for side_chain by factor -2 !
12323 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12324 C print *,"jestem",scale_fac_dist,fac_help_scale,
12325 C & sh_frac_dist_grad(j)
12328 C if ((i.eq.3).and.(k.eq.2)) then
12329 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12333 C this is what is now we have the distance scaling now volume...
12334 short=short_r_sidechain(itype(k))
12335 long=long_r_sidechain(itype(k))
12336 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12339 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12340 C costhet_fac=0.0d0
12342 costhet_grad(j)=costhet_fac*pep_side(j)
12344 C remember for the final gradient multiply costhet_grad(j)
12345 C for side_chain by factor -2 !
12346 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12347 C pep_side0pept_group is vector multiplication
12348 pep_side0pept_group=0.0
12350 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12352 cosalfa=(pep_side0pept_group/
12353 & (dist_pep_side*dist_side_calf))
12354 fac_alfa_sin=1.0-cosalfa**2
12355 fac_alfa_sin=dsqrt(fac_alfa_sin)
12356 rkprim=fac_alfa_sin*(long-short)+short
12358 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12359 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12362 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12363 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12364 &*(long-short)/fac_alfa_sin*cosalfa/
12365 &((dist_pep_side*dist_side_calf))*
12366 &((side_calf(j))-cosalfa*
12367 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12369 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12370 &*(long-short)/fac_alfa_sin*cosalfa
12371 &/((dist_pep_side*dist_side_calf))*
12373 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12376 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12379 C now the gradient...
12380 C grad_shield is gradient of Calfa for peptide groups
12381 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12383 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12384 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12386 grad_shield(j,i)=grad_shield(j,i)
12387 C gradient po skalowaniu
12388 & +(sh_frac_dist_grad(j)
12389 C gradient po costhet
12390 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12391 &-scale_fac_dist*(cosphi_grad_long(j))
12392 &/(1.0-cosphi) )*div77_81
12394 C grad_shield_side is Cbeta sidechain gradient
12395 grad_shield_side(j,ishield_list(i),i)=
12396 & (sh_frac_dist_grad(j)*(-2.0d0)
12397 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12398 & +scale_fac_dist*(cosphi_grad_long(j))
12399 & *2.0d0/(1.0-cosphi))
12400 & *div77_81*VofOverlap
12402 grad_shield_loc(j,ishield_list(i),i)=
12403 & scale_fac_dist*cosphi_grad_loc(j)
12404 & *2.0d0/(1.0-cosphi)
12405 & *div77_81*VofOverlap
12407 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12409 fac_shield(i)=VolumeTotal*div77_81+div4_81
12410 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12414 C--------------------------------------------------------------------------
12415 double precision function tschebyshev(m,n,x,y)
12417 include "DIMENSIONS"
12419 double precision x(n),y,yy(0:maxvar),aux
12420 c Tschebyshev polynomial. Note that the first term is omitted
12421 c m=0: the constant term is included
12422 c m=1: the constant term is not included
12426 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12435 C--------------------------------------------------------------------------
12436 double precision function gradtschebyshev(m,n,x,y)
12438 include "DIMENSIONS"
12440 double precision x(n+1),y,yy(0:maxvar),aux
12441 c Tschebyshev polynomial. Note that the first term is omitted
12442 c m=0: the constant term is included
12443 c m=1: the constant term is not included
12447 yy(i)=2*y*yy(i-1)-yy(i-2)
12451 aux=aux+x(i+1)*yy(i)*(i+1)
12452 C print *, x(i+1),yy(i),i
12454 gradtschebyshev=aux
12457 C------------------------------------------------------------------------
12458 C first for shielding is setting of function of side-chains
12459 subroutine set_shield_fac2
12460 implicit real*8 (a-h,o-z)
12461 include 'DIMENSIONS'
12462 include 'COMMON.CHAIN'
12463 include 'COMMON.DERIV'
12464 include 'COMMON.IOUNITS'
12465 include 'COMMON.SHIELD'
12466 include 'COMMON.INTERACT'
12467 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12468 double precision div77_81/0.974996043d0/,
12469 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12471 C the vector between center of side_chain and peptide group
12472 double precision pep_side(3),long,side_calf(3),
12473 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12474 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12475 C the line belowe needs to be changed for FGPROC>1
12477 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12479 Cif there two consequtive dummy atoms there is no peptide group between them
12480 C the line below has to be changed for FGPROC>1
12483 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12487 C first lets set vector conecting the ithe side-chain with kth side-chain
12488 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12489 C pep_side(j)=2.0d0
12490 C and vector conecting the side-chain with its proper calfa
12491 side_calf(j)=c(j,k+nres)-c(j,k)
12492 C side_calf(j)=2.0d0
12493 pept_group(j)=c(j,i)-c(j,i+1)
12494 C lets have their lenght
12495 dist_pep_side=pep_side(j)**2+dist_pep_side
12496 dist_side_calf=dist_side_calf+side_calf(j)**2
12497 dist_pept_group=dist_pept_group+pept_group(j)**2
12499 dist_pep_side=dsqrt(dist_pep_side)
12500 dist_pept_group=dsqrt(dist_pept_group)
12501 dist_side_calf=dsqrt(dist_side_calf)
12503 pep_side_norm(j)=pep_side(j)/dist_pep_side
12504 side_calf_norm(j)=dist_side_calf
12506 C now sscale fraction
12507 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12508 C print *,buff_shield,"buff"
12510 if (sh_frac_dist.le.0.0) cycle
12511 C If we reach here it means that this side chain reaches the shielding sphere
12512 C Lets add him to the list for gradient
12513 ishield_list(i)=ishield_list(i)+1
12514 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12515 C this list is essential otherwise problem would be O3
12516 shield_list(ishield_list(i),i)=k
12517 C Lets have the sscale value
12518 if (sh_frac_dist.gt.1.0) then
12519 scale_fac_dist=1.0d0
12521 sh_frac_dist_grad(j)=0.0d0
12524 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12525 & *(2.0d0*sh_frac_dist-3.0d0)
12526 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12527 & /dist_pep_side/buff_shield*0.5d0
12528 C remember for the final gradient multiply sh_frac_dist_grad(j)
12529 C for side_chain by factor -2 !
12531 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12532 C sh_frac_dist_grad(j)=0.0d0
12533 C scale_fac_dist=1.0d0
12534 C print *,"jestem",scale_fac_dist,fac_help_scale,
12535 C & sh_frac_dist_grad(j)
12538 C this is what is now we have the distance scaling now volume...
12539 short=short_r_sidechain(itype(k))
12540 long=long_r_sidechain(itype(k))
12541 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12542 sinthet=short/dist_pep_side*costhet
12546 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12547 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12548 C & -short/dist_pep_side**2/costhet)
12549 C costhet_fac=0.0d0
12551 costhet_grad(j)=costhet_fac*pep_side(j)
12553 C remember for the final gradient multiply costhet_grad(j)
12554 C for side_chain by factor -2 !
12555 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12556 C pep_side0pept_group is vector multiplication
12557 pep_side0pept_group=0.0d0
12559 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12561 cosalfa=(pep_side0pept_group/
12562 & (dist_pep_side*dist_side_calf))
12563 fac_alfa_sin=1.0d0-cosalfa**2
12564 fac_alfa_sin=dsqrt(fac_alfa_sin)
12565 rkprim=fac_alfa_sin*(long-short)+short
12569 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12571 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12572 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12573 & dist_pep_side**2)
12576 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12577 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12578 &*(long-short)/fac_alfa_sin*cosalfa/
12579 &((dist_pep_side*dist_side_calf))*
12580 &((side_calf(j))-cosalfa*
12581 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12582 C cosphi_grad_long(j)=0.0d0
12583 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12584 &*(long-short)/fac_alfa_sin*cosalfa
12585 &/((dist_pep_side*dist_side_calf))*
12587 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12588 C cosphi_grad_loc(j)=0.0d0
12590 C print *,sinphi,sinthet
12591 c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12592 c & VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12593 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12596 C now the gradient...
12598 grad_shield(j,i)=grad_shield(j,i)
12599 C gradient po skalowaniu
12600 & +(sh_frac_dist_grad(j)*VofOverlap
12601 C gradient po costhet
12602 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12603 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12604 & sinphi/sinthet*costhet*costhet_grad(j)
12605 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12607 C grad_shield_side is Cbeta sidechain gradient
12608 grad_shield_side(j,ishield_list(i),i)=
12609 & (sh_frac_dist_grad(j)*(-2.0d0)
12611 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12612 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12613 & sinphi/sinthet*costhet*costhet_grad(j)
12614 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12617 grad_shield_loc(j,ishield_list(i),i)=
12618 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12619 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12620 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12624 c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12626 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12628 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12629 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12630 c & " wshield",wshield
12631 c write(2,*) "TU",rpp(1,1),short,long,buff_shield
12635 C-----------------------------------------------------------------------
12636 C-----------------------------------------------------------
12637 C This subroutine is to mimic the histone like structure but as well can be
12638 C utilizet to nanostructures (infinit) small modification has to be used to
12639 C make it finite (z gradient at the ends has to be changes as well as the x,y
12640 C gradient has to be modified at the ends
12641 C The energy function is Kihara potential
12642 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12643 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12644 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12645 C simple Kihara potential
12646 subroutine calctube(Etube)
12647 implicit real*8 (a-h,o-z)
12648 include 'DIMENSIONS'
12649 include 'COMMON.GEO'
12650 include 'COMMON.VAR'
12651 include 'COMMON.LOCAL'
12652 include 'COMMON.CHAIN'
12653 include 'COMMON.DERIV'
12654 include 'COMMON.NAMES'
12655 include 'COMMON.INTERACT'
12656 include 'COMMON.IOUNITS'
12657 include 'COMMON.CALC'
12658 include 'COMMON.CONTROL'
12659 include 'COMMON.SPLITELE'
12660 include 'COMMON.SBRIDGE'
12661 double precision tub_r,vectube(3),enetube(maxres*2)
12666 C first we calculate the distance from tube center
12667 C first sugare-phosphate group for NARES this would be peptide group
12670 C lets ommit dummy atoms for now
12671 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12672 C now calculate distance from center of tube and direction vectors
12673 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12674 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12675 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12676 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12677 vectube(1)=vectube(1)-tubecenter(1)
12678 vectube(2)=vectube(2)-tubecenter(2)
12680 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12681 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12683 C as the tube is infinity we do not calculate the Z-vector use of Z
12686 C now calculte the distance
12687 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12688 C now normalize vector
12689 vectube(1)=vectube(1)/tub_r
12690 vectube(2)=vectube(2)/tub_r
12691 C calculte rdiffrence between r and r0
12694 rdiff6=rdiff**6.0d0
12695 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12696 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12697 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12698 C print *,rdiff,rdiff6,pep_aa_tube
12699 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12700 C now we calculate gradient
12701 fac=(-12.0d0*pep_aa_tube/rdiff6+
12702 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12703 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12706 C now direction of gg_tube vector
12708 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12709 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12712 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12714 C Lets not jump over memory as we use many times iti
12716 C lets ommit dummy atoms for now
12718 C in UNRES uncomment the line below as GLY has no side-chain...
12721 vectube(1)=c(1,i+nres)
12722 vectube(1)=mod(vectube(1),boxxsize)
12723 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12724 vectube(2)=c(2,i+nres)
12725 vectube(2)=mod(vectube(2),boxxsize)
12726 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12728 vectube(1)=vectube(1)-tubecenter(1)
12729 vectube(2)=vectube(2)-tubecenter(2)
12731 C as the tube is infinity we do not calculate the Z-vector use of Z
12734 C now calculte the distance
12735 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12736 C now normalize vector
12737 vectube(1)=vectube(1)/tub_r
12738 vectube(2)=vectube(2)/tub_r
12739 C calculte rdiffrence between r and r0
12742 rdiff6=rdiff**6.0d0
12743 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12744 sc_aa_tube=sc_aa_tube_par(iti)
12745 sc_bb_tube=sc_bb_tube_par(iti)
12746 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12747 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12748 C now we calculate gradient
12749 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12750 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12751 C now direction of gg_tube vector
12753 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12754 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12758 Etube=Etube+enetube(i)
12760 C print *,"ETUBE", etube
12763 C TO DO 1) add to total energy
12764 C 2) add to gradient summation
12765 C 3) add reading parameters (AND of course oppening of PARAM file)
12766 C 4) add reading the center of tube
12768 C 6) add to zerograd
12770 C-----------------------------------------------------------------------
12771 C-----------------------------------------------------------
12772 C This subroutine is to mimic the histone like structure but as well can be
12773 C utilizet to nanostructures (infinit) small modification has to be used to
12774 C make it finite (z gradient at the ends has to be changes as well as the x,y
12775 C gradient has to be modified at the ends
12776 C The energy function is Kihara potential
12777 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12778 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12779 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12780 C simple Kihara potential
12781 subroutine calctube2(Etube)
12782 implicit real*8 (a-h,o-z)
12783 include 'DIMENSIONS'
12784 include 'COMMON.GEO'
12785 include 'COMMON.VAR'
12786 include 'COMMON.LOCAL'
12787 include 'COMMON.CHAIN'
12788 include 'COMMON.DERIV'
12789 include 'COMMON.NAMES'
12790 include 'COMMON.INTERACT'
12791 include 'COMMON.IOUNITS'
12792 include 'COMMON.CALC'
12793 include 'COMMON.CONTROL'
12794 include 'COMMON.SPLITELE'
12795 include 'COMMON.SBRIDGE'
12796 double precision tub_r,vectube(3),enetube(maxres*2)
12801 C first we calculate the distance from tube center
12802 C first sugare-phosphate group for NARES this would be peptide group
12805 C lets ommit dummy atoms for now
12806 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12807 C now calculate distance from center of tube and direction vectors
12808 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12809 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12810 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12811 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12812 vectube(1)=vectube(1)-tubecenter(1)
12813 vectube(2)=vectube(2)-tubecenter(2)
12815 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12816 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12818 C as the tube is infinity we do not calculate the Z-vector use of Z
12821 C now calculte the distance
12822 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12823 C now normalize vector
12824 vectube(1)=vectube(1)/tub_r
12825 vectube(2)=vectube(2)/tub_r
12826 C calculte rdiffrence between r and r0
12829 rdiff6=rdiff**6.0d0
12830 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12831 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12832 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12833 C print *,rdiff,rdiff6,pep_aa_tube
12834 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12835 C now we calculate gradient
12836 fac=(-12.0d0*pep_aa_tube/rdiff6+
12837 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12838 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12841 C now direction of gg_tube vector
12843 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12844 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12847 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12849 C Lets not jump over memory as we use many times iti
12851 C lets ommit dummy atoms for now
12853 C in UNRES uncomment the line below as GLY has no side-chain...
12856 vectube(1)=c(1,i+nres)
12857 vectube(1)=mod(vectube(1),boxxsize)
12858 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12859 vectube(2)=c(2,i+nres)
12860 vectube(2)=mod(vectube(2),boxxsize)
12861 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12863 vectube(1)=vectube(1)-tubecenter(1)
12864 vectube(2)=vectube(2)-tubecenter(2)
12865 C THIS FRAGMENT MAKES TUBE FINITE
12866 positi=(mod(c(3,i+nres),boxzsize))
12867 if (positi.le.0) positi=positi+boxzsize
12868 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12869 c for each residue check if it is in lipid or lipid water border area
12870 C respos=mod(c(3,i+nres),boxzsize)
12871 print *,positi,bordtubebot,buftubebot,bordtubetop
12872 if ((positi.gt.bordtubebot)
12873 & .and.(positi.lt.bordtubetop)) then
12874 C the energy transfer exist
12875 if (positi.lt.buftubebot) then
12877 & ((positi-bordtubebot)/tubebufthick)
12878 C lipbufthick is thickenes of lipid buffore
12879 sstube=sscalelip(fracinbuf)
12880 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12881 print *,ssgradtube, sstube,tubetranene(itype(i))
12882 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12883 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12884 &+ssgradtube*tubetranene(itype(i))
12885 gg_tube(3,i-1)= gg_tube(3,i-1)
12886 &+ssgradtube*tubetranene(itype(i))
12887 C print *,"doing sccale for lower part"
12888 elseif (positi.gt.buftubetop) then
12890 &((bordtubetop-positi)/tubebufthick)
12891 sstube=sscalelip(fracinbuf)
12892 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12893 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12894 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12895 C &+ssgradtube*tubetranene(itype(i))
12896 C gg_tube(3,i-1)= gg_tube(3,i-1)
12897 C &+ssgradtube*tubetranene(itype(i))
12898 C print *, "doing sscalefor top part",sslip,fracinbuf
12902 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12903 C print *,"I am in true lipid"
12909 endif ! if in lipid or buffor
12910 CEND OF FINITE FRAGMENT
12911 C as the tube is infinity we do not calculate the Z-vector use of Z
12914 C now calculte the distance
12915 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12916 C now normalize vector
12917 vectube(1)=vectube(1)/tub_r
12918 vectube(2)=vectube(2)/tub_r
12919 C calculte rdiffrence between r and r0
12922 rdiff6=rdiff**6.0d0
12923 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12924 sc_aa_tube=sc_aa_tube_par(iti)
12925 sc_bb_tube=sc_bb_tube_par(iti)
12926 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12927 & *sstube+enetube(i+nres)
12928 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12929 C now we calculate gradient
12930 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12931 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12932 C now direction of gg_tube vector
12934 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12935 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12937 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12938 &+ssgradtube*enetube(i+nres)/sstube
12939 gg_tube(3,i-1)= gg_tube(3,i-1)
12940 &+ssgradtube*enetube(i+nres)/sstube
12944 Etube=Etube+enetube(i)
12946 C print *,"ETUBE", etube
12949 C TO DO 1) add to total energy
12950 C 2) add to gradient summation
12951 C 3) add reading parameters (AND of course oppening of PARAM file)
12952 C 4) add reading the center of tube
12954 C 6) add to zerograd
12955 c----------------------------------------------------------------------------
12956 subroutine e_saxs(Esaxs_constr)
12958 include 'DIMENSIONS'
12961 include "COMMON.SETUP"
12964 include 'COMMON.SBRIDGE'
12965 include 'COMMON.CHAIN'
12966 include 'COMMON.GEO'
12967 include 'COMMON.DERIV'
12968 include 'COMMON.LOCAL'
12969 include 'COMMON.INTERACT'
12970 include 'COMMON.VAR'
12971 include 'COMMON.IOUNITS'
12972 include 'COMMON.MD'
12973 include 'COMMON.CONTROL'
12974 include 'COMMON.NAMES'
12975 include 'COMMON.TIME1'
12976 include 'COMMON.FFIELD'
12978 double precision Esaxs_constr
12979 integer i,iint,j,k,l
12980 double precision PgradC(maxSAXS,3,maxres),
12981 & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12983 double precision PgradC_(maxSAXS,3,maxres),
12984 & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12986 double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12987 & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12988 & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12989 & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12990 double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12991 double precision dist,mygauss,mygaussder
12993 integer llicz,lllicz
12994 double precision time01
12995 c SAXS restraint penalty function
12997 write(iout,*) "------- SAXS penalty function start -------"
12998 write (iout,*) "nsaxs",nsaxs
12999 write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13000 write (iout,*) "Psaxs"
13002 write (iout,'(i5,e15.5)') i, Psaxs(i)
13008 Esaxs_constr = 0.0d0
13013 PgradC(k,l,j)=0.0d0
13014 PgradX(k,l,j)=0.0d0
13019 do i=iatsc_s,iatsc_e
13020 if (itype(i).eq.ntyp1) cycle
13021 do iint=1,nint_gr(i)
13022 do j=istart(i,iint),iend(i,iint)
13023 if (itype(j).eq.ntyp1) cycle
13026 dijCASC=dist(i,j+nres)
13027 dijSCCA=dist(i+nres,j)
13028 dijSCSC=dist(i+nres,j+nres)
13029 sigma2CACA=2.0d0/(pstok**2)
13030 sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13031 sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13032 sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13035 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13036 if (itype(j).ne.10) then
13037 expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13041 if (itype(i).ne.10) then
13042 expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13046 if (itype(i).ne.10 .and. itype(j).ne.10) then
13047 expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13051 Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13053 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13055 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13056 CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13057 SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13058 SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13061 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13062 PgradC(k,l,i) = PgradC(k,l,i)-aux
13063 PgradC(k,l,j) = PgradC(k,l,j)+aux
13065 if (itype(j).ne.10) then
13066 aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13067 PgradC(k,l,i) = PgradC(k,l,i)-aux
13068 PgradC(k,l,j) = PgradC(k,l,j)+aux
13069 PgradX(k,l,j) = PgradX(k,l,j)+aux
13072 if (itype(i).ne.10) then
13073 aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13074 PgradX(k,l,i) = PgradX(k,l,i)-aux
13075 PgradC(k,l,i) = PgradC(k,l,i)-aux
13076 PgradC(k,l,j) = PgradC(k,l,j)+aux
13079 if (itype(i).ne.10 .and. itype(j).ne.10) then
13080 aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13081 PgradC(k,l,i) = PgradC(k,l,i)-aux
13082 PgradC(k,l,j) = PgradC(k,l,j)+aux
13083 PgradX(k,l,i) = PgradX(k,l,i)-aux
13084 PgradX(k,l,j) = PgradX(k,l,j)+aux
13090 sigma2CACA=scal_rad**2*0.25d0/
13091 & (restok(itype(j))**2+restok(itype(i))**2)
13092 c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13093 c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13095 sigmaCACA=dsqrt(sigma2CACA)
13096 threesig=3.0d0/sigmaCACA
13100 if (dabs(dijCACA-dk).ge.threesig) cycle
13103 aux = sigmaCACA*(dijCACA-dk)
13104 expCACA = mygauss(aux)
13105 c if (expcaca.eq.0.0d0) cycle
13106 Pcalc(k) = Pcalc(k)+expCACA
13107 CACAgrad = -sigmaCACA*mygaussder(aux)
13108 c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13110 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13111 PgradC(k,l,i) = PgradC(k,l,i)-aux
13112 PgradC(k,l,j) = PgradC(k,l,j)+aux
13115 c write (iout,*) "i",i," j",j," llicz",llicz
13117 IF (saxs_cutoff.eq.0) THEN
13120 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13121 Pcalc(k) = Pcalc(k)+expCACA
13122 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13124 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13125 PgradC(k,l,i) = PgradC(k,l,i)-aux
13126 PgradC(k,l,j) = PgradC(k,l,j)+aux
13130 rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13133 c write (2,*) "ijk",i,j,k
13134 sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13135 if (sss2.eq.0.0d0) cycle
13136 ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13137 if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13138 & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13139 & 1.0d0/dsqrt(sigma2CACA),rrr,dk,
13141 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13142 Pcalc(k) = Pcalc(k)+expCACA
13144 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13146 CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13147 & ssgrad2*expCACA/sss2
13150 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13151 PgradC(k,l,i) = PgradC(k,l,i)+aux
13152 PgradC(k,l,j) = PgradC(k,l,j)-aux
13162 c time_SAXS=time_SAXS+MPI_Wtime()-time01
13164 c write (iout,*) "lllicz",lllicz
13166 c time01=MPI_Wtime()
13169 if (nfgtasks.gt.1) then
13170 call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13171 & MPI_SUM,FG_COMM,IERR)
13172 c if (fg_rank.eq.king) then
13174 Pcalc(k) = Pcalc_(k)
13177 c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13178 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13179 c if (fg_rank.eq.king) then
13183 c PgradC(k,l,i) = PgradC_(k,l,i)
13189 c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13190 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13191 c if (fg_rank.eq.king) then
13195 c PgradX(k,l,i) = PgradX_(k,l,i)
13205 Cnorm = Cnorm + Pcalc(k)
13208 if (fg_rank.eq.king) then
13210 Esaxs_constr = dlog(Cnorm)-wsaxs0
13212 if (Pcalc(k).gt.0.0d0)
13213 & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13215 write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13219 write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13234 & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13235 auxC1 = auxC1+PgradC(k,l,i)
13237 auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13238 auxX1 = auxX1+PgradX(k,l,i)
13241 gsaxsC(l,i) = auxC - auxC1/Cnorm
13243 gsaxsX(l,i) = auxX - auxX1/Cnorm
13245 c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13246 c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
13247 c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13248 c * " gradX",wsaxs*gsaxsX(l,i)
13252 time_SAXS=time_SAXS+MPI_Wtime()-time01
13255 write (iout,*) "gsaxsc"
13257 write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13265 c----------------------------------------------------------------------------
13266 subroutine e_saxsC(Esaxs_constr)
13268 include 'DIMENSIONS'
13271 include "COMMON.SETUP"
13274 include 'COMMON.SBRIDGE'
13275 include 'COMMON.CHAIN'
13276 include 'COMMON.GEO'
13277 include 'COMMON.DERIV'
13278 include 'COMMON.LOCAL'
13279 include 'COMMON.INTERACT'
13280 include 'COMMON.VAR'
13281 include 'COMMON.IOUNITS'
13282 include 'COMMON.MD'
13283 include 'COMMON.CONTROL'
13284 include 'COMMON.NAMES'
13285 include 'COMMON.TIME1'
13286 include 'COMMON.FFIELD'
13288 double precision Esaxs_constr
13289 integer i,iint,j,k,l
13290 double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13292 double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13294 double precision dk,dijCASPH,dijSCSPH,
13295 & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13296 & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13298 c SAXS restraint penalty function
13300 write(iout,*) "------- SAXS penalty function start -------"
13301 write (iout,*) "nsaxs",nsaxs
13304 print *,MyRank,"C",i,(C(j,i),j=1,3)
13307 print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13310 Esaxs_constr = 0.0d0
13312 do j=isaxs_start,isaxs_end
13321 if (itype(i).eq.ntyp1) cycle
13325 dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13327 if (itype(i).ne.10) then
13329 dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13332 sigma2CA=2.0d0/pstok**2
13333 sigma2SC=4.0d0/restok(itype(i))**2
13334 expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13335 expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13336 Pcalc = Pcalc+expCASPH+expSCSPH
13338 write(*,*) "processor i j Pcalc",
13339 & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13341 CASPHgrad = sigma2CA*expCASPH
13342 SCSPHgrad = sigma2SC*expSCSPH
13344 aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13345 PgradX(l,i) = PgradX(l,i) + aux
13346 PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13351 gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13352 gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13355 logPtot = logPtot - dlog(Pcalc)
13356 c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13357 c & " logPtot",logPtot
13360 if (nfgtasks.gt.1) then
13361 c write (iout,*) "logPtot before reduction",logPtot
13362 call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13363 & MPI_SUM,king,FG_COMM,IERR)
13365 c write (iout,*) "logPtot after reduction",logPtot
13366 call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13367 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13368 if (fg_rank.eq.king) then
13371 gsaxsC(l,i) = gsaxsC_(l,i)
13375 call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13376 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13377 if (fg_rank.eq.king) then
13380 gsaxsX(l,i) = gsaxsX_(l,i)
13386 Esaxs_constr = logPtot
13389 c----------------------------------------------------------------------------
13390 double precision function sscale2(r,r_cut,r0,rlamb)
13392 double precision r,gamm,r_cut,r0,rlamb,rr
13394 c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13395 c write (2,*) "rr",rr
13396 if(rr.lt.r_cut-rlamb) then
13398 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13399 gamm=(rr-(r_cut-rlamb))/rlamb
13400 sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13406 C-----------------------------------------------------------------------
13407 double precision function sscalgrad2(r,r_cut,r0,rlamb)
13409 double precision r,gamm,r_cut,r0,rlamb,rr
13411 if(rr.lt.r_cut-rlamb) then
13413 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13414 gamm=(rr-(r_cut-rlamb))/rlamb
13416 sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13418 sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb