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 (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6717 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6718 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6725 c-----------------------------------------------------------------------------
6726 subroutine esc(escloc)
6727 C Calculate the local energy of a side chain and its derivatives in the
6728 C corresponding virtual-bond valence angles THETA and the spherical angles
6730 implicit real*8 (a-h,o-z)
6731 include 'DIMENSIONS'
6732 include 'COMMON.GEO'
6733 include 'COMMON.LOCAL'
6734 include 'COMMON.VAR'
6735 include 'COMMON.INTERACT'
6736 include 'COMMON.DERIV'
6737 include 'COMMON.CHAIN'
6738 include 'COMMON.IOUNITS'
6739 include 'COMMON.NAMES'
6740 include 'COMMON.FFIELD'
6741 include 'COMMON.CONTROL'
6742 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6743 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6744 common /sccalc/ time11,time12,time112,theti,it,nlobit
6747 c write (iout,'(a)') 'ESC'
6748 do i=loc_start,loc_end
6750 if (it.eq.ntyp1) cycle
6751 if (it.eq.10) goto 1
6752 nlobit=nlob(iabs(it))
6753 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6754 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6755 theti=theta(i+1)-pipol
6760 if (x(2).gt.pi-delta) then
6764 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6766 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6767 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6769 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6770 & ddersc0(1),dersc(1))
6771 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6772 & ddersc0(3),dersc(3))
6774 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6776 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6777 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6778 & dersc0(2),esclocbi,dersc02)
6779 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6781 call splinthet(x(2),0.5d0*delta,ss,ssd)
6786 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6788 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6789 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6791 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6793 c write (iout,*) escloci
6794 else if (x(2).lt.delta) then
6798 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6800 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6801 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6803 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6804 & ddersc0(1),dersc(1))
6805 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6806 & ddersc0(3),dersc(3))
6808 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6810 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6811 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6812 & dersc0(2),esclocbi,dersc02)
6813 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6818 call splinthet(x(2),0.5d0*delta,ss,ssd)
6820 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6822 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6823 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6825 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6826 c write (iout,*) escloci
6828 call enesc(x,escloci,dersc,ddummy,.false.)
6831 escloc=escloc+escloci
6832 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6833 & 'escloc',i,escloci
6834 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6836 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6838 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6839 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6844 C---------------------------------------------------------------------------
6845 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6846 implicit real*8 (a-h,o-z)
6847 include 'DIMENSIONS'
6848 include 'COMMON.GEO'
6849 include 'COMMON.LOCAL'
6850 include 'COMMON.IOUNITS'
6851 common /sccalc/ time11,time12,time112,theti,it,nlobit
6852 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6853 double precision contr(maxlob,-1:1)
6855 c write (iout,*) 'it=',it,' nlobit=',nlobit
6859 if (mixed) ddersc(j)=0.0d0
6863 C Because of periodicity of the dependence of the SC energy in omega we have
6864 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6865 C To avoid underflows, first compute & store the exponents.
6873 z(k)=x(k)-censc(k,j,it)
6878 Axk=Axk+gaussc(l,k,j,it)*z(l)
6884 expfac=expfac+Ax(k,j,iii)*z(k)
6892 C As in the case of ebend, we want to avoid underflows in exponentiation and
6893 C subsequent NaNs and INFs in energy calculation.
6894 C Find the largest exponent
6898 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6902 cd print *,'it=',it,' emin=',emin
6904 C Compute the contribution to SC energy and derivatives
6909 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6910 if(adexp.ne.adexp) adexp=1.0
6913 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6915 cd print *,'j=',j,' expfac=',expfac
6916 escloc_i=escloc_i+expfac
6918 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6922 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6923 & +gaussc(k,2,j,it))*expfac
6930 dersc(1)=dersc(1)/cos(theti)**2
6931 ddersc(1)=ddersc(1)/cos(theti)**2
6934 escloci=-(dlog(escloc_i)-emin)
6936 dersc(j)=dersc(j)/escloc_i
6940 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6945 C------------------------------------------------------------------------------
6946 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6947 implicit real*8 (a-h,o-z)
6948 include 'DIMENSIONS'
6949 include 'COMMON.GEO'
6950 include 'COMMON.LOCAL'
6951 include 'COMMON.IOUNITS'
6952 common /sccalc/ time11,time12,time112,theti,it,nlobit
6953 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6954 double precision contr(maxlob)
6965 z(k)=x(k)-censc(k,j,it)
6971 Axk=Axk+gaussc(l,k,j,it)*z(l)
6977 expfac=expfac+Ax(k,j)*z(k)
6982 C As in the case of ebend, we want to avoid underflows in exponentiation and
6983 C subsequent NaNs and INFs in energy calculation.
6984 C Find the largest exponent
6987 if (emin.gt.contr(j)) emin=contr(j)
6991 C Compute the contribution to SC energy and derivatives
6995 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6996 escloc_i=escloc_i+expfac
6998 dersc(k)=dersc(k)+Ax(k,j)*expfac
7000 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7001 & +gaussc(1,2,j,it))*expfac
7005 dersc(1)=dersc(1)/cos(theti)**2
7006 dersc12=dersc12/cos(theti)**2
7007 escloci=-(dlog(escloc_i)-emin)
7009 dersc(j)=dersc(j)/escloc_i
7011 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7015 c----------------------------------------------------------------------------------
7016 subroutine esc(escloc)
7017 C Calculate the local energy of a side chain and its derivatives in the
7018 C corresponding virtual-bond valence angles THETA and the spherical angles
7019 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7020 C added by Urszula Kozlowska. 07/11/2007
7022 implicit real*8 (a-h,o-z)
7023 include 'DIMENSIONS'
7024 include 'COMMON.GEO'
7025 include 'COMMON.LOCAL'
7026 include 'COMMON.VAR'
7027 include 'COMMON.SCROT'
7028 include 'COMMON.INTERACT'
7029 include 'COMMON.DERIV'
7030 include 'COMMON.CHAIN'
7031 include 'COMMON.IOUNITS'
7032 include 'COMMON.NAMES'
7033 include 'COMMON.FFIELD'
7034 include 'COMMON.CONTROL'
7035 include 'COMMON.VECTORS'
7036 double precision x_prime(3),y_prime(3),z_prime(3)
7037 & , sumene,dsc_i,dp2_i,x(65),
7038 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7039 & de_dxx,de_dyy,de_dzz,de_dt
7040 double precision s1_t,s1_6_t,s2_t,s2_6_t
7042 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7043 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7044 & dt_dCi(3),dt_dCi1(3)
7045 common /sccalc/ time11,time12,time112,theti,it,nlobit
7048 do i=loc_start,loc_end
7049 if (itype(i).eq.ntyp1) cycle
7050 costtab(i+1) =dcos(theta(i+1))
7051 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7052 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7053 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7054 cosfac2=0.5d0/(1.0d0+costtab(i+1))
7055 cosfac=dsqrt(cosfac2)
7056 sinfac2=0.5d0/(1.0d0-costtab(i+1))
7057 sinfac=dsqrt(sinfac2)
7059 if (it.eq.10) goto 1
7061 C Compute the axes of tghe local cartesian coordinates system; store in
7062 c x_prime, y_prime and z_prime
7069 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7070 C & dc_norm(3,i+nres)
7072 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7073 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7076 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7079 c write (2,*) "x_prime",(x_prime(j),j=1,3)
7080 c write (2,*) "y_prime",(y_prime(j),j=1,3)
7081 c write (2,*) "z_prime",(z_prime(j),j=1,3)
7082 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7083 c & " xy",scalar(x_prime(1),y_prime(1)),
7084 c & " xz",scalar(x_prime(1),z_prime(1)),
7085 c & " yy",scalar(y_prime(1),y_prime(1)),
7086 c & " yz",scalar(y_prime(1),z_prime(1)),
7087 c & " zz",scalar(z_prime(1),z_prime(1))
7089 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7090 C to local coordinate system. Store in xx, yy, zz.
7096 xx = xx + x_prime(j)*dc_norm(j,i+nres)
7097 yy = yy + y_prime(j)*dc_norm(j,i+nres)
7098 zz = zz + z_prime(j)*dc_norm(j,i+nres)
7105 C Compute the energy of the ith side cbain
7107 c write (2,*) "xx",xx," yy",yy," zz",zz
7110 x(j) = sc_parmin(j,it)
7113 Cc diagnostics - remove later
7115 yy1 = dsin(alph(2))*dcos(omeg(2))
7116 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7117 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7118 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7120 C," --- ", xx_w,yy_w,zz_w
7123 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7124 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7126 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7127 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7129 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7130 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7131 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7132 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7133 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7135 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7136 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7137 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7138 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7139 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7141 dsc_i = 0.743d0+x(61)
7143 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7144 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7145 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7146 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7147 s1=(1+x(63))/(0.1d0 + dscp1)
7148 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7149 s2=(1+x(65))/(0.1d0 + dscp2)
7150 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7151 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7152 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7153 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7155 c & dscp1,dscp2,sumene
7156 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7157 escloc = escloc + sumene
7158 c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7163 C This section to check the numerical derivatives of the energy of ith side
7164 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7165 C #define DEBUG in the code to turn it on.
7167 write (2,*) "sumene =",sumene
7171 write (2,*) xx,yy,zz
7172 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7173 de_dxx_num=(sumenep-sumene)/aincr
7175 write (2,*) "xx+ sumene from enesc=",sumenep
7178 write (2,*) xx,yy,zz
7179 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7180 de_dyy_num=(sumenep-sumene)/aincr
7182 write (2,*) "yy+ sumene from enesc=",sumenep
7185 write (2,*) xx,yy,zz
7186 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7187 de_dzz_num=(sumenep-sumene)/aincr
7189 write (2,*) "zz+ sumene from enesc=",sumenep
7190 costsave=cost2tab(i+1)
7191 sintsave=sint2tab(i+1)
7192 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7193 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7194 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7195 de_dt_num=(sumenep-sumene)/aincr
7196 write (2,*) " t+ sumene from enesc=",sumenep
7197 cost2tab(i+1)=costsave
7198 sint2tab(i+1)=sintsave
7199 C End of diagnostics section.
7202 C Compute the gradient of esc
7204 c zz=zz*dsign(1.0,dfloat(itype(i)))
7205 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7206 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7207 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7208 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7209 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7210 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7211 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7212 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7213 pom1=(sumene3*sint2tab(i+1)+sumene1)
7214 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7215 pom2=(sumene4*cost2tab(i+1)+sumene2)
7216 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7217 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7218 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7219 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7221 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7222 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7223 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7225 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7226 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7227 & +(pom1+pom2)*pom_dx
7229 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7232 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7233 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7234 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7236 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7237 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7238 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7239 & +x(59)*zz**2 +x(60)*xx*zz
7240 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7241 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7242 & +(pom1-pom2)*pom_dy
7244 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7247 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7248 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7249 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7250 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7251 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7252 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7253 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7254 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7256 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7259 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7260 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7261 & +pom1*pom_dt1+pom2*pom_dt2
7263 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7268 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7269 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7270 cosfac2xx=cosfac2*xx
7271 sinfac2yy=sinfac2*yy
7273 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7275 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7277 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7278 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7279 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7280 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7281 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7282 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7283 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7284 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7285 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7286 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7290 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7291 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7292 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7293 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7296 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7297 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7298 dZZ_XYZ(k)=vbld_inv(i+nres)*
7299 & (z_prime(k)-zz*dC_norm(k,i+nres))
7301 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7302 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7306 dXX_Ctab(k,i)=dXX_Ci(k)
7307 dXX_C1tab(k,i)=dXX_Ci1(k)
7308 dYY_Ctab(k,i)=dYY_Ci(k)
7309 dYY_C1tab(k,i)=dYY_Ci1(k)
7310 dZZ_Ctab(k,i)=dZZ_Ci(k)
7311 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7312 dXX_XYZtab(k,i)=dXX_XYZ(k)
7313 dYY_XYZtab(k,i)=dYY_XYZ(k)
7314 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7318 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7319 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7320 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7321 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7322 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7324 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7325 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7326 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7327 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7328 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7329 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7330 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7331 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7333 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7334 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7336 C to check gradient call subroutine check_grad
7342 c------------------------------------------------------------------------------
7343 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7345 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7346 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7347 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7348 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7350 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7351 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7353 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7354 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7355 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7356 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7357 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7359 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7360 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7361 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7362 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7363 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7365 dsc_i = 0.743d0+x(61)
7367 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7368 & *(xx*cost2+yy*sint2))
7369 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7370 & *(xx*cost2-yy*sint2))
7371 s1=(1+x(63))/(0.1d0 + dscp1)
7372 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7373 s2=(1+x(65))/(0.1d0 + dscp2)
7374 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7375 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7376 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7381 c------------------------------------------------------------------------------
7382 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7384 C This procedure calculates two-body contact function g(rij) and its derivative:
7387 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7390 C where x=(rij-r0ij)/delta
7392 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7395 double precision rij,r0ij,eps0ij,fcont,fprimcont
7396 double precision x,x2,x4,delta
7400 if (x.lt.-1.0D0) then
7403 else if (x.le.1.0D0) then
7406 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7407 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7414 c------------------------------------------------------------------------------
7415 subroutine splinthet(theti,delta,ss,ssder)
7416 implicit real*8 (a-h,o-z)
7417 include 'DIMENSIONS'
7418 include 'COMMON.VAR'
7419 include 'COMMON.GEO'
7422 if (theti.gt.pipol) then
7423 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7425 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7430 c------------------------------------------------------------------------------
7431 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7433 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7434 double precision ksi,ksi2,ksi3,a1,a2,a3
7435 a1=fprim0*delta/(f1-f0)
7441 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7442 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7445 c------------------------------------------------------------------------------
7446 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7448 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7449 double precision ksi,ksi2,ksi3,a1,a2,a3
7454 a2=3*(f1x-f0x)-2*fprim0x*delta
7455 a3=fprim0x*delta-2*(f1x-f0x)
7456 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7459 C-----------------------------------------------------------------------------
7461 C-----------------------------------------------------------------------------
7462 subroutine etor(etors)
7463 implicit real*8 (a-h,o-z)
7464 include 'DIMENSIONS'
7465 include 'COMMON.VAR'
7466 include 'COMMON.GEO'
7467 include 'COMMON.LOCAL'
7468 include 'COMMON.TORSION'
7469 include 'COMMON.INTERACT'
7470 include 'COMMON.DERIV'
7471 include 'COMMON.CHAIN'
7472 include 'COMMON.NAMES'
7473 include 'COMMON.IOUNITS'
7474 include 'COMMON.FFIELD'
7475 include 'COMMON.TORCNSTR'
7476 include 'COMMON.CONTROL'
7478 C Set lprn=.true. for debugging
7482 do i=iphi_start,iphi_end
7484 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7485 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7486 itori=itortyp(itype(i-2))
7487 itori1=itortyp(itype(i-1))
7490 C Proline-Proline pair is a special case...
7491 if (itori.eq.3 .and. itori1.eq.3) then
7492 if (phii.gt.-dwapi3) then
7494 fac=1.0D0/(1.0D0-cosphi)
7495 etorsi=v1(1,3,3)*fac
7496 etorsi=etorsi+etorsi
7497 etors=etors+etorsi-v1(1,3,3)
7498 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7499 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7502 v1ij=v1(j+1,itori,itori1)
7503 v2ij=v2(j+1,itori,itori1)
7506 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7507 if (energy_dec) etors_ii=etors_ii+
7508 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7509 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7513 v1ij=v1(j,itori,itori1)
7514 v2ij=v2(j,itori,itori1)
7517 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7518 if (energy_dec) etors_ii=etors_ii+
7519 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7520 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7523 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7526 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7527 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7528 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7529 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7530 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7534 c------------------------------------------------------------------------------
7535 subroutine etor_d(etors_d)
7539 c----------------------------------------------------------------------------
7540 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7541 subroutine e_modeller(ehomology_constr)
7542 ehomology_constr=0.0d0
7543 write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7546 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7548 c------------------------------------------------------------------------------
7549 subroutine etor_d(etors_d)
7553 c----------------------------------------------------------------------------
7555 subroutine etor(etors)
7556 implicit real*8 (a-h,o-z)
7557 include 'DIMENSIONS'
7558 include 'COMMON.VAR'
7559 include 'COMMON.GEO'
7560 include 'COMMON.LOCAL'
7561 include 'COMMON.TORSION'
7562 include 'COMMON.INTERACT'
7563 include 'COMMON.DERIV'
7564 include 'COMMON.CHAIN'
7565 include 'COMMON.NAMES'
7566 include 'COMMON.IOUNITS'
7567 include 'COMMON.FFIELD'
7568 include 'COMMON.TORCNSTR'
7569 include 'COMMON.CONTROL'
7571 C Set lprn=.true. for debugging
7575 do i=iphi_start,iphi_end
7576 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7577 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7578 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7579 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7580 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7581 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7582 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7583 C For introducing the NH3+ and COO- group please check the etor_d for reference
7586 if (iabs(itype(i)).eq.20) then
7591 itori=itortyp(itype(i-2))
7592 itori1=itortyp(itype(i-1))
7595 C Regular cosine and sine terms
7596 do j=1,nterm(itori,itori1,iblock)
7597 v1ij=v1(j,itori,itori1,iblock)
7598 v2ij=v2(j,itori,itori1,iblock)
7601 etors=etors+v1ij*cosphi+v2ij*sinphi
7602 if (energy_dec) etors_ii=etors_ii+
7603 & v1ij*cosphi+v2ij*sinphi
7604 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7608 C E = SUM ----------------------------------- - v1
7609 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7611 cosphi=dcos(0.5d0*phii)
7612 sinphi=dsin(0.5d0*phii)
7613 do j=1,nlor(itori,itori1,iblock)
7614 vl1ij=vlor1(j,itori,itori1)
7615 vl2ij=vlor2(j,itori,itori1)
7616 vl3ij=vlor3(j,itori,itori1)
7617 pom=vl2ij*cosphi+vl3ij*sinphi
7618 pom1=1.0d0/(pom*pom+1.0d0)
7619 etors=etors+vl1ij*pom1
7620 if (energy_dec) etors_ii=etors_ii+
7623 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7625 C Subtract the constant term
7626 etors=etors-v0(itori,itori1,iblock)
7627 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7628 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7630 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7631 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7632 & (v1(j,itori,itori1,iblock),j=1,6),
7633 & (v2(j,itori,itori1,iblock),j=1,6)
7634 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7635 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7639 c----------------------------------------------------------------------------
7640 subroutine etor_d(etors_d)
7641 C 6/23/01 Compute double torsional energy
7642 implicit real*8 (a-h,o-z)
7643 include 'DIMENSIONS'
7644 include 'COMMON.VAR'
7645 include 'COMMON.GEO'
7646 include 'COMMON.LOCAL'
7647 include 'COMMON.TORSION'
7648 include 'COMMON.INTERACT'
7649 include 'COMMON.DERIV'
7650 include 'COMMON.CHAIN'
7651 include 'COMMON.NAMES'
7652 include 'COMMON.IOUNITS'
7653 include 'COMMON.FFIELD'
7654 include 'COMMON.TORCNSTR'
7656 C Set lprn=.true. for debugging
7660 c write(iout,*) "a tu??"
7661 do i=iphid_start,iphid_end
7662 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7663 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7664 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7665 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7666 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7667 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7668 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7669 & (itype(i+1).eq.ntyp1)) cycle
7670 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7671 itori=itortyp(itype(i-2))
7672 itori1=itortyp(itype(i-1))
7673 itori2=itortyp(itype(i))
7679 if (iabs(itype(i+1)).eq.20) iblock=2
7680 C Iblock=2 Proline type
7681 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7682 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7683 C if (itype(i+1).eq.ntyp1) iblock=3
7684 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7685 C IS or IS NOT need for this
7686 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7687 C is (itype(i-3).eq.ntyp1) ntblock=2
7688 C ntblock is N-terminal blocking group
7690 C Regular cosine and sine terms
7691 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7692 C Example of changes for NH3+ blocking group
7693 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7694 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7695 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7696 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7697 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7698 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7699 cosphi1=dcos(j*phii)
7700 sinphi1=dsin(j*phii)
7701 cosphi2=dcos(j*phii1)
7702 sinphi2=dsin(j*phii1)
7703 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7704 & v2cij*cosphi2+v2sij*sinphi2
7705 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7706 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7708 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7710 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7711 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7712 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7713 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7714 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7715 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7716 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7717 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7718 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7719 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7720 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7721 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7722 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7723 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7726 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7727 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7732 C----------------------------------------------------------------------------------
7733 C The rigorous attempt to derive energy function
7734 subroutine etor_kcc(etors)
7735 implicit real*8 (a-h,o-z)
7736 include 'DIMENSIONS'
7737 include 'COMMON.VAR'
7738 include 'COMMON.GEO'
7739 include 'COMMON.LOCAL'
7740 include 'COMMON.TORSION'
7741 include 'COMMON.INTERACT'
7742 include 'COMMON.DERIV'
7743 include 'COMMON.CHAIN'
7744 include 'COMMON.NAMES'
7745 include 'COMMON.IOUNITS'
7746 include 'COMMON.FFIELD'
7747 include 'COMMON.TORCNSTR'
7748 include 'COMMON.CONTROL'
7749 double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7751 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7752 C Set lprn=.true. for debugging
7755 C print *,"wchodze kcc"
7756 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7758 do i=iphi_start,iphi_end
7759 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7760 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7761 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7762 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7763 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7764 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7765 itori=itortyp(itype(i-2))
7766 itori1=itortyp(itype(i-1))
7771 C to avoid multiple devision by 2
7772 c theti22=0.5d0*theta(i)
7773 C theta 12 is the theta_1 /2
7774 C theta 22 is theta_2 /2
7775 c theti12=0.5d0*theta(i-1)
7776 C and appropriate sinus function
7777 sinthet1=dsin(theta(i-1))
7778 sinthet2=dsin(theta(i))
7779 costhet1=dcos(theta(i-1))
7780 costhet2=dcos(theta(i))
7781 C to speed up lets store its mutliplication
7782 sint1t2=sinthet2*sinthet1
7784 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7785 C +d_n*sin(n*gamma)) *
7786 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7787 C we have two sum 1) Non-Chebyshev which is with n and gamma
7788 nval=nterm_kcc_Tb(itori,itori1)
7794 c1(j)=c1(j-1)*costhet1
7795 c2(j)=c2(j-1)*costhet2
7798 do j=1,nterm_kcc(itori,itori1)
7802 sint1t2n=sint1t2n*sint1t2
7808 sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7809 gradvalct1=gradvalct1+
7810 & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7811 gradvalct2=gradvalct2+
7812 & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7815 gradvalct1=-gradvalct1*sinthet1
7816 gradvalct2=-gradvalct2*sinthet2
7822 sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7823 gradvalst1=gradvalst1+
7824 & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7825 gradvalst2=gradvalst2+
7826 & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7829 gradvalst1=-gradvalst1*sinthet1
7830 gradvalst2=-gradvalst2*sinthet2
7831 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7832 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7833 C glocig is the gradient local i site in gamma
7834 glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7835 C now gradient over theta_1
7836 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7837 & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7838 glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7839 & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7842 C derivative over gamma
7843 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7844 C derivative over theta1
7845 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7846 C now derivative over theta2
7847 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7849 write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7850 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7851 write (iout,*) "c1",(c1(k),k=0,nval),
7852 & " c2",(c2(k),k=0,nval)
7857 c---------------------------------------------------------------------------------------------
7858 subroutine etor_constr(edihcnstr)
7859 implicit real*8 (a-h,o-z)
7860 include 'DIMENSIONS'
7861 include 'COMMON.VAR'
7862 include 'COMMON.GEO'
7863 include 'COMMON.LOCAL'
7864 include 'COMMON.TORSION'
7865 include 'COMMON.INTERACT'
7866 include 'COMMON.DERIV'
7867 include 'COMMON.CHAIN'
7868 include 'COMMON.NAMES'
7869 include 'COMMON.IOUNITS'
7870 include 'COMMON.FFIELD'
7871 include 'COMMON.TORCNSTR'
7872 include 'COMMON.BOUNDS'
7873 include 'COMMON.CONTROL'
7874 ! 6/20/98 - dihedral angle constraints
7876 c do i=1,ndih_constr
7877 if (raw_psipred) then
7878 do i=idihconstr_start,idihconstr_end
7879 itori=idih_constr(i)
7881 gaudih_i=vpsipred(1,i)
7885 cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7886 dexpcos_i=dexp(-cos_i*cos_i)
7887 gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7888 gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7889 & *cos_i*dexpcos_i/s**2
7891 edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7892 gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7894 & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7895 & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7896 & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7897 & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7898 & -wdihc*dlog(gaudih_i)
7902 do i=idihconstr_start,idihconstr_end
7903 itori=idih_constr(i)
7905 difi=pinorm(phii-phi0(i))
7906 if (difi.gt.drange(i)) then
7908 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7909 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7910 else if (difi.lt.-drange(i)) then
7912 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7913 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7923 c----------------------------------------------------------------------------
7924 c MODELLER restraint function
7925 subroutine e_modeller(ehomology_constr)
7926 implicit real*8 (a-h,o-z)
7927 include 'DIMENSIONS'
7929 integer nnn, i, j, k, ki, irec, l
7930 integer katy, odleglosci, test7
7931 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7933 real*8 distance(max_template),distancek(max_template),
7934 & min_odl,godl(max_template),dih_diff(max_template)
7937 c FP - 30/10/2014 Temporary specifications for homology restraints
7939 double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7941 double precision, dimension (maxres) :: guscdiff,usc_diff
7942 double precision, dimension (max_template) ::
7943 & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7947 include 'COMMON.SBRIDGE'
7948 include 'COMMON.CHAIN'
7949 include 'COMMON.GEO'
7950 include 'COMMON.DERIV'
7951 include 'COMMON.LOCAL'
7952 include 'COMMON.INTERACT'
7953 include 'COMMON.VAR'
7954 include 'COMMON.IOUNITS'
7956 include 'COMMON.CONTROL'
7958 c From subroutine Econstr_back
7960 include 'COMMON.NAMES'
7961 include 'COMMON.TIME1'
7966 distancek(i)=9999999.9
7972 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7974 C AL 5/2/14 - Introduce list of restraints
7975 c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7977 write(iout,*) "------- dist restrs start -------"
7979 do ii = link_start_homo,link_end_homo
7983 c write (iout,*) "dij(",i,j,") =",dij
7985 do k=1,constr_homology
7986 c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7987 if(.not.l_homo(k,ii)) then
7991 distance(k)=odl(k,ii)-dij
7992 c write (iout,*) "distance(",k,") =",distance(k)
7994 c For Gaussian-type Urestr
7996 distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7997 c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7998 c write (iout,*) "distancek(",k,") =",distancek(k)
7999 c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8001 c For Lorentzian-type Urestr
8003 if (waga_dist.lt.0.0d0) then
8004 sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8005 distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8006 & (distance(k)**2+sigma_odlir(k,ii)**2))
8010 c min_odl=minval(distancek)
8011 do kk=1,constr_homology
8012 if(l_homo(kk,ii)) then
8013 min_odl=distancek(kk)
8017 do kk=1,constr_homology
8018 if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8019 & min_odl=distancek(kk)
8022 c write (iout,* )"min_odl",min_odl
8024 write (iout,*) "ij dij",i,j,dij
8025 write (iout,*) "distance",(distance(k),k=1,constr_homology)
8026 write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8027 write (iout,* )"min_odl",min_odl
8032 if (waga_dist.ge.0.0d0) then
8038 do k=1,constr_homology
8039 c Nie wiem po co to liczycie jeszcze raz!
8040 c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8041 c & (2*(sigma_odl(i,j,k))**2))
8042 if(.not.l_homo(k,ii)) cycle
8043 if (waga_dist.ge.0.0d0) then
8045 c For Gaussian-type Urestr
8047 godl(k)=dexp(-distancek(k)+min_odl)
8048 odleg2=odleg2+godl(k)
8050 c For Lorentzian-type Urestr
8053 odleg2=odleg2+distancek(k)
8056 ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8057 ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8058 ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8059 ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8062 c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8063 c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8065 write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8066 write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8068 if (waga_dist.ge.0.0d0) then
8070 c For Gaussian-type Urestr
8072 odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8074 c For Lorentzian-type Urestr
8077 odleg=odleg+odleg2/constr_homology
8080 c write (iout,*) "odleg",odleg ! sum of -ln-s
8083 c For Gaussian-type Urestr
8085 if (waga_dist.ge.0.0d0) sum_godl=odleg2
8087 do k=1,constr_homology
8088 c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8089 c & *waga_dist)+min_odl
8090 c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8092 if(.not.l_homo(k,ii)) cycle
8093 if (waga_dist.ge.0.0d0) then
8094 c For Gaussian-type Urestr
8096 sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8098 c For Lorentzian-type Urestr
8101 sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8102 & sigma_odlir(k,ii)**2)**2)
8104 sum_sgodl=sum_sgodl+sgodl
8106 c sgodl2=sgodl2+sgodl
8107 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8108 c write(iout,*) "constr_homology=",constr_homology
8109 c write(iout,*) i, j, k, "TEST K"
8111 if (waga_dist.ge.0.0d0) then
8113 c For Gaussian-type Urestr
8115 grad_odl3=waga_homology(iset)*waga_dist
8116 & *sum_sgodl/(sum_godl*dij)
8118 c For Lorentzian-type Urestr
8121 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8122 c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8123 grad_odl3=-waga_homology(iset)*waga_dist*
8124 & sum_sgodl/(constr_homology*dij)
8127 c grad_odl3=sum_sgodl/(sum_godl*dij)
8130 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8131 c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8132 c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8134 ccc write(iout,*) godl, sgodl, grad_odl3
8136 c grad_odl=grad_odl+grad_odl3
8139 ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8140 ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8141 ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8142 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8143 ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8144 ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8145 ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8146 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8147 c if (i.eq.25.and.j.eq.27) then
8148 c write(iout,*) "jik",jik,"i",i,"j",j
8149 c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8150 c write(iout,*) "grad_odl3",grad_odl3
8151 c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8152 c write(iout,*) "ggodl",ggodl
8153 c write(iout,*) "ghpbc(",jik,i,")",
8154 c & ghpbc(jik,i),"ghpbc(",jik,j,")",
8158 ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8159 ccc & dLOG(odleg2),"-odleg=", -odleg
8161 enddo ! ii-loop for dist
8163 write(iout,*) "------- dist restrs end -------"
8164 c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8165 c & waga_d.eq.1.0d0) call sum_gradient
8167 c Pseudo-energy and gradient from dihedral-angle restraints from
8168 c homology templates
8169 c write (iout,*) "End of distance loop"
8172 c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8174 write(iout,*) "------- dih restrs start -------"
8175 do i=idihconstr_start_homo,idihconstr_end_homo
8176 write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8179 do i=idihconstr_start_homo,idihconstr_end_homo
8181 c betai=beta(i,i+1,i+2,i+3)
8183 c write (iout,*) "betai =",betai
8184 do k=1,constr_homology
8185 dih_diff(k)=pinorm(dih(k,i)-betai)
8186 cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8187 cd & ,sigma_dih(k,i)
8188 c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8189 c & -(6.28318-dih_diff(i,k))
8190 c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8191 c & 6.28318+dih_diff(i,k)
8193 kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8195 kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8197 c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8200 c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8203 c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8204 c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8206 write (iout,*) "i",i," betai",betai," kat2",kat2
8207 write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8209 if (kat2.le.1.0d-14) cycle
8210 kat=kat-dLOG(kat2/constr_homology)
8211 c write (iout,*) "kat",kat ! sum of -ln-s
8213 ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8214 ccc & dLOG(kat2), "-kat=", -kat
8216 c ----------------------------------------------------------------------
8218 c ----------------------------------------------------------------------
8222 do k=1,constr_homology
8224 sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
8226 sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd
8228 c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8229 sum_sgdih=sum_sgdih+sgdih
8231 c grad_dih3=sum_sgdih/sum_gdih
8232 grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8234 c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8235 ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8236 ccc & gloc(nphi+i-3,icg)
8237 gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8239 c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8241 ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8242 ccc & gloc(nphi+i-3,icg)
8244 enddo ! i-loop for dih
8246 write(iout,*) "------- dih restrs end -------"
8249 c Pseudo-energy and gradient for theta angle restraints from
8250 c homology templates
8251 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8255 c For constr_homology reference structures (FP)
8257 c Uconst_back_tot=0.0d0
8260 c Econstr_back legacy
8262 c do i=ithet_start,ithet_end
8265 c do i=loc_start,loc_end
8268 duscdiffx(j,i)=0.0d0
8273 c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8274 c write (iout,*) "waga_theta",waga_theta
8275 if (waga_theta.gt.0.0d0) then
8277 write (iout,*) "usampl",usampl
8278 write(iout,*) "------- theta restrs start -------"
8279 c do i=ithet_start,ithet_end
8280 c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8283 c write (iout,*) "maxres",maxres,"nres",nres
8285 do i=ithet_start,ithet_end
8288 c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8290 c Deviation of theta angles wrt constr_homology ref structures
8292 utheta_i=0.0d0 ! argument of Gaussian for single k
8293 gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8294 c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8295 c over residues in a fragment
8296 c write (iout,*) "theta(",i,")=",theta(i)
8297 do k=1,constr_homology
8299 c dtheta_i=theta(j)-thetaref(j,iref)
8300 c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8301 theta_diff(k)=thetatpl(k,i)-theta(i)
8302 cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8303 cd & ,sigma_theta(k,i)
8306 utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8307 c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8308 gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8309 gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk)
8310 c Gradient for single Gaussian restraint in subr Econstr_back
8311 c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8314 c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8315 c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8318 c Gradient for multiple Gaussian restraint
8319 sum_gtheta=gutheta_i
8321 do k=1,constr_homology
8322 c New generalized expr for multiple Gaussian from Econstr_back
8323 sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8325 c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8326 sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8328 c Final value of gradient using same var as in Econstr_back
8329 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8330 & +sum_sgtheta/sum_gtheta*waga_theta
8331 & *waga_homology(iset)
8332 c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8333 c & *waga_homology(iset)
8334 c dutheta(i)=sum_sgtheta/sum_gtheta
8336 c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8337 Eval=Eval-dLOG(gutheta_i/constr_homology)
8338 c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8339 c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8340 c Uconst_back=Uconst_back+utheta(i)
8341 enddo ! (i-loop for theta)
8343 write(iout,*) "------- theta restrs end -------"
8347 c Deviation of local SC geometry
8349 c Separation of two i-loops (instructed by AL - 11/3/2014)
8351 c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8352 c write (iout,*) "waga_d",waga_d
8355 write(iout,*) "------- SC restrs start -------"
8356 write (iout,*) "Initial duscdiff,duscdiffx"
8357 do i=loc_start,loc_end
8358 write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8359 & (duscdiffx(jik,i),jik=1,3)
8362 do i=loc_start,loc_end
8363 usc_diff_i=0.0d0 ! argument of Gaussian for single k
8364 guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8365 c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8366 c write(iout,*) "xxtab, yytab, zztab"
8367 c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8368 do k=1,constr_homology
8370 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8371 c Original sign inverted for calc of gradients (s. Econstr_back)
8372 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8373 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8374 c write(iout,*) "dxx, dyy, dzz"
8375 cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8377 usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
8378 c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8379 c uscdiffk(k)=usc_diff(i)
8380 guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8381 c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8382 c & " guscdiff2",guscdiff2(k)
8383 guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk)
8384 c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8385 c & xxref(j),yyref(j),zzref(j)
8390 c Generalized expression for multiple Gaussian acc to that for a single
8391 c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8393 c Original implementation
8394 c sum_guscdiff=guscdiff(i)
8396 c sum_sguscdiff=0.0d0
8397 c do k=1,constr_homology
8398 c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8399 c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8400 c sum_sguscdiff=sum_sguscdiff+sguscdiff
8403 c Implementation of new expressions for gradient (Jan. 2015)
8405 c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8406 do k=1,constr_homology
8408 c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8409 c before. Now the drivatives should be correct
8411 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8412 c Original sign inverted for calc of gradients (s. Econstr_back)
8413 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8414 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8416 c New implementation
8418 sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8419 & sigma_d(k,i) ! for the grad wrt r'
8420 c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8423 c New implementation
8424 sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8426 duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8427 & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8428 & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8429 duscdiff(jik,i)=duscdiff(jik,i)+
8430 & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8431 & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8432 duscdiffx(jik,i)=duscdiffx(jik,i)+
8433 & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8434 & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8437 write(iout,*) "jik",jik,"i",i
8438 write(iout,*) "dxx, dyy, dzz"
8439 write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8440 write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8441 c write(iout,*) "sum_sguscdiff",sum_sguscdiff
8442 cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8443 c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8444 c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8445 c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8446 c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8447 c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8448 c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8449 c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8450 c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8451 c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8452 c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8453 c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8459 c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
8460 c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8462 c write (iout,*) i," uscdiff",uscdiff(i)
8464 c Put together deviations from local geometry
8466 c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8467 c & wfrag_back(3,i,iset)*uscdiff(i)
8468 Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8469 c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8470 c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8471 c Uconst_back=Uconst_back+usc_diff(i)
8473 c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8475 c New implment: multiplied by sum_sguscdiff
8478 enddo ! (i-loop for dscdiff)
8483 write(iout,*) "------- SC restrs end -------"
8484 write (iout,*) "------ After SC loop in e_modeller ------"
8485 do i=loc_start,loc_end
8486 write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8487 write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8489 if (waga_theta.eq.1.0d0) then
8490 write (iout,*) "in e_modeller after SC restr end: dutheta"
8491 do i=ithet_start,ithet_end
8492 write (iout,*) i,dutheta(i)
8495 if (waga_d.eq.1.0d0) then
8496 write (iout,*) "e_modeller after SC loop: duscdiff/x"
8498 write (iout,*) i,(duscdiff(j,i),j=1,3)
8499 write (iout,*) i,(duscdiffx(j,i),j=1,3)
8504 c Total energy from homology restraints
8506 write (iout,*) "odleg",odleg," kat",kat
8509 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8511 c ehomology_constr=odleg+kat
8513 c For Lorentzian-type Urestr
8516 if (waga_dist.ge.0.0d0) then
8518 c For Gaussian-type Urestr
8520 ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8521 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8522 c write (iout,*) "ehomology_constr=",ehomology_constr
8525 c For Lorentzian-type Urestr
8527 ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8528 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8529 c write (iout,*) "ehomology_constr=",ehomology_constr
8532 write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8533 & "Eval",waga_theta,eval,
8534 & "Erot",waga_d,Erot
8535 write (iout,*) "ehomology_constr",ehomology_constr
8541 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8542 747 format(a12,i4,i4,i4,f8.3,f8.3)
8543 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8544 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8545 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8546 & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8548 c----------------------------------------------------------------------------
8549 C The rigorous attempt to derive energy function
8550 subroutine ebend_kcc(etheta)
8552 implicit real*8 (a-h,o-z)
8553 include 'DIMENSIONS'
8554 include 'COMMON.VAR'
8555 include 'COMMON.GEO'
8556 include 'COMMON.LOCAL'
8557 include 'COMMON.TORSION'
8558 include 'COMMON.INTERACT'
8559 include 'COMMON.DERIV'
8560 include 'COMMON.CHAIN'
8561 include 'COMMON.NAMES'
8562 include 'COMMON.IOUNITS'
8563 include 'COMMON.FFIELD'
8564 include 'COMMON.TORCNSTR'
8565 include 'COMMON.CONTROL'
8567 double precision thybt1(maxang_kcc)
8568 C Set lprn=.true. for debugging
8571 C print *,"wchodze kcc"
8572 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8574 do i=ithet_start,ithet_end
8575 c print *,i,itype(i-1),itype(i),itype(i-2)
8576 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8577 & .or.itype(i).eq.ntyp1) cycle
8578 iti=iabs(itortyp(itype(i-1)))
8579 sinthet=dsin(theta(i))
8580 costhet=dcos(theta(i))
8581 do j=1,nbend_kcc_Tb(iti)
8582 thybt1(j)=v1bend_chyb(j,iti)
8584 sumth1thyb=v1bend_chyb(0,iti)+
8585 & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8586 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8588 ihelp=nbend_kcc_Tb(iti)-1
8589 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8590 etheta=etheta+sumth1thyb
8591 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8592 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8596 c-------------------------------------------------------------------------------------
8597 subroutine etheta_constr(ethetacnstr)
8599 implicit real*8 (a-h,o-z)
8600 include 'DIMENSIONS'
8601 include 'COMMON.VAR'
8602 include 'COMMON.GEO'
8603 include 'COMMON.LOCAL'
8604 include 'COMMON.TORSION'
8605 include 'COMMON.INTERACT'
8606 include 'COMMON.DERIV'
8607 include 'COMMON.CHAIN'
8608 include 'COMMON.NAMES'
8609 include 'COMMON.IOUNITS'
8610 include 'COMMON.FFIELD'
8611 include 'COMMON.TORCNSTR'
8612 include 'COMMON.CONTROL'
8614 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8615 do i=ithetaconstr_start,ithetaconstr_end
8616 itheta=itheta_constr(i)
8617 thetiii=theta(itheta)
8618 difi=pinorm(thetiii-theta_constr0(i))
8619 if (difi.gt.theta_drange(i)) then
8620 difi=difi-theta_drange(i)
8621 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8622 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8623 & +for_thet_constr(i)*difi**3
8624 else if (difi.lt.-drange(i)) then
8626 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8627 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8628 & +for_thet_constr(i)*difi**3
8632 if (energy_dec) then
8633 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8634 & i,itheta,rad2deg*thetiii,
8635 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8636 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8637 & gloc(itheta+nphi-2,icg)
8642 c------------------------------------------------------------------------------
8643 subroutine eback_sc_corr(esccor)
8644 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8645 c conformational states; temporarily implemented as differences
8646 c between UNRES torsional potentials (dependent on three types of
8647 c residues) and the torsional potentials dependent on all 20 types
8648 c of residues computed from AM1 energy surfaces of terminally-blocked
8649 c amino-acid residues.
8650 implicit real*8 (a-h,o-z)
8651 include 'DIMENSIONS'
8652 include 'COMMON.VAR'
8653 include 'COMMON.GEO'
8654 include 'COMMON.LOCAL'
8655 include 'COMMON.TORSION'
8656 include 'COMMON.SCCOR'
8657 include 'COMMON.INTERACT'
8658 include 'COMMON.DERIV'
8659 include 'COMMON.CHAIN'
8660 include 'COMMON.NAMES'
8661 include 'COMMON.IOUNITS'
8662 include 'COMMON.FFIELD'
8663 include 'COMMON.CONTROL'
8665 C Set lprn=.true. for debugging
8668 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8670 do i=itau_start,itau_end
8671 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8673 isccori=isccortyp(itype(i-2))
8674 isccori1=isccortyp(itype(i-1))
8675 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8677 do intertyp=1,3 !intertyp
8678 cc Added 09 May 2012 (Adasko)
8679 cc Intertyp means interaction type of backbone mainchain correlation:
8680 c 1 = SC...Ca...Ca...Ca
8681 c 2 = Ca...Ca...Ca...SC
8682 c 3 = SC...Ca...Ca...SCi
8684 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8685 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8686 & (itype(i-1).eq.ntyp1)))
8687 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8688 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8689 & .or.(itype(i).eq.ntyp1)))
8690 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8691 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8692 & (itype(i-3).eq.ntyp1)))) cycle
8693 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8694 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8696 do j=1,nterm_sccor(isccori,isccori1)
8697 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8698 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8699 cosphi=dcos(j*tauangle(intertyp,i))
8700 sinphi=dsin(j*tauangle(intertyp,i))
8701 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8702 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8704 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8705 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8707 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8708 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8709 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8710 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8711 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8717 c----------------------------------------------------------------------------
8718 subroutine multibody(ecorr)
8719 C This subroutine calculates multi-body contributions to energy following
8720 C the idea of Skolnick et al. If side chains I and J make a contact and
8721 C at the same time side chains I+1 and J+1 make a contact, an extra
8722 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8723 implicit real*8 (a-h,o-z)
8724 include 'DIMENSIONS'
8725 include 'COMMON.IOUNITS'
8726 include 'COMMON.DERIV'
8727 include 'COMMON.INTERACT'
8728 include 'COMMON.CONTACTS'
8729 double precision gx(3),gx1(3)
8732 C Set lprn=.true. for debugging
8736 write (iout,'(a)') 'Contact function values:'
8738 write (iout,'(i2,20(1x,i2,f10.5))')
8739 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8754 num_conti=num_cont(i)
8755 num_conti1=num_cont(i1)
8760 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8761 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8762 cd & ' ishift=',ishift
8763 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8764 C The system gains extra energy.
8765 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8766 endif ! j1==j+-ishift
8775 c------------------------------------------------------------------------------
8776 double precision function esccorr(i,j,k,l,jj,kk)
8777 implicit real*8 (a-h,o-z)
8778 include 'DIMENSIONS'
8779 include 'COMMON.IOUNITS'
8780 include 'COMMON.DERIV'
8781 include 'COMMON.INTERACT'
8782 include 'COMMON.CONTACTS'
8783 include 'COMMON.SHIELD'
8784 double precision gx(3),gx1(3)
8789 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8790 C Calculate the multi-body contribution to energy.
8791 C Calculate multi-body contributions to the gradient.
8792 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8793 cd & k,l,(gacont(m,kk,k),m=1,3)
8795 gx(m) =ekl*gacont(m,jj,i)
8796 gx1(m)=eij*gacont(m,kk,k)
8797 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8798 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8799 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8800 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8804 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8809 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8815 c------------------------------------------------------------------------------
8816 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8817 C This subroutine calculates multi-body contributions to hydrogen-bonding
8818 implicit real*8 (a-h,o-z)
8819 include 'DIMENSIONS'
8820 include 'COMMON.IOUNITS'
8823 parameter (max_cont=maxconts)
8824 parameter (max_dim=26)
8825 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8826 double precision zapas(max_dim,maxconts,max_fg_procs),
8827 & zapas_recv(max_dim,maxconts,max_fg_procs)
8828 common /przechowalnia/ zapas
8829 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8830 & status_array(MPI_STATUS_SIZE,maxconts*2)
8832 include 'COMMON.SETUP'
8833 include 'COMMON.FFIELD'
8834 include 'COMMON.DERIV'
8835 include 'COMMON.INTERACT'
8836 include 'COMMON.CONTACTS'
8837 include 'COMMON.CONTROL'
8838 include 'COMMON.LOCAL'
8839 double precision gx(3),gx1(3),time00
8842 C Set lprn=.true. for debugging
8847 if (nfgtasks.le.1) goto 30
8849 write (iout,'(a)') 'Contact function values before RECEIVE:'
8851 write (iout,'(2i3,50(1x,i2,f5.2))')
8852 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8853 & j=1,num_cont_hb(i))
8857 do i=1,ntask_cont_from
8860 do i=1,ntask_cont_to
8863 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8865 C Make the list of contacts to send to send to other procesors
8866 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8868 do i=iturn3_start,iturn3_end
8869 c write (iout,*) "make contact list turn3",i," num_cont",
8871 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8873 do i=iturn4_start,iturn4_end
8874 c write (iout,*) "make contact list turn4",i," num_cont",
8876 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8880 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8882 do j=1,num_cont_hb(i)
8885 iproc=iint_sent_local(k,jjc,ii)
8886 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8887 if (iproc.gt.0) then
8888 ncont_sent(iproc)=ncont_sent(iproc)+1
8889 nn=ncont_sent(iproc)
8891 zapas(2,nn,iproc)=jjc
8892 zapas(3,nn,iproc)=facont_hb(j,i)
8893 zapas(4,nn,iproc)=ees0p(j,i)
8894 zapas(5,nn,iproc)=ees0m(j,i)
8895 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8896 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8897 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8898 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8899 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8900 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8901 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8902 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8903 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8904 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8905 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8906 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8907 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8908 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8909 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8910 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8911 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8912 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8913 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8914 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8915 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8922 & "Numbers of contacts to be sent to other processors",
8923 & (ncont_sent(i),i=1,ntask_cont_to)
8924 write (iout,*) "Contacts sent"
8925 do ii=1,ntask_cont_to
8927 iproc=itask_cont_to(ii)
8928 write (iout,*) nn," contacts to processor",iproc,
8929 & " of CONT_TO_COMM group"
8931 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8939 CorrelID1=nfgtasks+fg_rank+1
8941 C Receive the numbers of needed contacts from other processors
8942 do ii=1,ntask_cont_from
8943 iproc=itask_cont_from(ii)
8945 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8946 & FG_COMM,req(ireq),IERR)
8948 c write (iout,*) "IRECV ended"
8950 C Send the number of contacts needed by other processors
8951 do ii=1,ntask_cont_to
8952 iproc=itask_cont_to(ii)
8954 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8955 & FG_COMM,req(ireq),IERR)
8957 c write (iout,*) "ISEND ended"
8958 c write (iout,*) "number of requests (nn)",ireq
8961 & call MPI_Waitall(ireq,req,status_array,ierr)
8963 c & "Numbers of contacts to be received from other processors",
8964 c & (ncont_recv(i),i=1,ntask_cont_from)
8968 do ii=1,ntask_cont_from
8969 iproc=itask_cont_from(ii)
8971 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8972 c & " of CONT_TO_COMM group"
8976 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8977 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8978 c write (iout,*) "ireq,req",ireq,req(ireq)
8981 C Send the contacts to processors that need them
8982 do ii=1,ntask_cont_to
8983 iproc=itask_cont_to(ii)
8985 c write (iout,*) nn," contacts to processor",iproc,
8986 c & " of CONT_TO_COMM group"
8989 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8990 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8991 c write (iout,*) "ireq,req",ireq,req(ireq)
8993 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8997 c write (iout,*) "number of requests (contacts)",ireq
8998 c write (iout,*) "req",(req(i),i=1,4)
9001 & call MPI_Waitall(ireq,req,status_array,ierr)
9002 do iii=1,ntask_cont_from
9003 iproc=itask_cont_from(iii)
9006 write (iout,*) "Received",nn," contacts from processor",iproc,
9007 & " of CONT_FROM_COMM group"
9010 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9015 ii=zapas_recv(1,i,iii)
9016 c Flag the received contacts to prevent double-counting
9017 jj=-zapas_recv(2,i,iii)
9018 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9020 nnn=num_cont_hb(ii)+1
9023 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9024 ees0p(nnn,ii)=zapas_recv(4,i,iii)
9025 ees0m(nnn,ii)=zapas_recv(5,i,iii)
9026 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9027 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9028 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9029 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9030 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9031 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9032 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9033 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9034 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9035 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9036 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9037 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9038 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9039 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9040 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9041 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9042 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9043 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9044 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9045 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9046 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9050 write (iout,'(a)') 'Contact function values after receive:'
9052 write (iout,'(2i3,50(1x,i3,f5.2))')
9053 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9054 & j=1,num_cont_hb(i))
9061 write (iout,'(a)') 'Contact function values:'
9063 write (iout,'(2i3,50(1x,i3,f5.2))')
9064 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9065 & j=1,num_cont_hb(i))
9070 C Remove the loop below after debugging !!!
9077 C Calculate the local-electrostatic correlation terms
9078 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9080 num_conti=num_cont_hb(i)
9081 num_conti1=num_cont_hb(i+1)
9088 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9089 c & ' jj=',jj,' kk=',kk
9091 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9092 & .or. j.lt.0 .and. j1.gt.0) .and.
9093 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9094 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9095 C The system gains extra energy.
9096 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9097 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9098 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9100 else if (j1.eq.j) then
9101 C Contacts I-J and I-(J+1) occur simultaneously.
9102 C The system loses extra energy.
9103 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9108 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9109 c & ' jj=',jj,' kk=',kk
9111 C Contacts I-J and (I+1)-J occur simultaneously.
9112 C The system loses extra energy.
9113 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9120 c------------------------------------------------------------------------------
9121 subroutine add_hb_contact(ii,jj,itask)
9122 implicit real*8 (a-h,o-z)
9123 include "DIMENSIONS"
9124 include "COMMON.IOUNITS"
9127 parameter (max_cont=maxconts)
9128 parameter (max_dim=26)
9129 include "COMMON.CONTACTS"
9130 double precision zapas(max_dim,maxconts,max_fg_procs),
9131 & zapas_recv(max_dim,maxconts,max_fg_procs)
9132 common /przechowalnia/ zapas
9133 integer i,j,ii,jj,iproc,itask(4),nn
9134 c write (iout,*) "itask",itask
9137 if (iproc.gt.0) then
9138 do j=1,num_cont_hb(ii)
9140 c write (iout,*) "i",ii," j",jj," jjc",jjc
9142 ncont_sent(iproc)=ncont_sent(iproc)+1
9143 nn=ncont_sent(iproc)
9144 zapas(1,nn,iproc)=ii
9145 zapas(2,nn,iproc)=jjc
9146 zapas(3,nn,iproc)=facont_hb(j,ii)
9147 zapas(4,nn,iproc)=ees0p(j,ii)
9148 zapas(5,nn,iproc)=ees0m(j,ii)
9149 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9150 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9151 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9152 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9153 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9154 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9155 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9156 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9157 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9158 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9159 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9160 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9161 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9162 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9163 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9164 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9165 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9166 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9167 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9168 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9169 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9177 c------------------------------------------------------------------------------
9178 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9180 C This subroutine calculates multi-body contributions to hydrogen-bonding
9181 implicit real*8 (a-h,o-z)
9182 include 'DIMENSIONS'
9183 include 'COMMON.IOUNITS'
9186 parameter (max_cont=maxconts)
9187 parameter (max_dim=70)
9188 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9189 double precision zapas(max_dim,maxconts,max_fg_procs),
9190 & zapas_recv(max_dim,maxconts,max_fg_procs)
9191 common /przechowalnia/ zapas
9192 integer status(MPI_STATUS_SIZE),req(maxconts*2),
9193 & status_array(MPI_STATUS_SIZE,maxconts*2)
9195 include 'COMMON.SETUP'
9196 include 'COMMON.FFIELD'
9197 include 'COMMON.DERIV'
9198 include 'COMMON.LOCAL'
9199 include 'COMMON.INTERACT'
9200 include 'COMMON.CONTACTS'
9201 include 'COMMON.CHAIN'
9202 include 'COMMON.CONTROL'
9203 include 'COMMON.SHIELD'
9204 double precision gx(3),gx1(3)
9205 integer num_cont_hb_old(maxres)
9207 double precision eello4,eello5,eelo6,eello_turn6
9208 external eello4,eello5,eello6,eello_turn6
9209 C Set lprn=.true. for debugging
9214 num_cont_hb_old(i)=num_cont_hb(i)
9218 if (nfgtasks.le.1) goto 30
9220 write (iout,'(a)') 'Contact function values before RECEIVE:'
9222 write (iout,'(2i3,50(1x,i2,f5.2))')
9223 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9224 & j=1,num_cont_hb(i))
9227 do i=1,ntask_cont_from
9230 do i=1,ntask_cont_to
9233 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9235 C Make the list of contacts to send to send to other procesors
9236 do i=iturn3_start,iturn3_end
9237 c write (iout,*) "make contact list turn3",i," num_cont",
9239 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9241 do i=iturn4_start,iturn4_end
9242 c write (iout,*) "make contact list turn4",i," num_cont",
9244 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9248 c write (iout,*) "make contact list longrange",i,ii," num_cont",
9250 do j=1,num_cont_hb(i)
9253 iproc=iint_sent_local(k,jjc,ii)
9254 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9255 if (iproc.ne.0) then
9256 ncont_sent(iproc)=ncont_sent(iproc)+1
9257 nn=ncont_sent(iproc)
9259 zapas(2,nn,iproc)=jjc
9260 zapas(3,nn,iproc)=d_cont(j,i)
9264 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9269 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9277 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9288 & "Numbers of contacts to be sent to other processors",
9289 & (ncont_sent(i),i=1,ntask_cont_to)
9290 write (iout,*) "Contacts sent"
9291 do ii=1,ntask_cont_to
9293 iproc=itask_cont_to(ii)
9294 write (iout,*) nn," contacts to processor",iproc,
9295 & " of CONT_TO_COMM group"
9297 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9305 CorrelID1=nfgtasks+fg_rank+1
9307 C Receive the numbers of needed contacts from other processors
9308 do ii=1,ntask_cont_from
9309 iproc=itask_cont_from(ii)
9311 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9312 & FG_COMM,req(ireq),IERR)
9314 c write (iout,*) "IRECV ended"
9316 C Send the number of contacts needed by other processors
9317 do ii=1,ntask_cont_to
9318 iproc=itask_cont_to(ii)
9320 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9321 & FG_COMM,req(ireq),IERR)
9323 c write (iout,*) "ISEND ended"
9324 c write (iout,*) "number of requests (nn)",ireq
9327 & call MPI_Waitall(ireq,req,status_array,ierr)
9329 c & "Numbers of contacts to be received from other processors",
9330 c & (ncont_recv(i),i=1,ntask_cont_from)
9334 do ii=1,ntask_cont_from
9335 iproc=itask_cont_from(ii)
9337 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9338 c & " of CONT_TO_COMM group"
9342 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9343 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9344 c write (iout,*) "ireq,req",ireq,req(ireq)
9347 C Send the contacts to processors that need them
9348 do ii=1,ntask_cont_to
9349 iproc=itask_cont_to(ii)
9351 c write (iout,*) nn," contacts to processor",iproc,
9352 c & " of CONT_TO_COMM group"
9355 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9356 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9357 c write (iout,*) "ireq,req",ireq,req(ireq)
9359 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9363 c write (iout,*) "number of requests (contacts)",ireq
9364 c write (iout,*) "req",(req(i),i=1,4)
9367 & call MPI_Waitall(ireq,req,status_array,ierr)
9368 do iii=1,ntask_cont_from
9369 iproc=itask_cont_from(iii)
9372 write (iout,*) "Received",nn," contacts from processor",iproc,
9373 & " of CONT_FROM_COMM group"
9376 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9381 ii=zapas_recv(1,i,iii)
9382 c Flag the received contacts to prevent double-counting
9383 jj=-zapas_recv(2,i,iii)
9384 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9386 nnn=num_cont_hb(ii)+1
9389 d_cont(nnn,ii)=zapas_recv(3,i,iii)
9393 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9398 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9406 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9414 write (iout,'(a)') 'Contact function values after receive:'
9416 write (iout,'(2i3,50(1x,i3,5f6.3))')
9417 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9418 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9425 write (iout,'(a)') 'Contact function values:'
9427 write (iout,'(2i3,50(1x,i2,5f6.3))')
9428 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9429 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9435 C Remove the loop below after debugging !!!
9442 C Calculate the dipole-dipole interaction energies
9443 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9444 do i=iatel_s,iatel_e+1
9445 num_conti=num_cont_hb(i)
9454 C Calculate the local-electrostatic correlation terms
9455 c write (iout,*) "gradcorr5 in eello5 before loop"
9457 c write (iout,'(i5,3f10.5)')
9458 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9460 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9461 c write (iout,*) "corr loop i",i
9463 num_conti=num_cont_hb(i)
9464 num_conti1=num_cont_hb(i+1)
9471 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9472 c & ' jj=',jj,' kk=',kk
9473 c if (j1.eq.j+1 .or. j1.eq.j-1) then
9474 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9475 & .or. j.lt.0 .and. j1.gt.0) .and.
9476 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9477 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9478 C The system gains extra energy.
9480 sqd1=dsqrt(d_cont(jj,i))
9481 sqd2=dsqrt(d_cont(kk,i1))
9482 sred_geom = sqd1*sqd2
9483 IF (sred_geom.lt.cutoff_corr) THEN
9484 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9486 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9487 cd & ' jj=',jj,' kk=',kk
9488 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9489 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9491 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9492 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9495 cd write (iout,*) 'sred_geom=',sred_geom,
9496 cd & ' ekont=',ekont,' fprim=',fprimcont,
9497 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9498 cd write (iout,*) "g_contij",g_contij
9499 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9500 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9501 call calc_eello(i,jp,i+1,jp1,jj,kk)
9502 if (wcorr4.gt.0.0d0)
9503 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9504 CC & *fac_shield(i)**2*fac_shield(j)**2
9505 if (energy_dec.and.wcorr4.gt.0.0d0)
9506 1 write (iout,'(a6,4i5,0pf7.3)')
9507 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9508 c write (iout,*) "gradcorr5 before eello5"
9510 c write (iout,'(i5,3f10.5)')
9511 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9513 if (wcorr5.gt.0.0d0)
9514 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9515 c write (iout,*) "gradcorr5 after eello5"
9517 c write (iout,'(i5,3f10.5)')
9518 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9520 if (energy_dec.and.wcorr5.gt.0.0d0)
9521 1 write (iout,'(a6,4i5,0pf7.3)')
9522 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9523 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9524 cd write(2,*)'ijkl',i,jp,i+1,jp1
9525 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9526 & .or. wturn6.eq.0.0d0))then
9527 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9528 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9529 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9530 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9531 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9532 cd & 'ecorr6=',ecorr6
9533 cd write (iout,'(4e15.5)') sred_geom,
9534 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9535 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9536 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9537 else if (wturn6.gt.0.0d0
9538 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9539 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9540 eturn6=eturn6+eello_turn6(i,jj,kk)
9541 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9542 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9543 cd write (2,*) 'multibody_eello:eturn6',eturn6
9552 num_cont_hb(i)=num_cont_hb_old(i)
9554 c write (iout,*) "gradcorr5 in eello5"
9556 c write (iout,'(i5,3f10.5)')
9557 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9561 c------------------------------------------------------------------------------
9562 subroutine add_hb_contact_eello(ii,jj,itask)
9563 implicit real*8 (a-h,o-z)
9564 include "DIMENSIONS"
9565 include "COMMON.IOUNITS"
9568 parameter (max_cont=maxconts)
9569 parameter (max_dim=70)
9570 include "COMMON.CONTACTS"
9571 double precision zapas(max_dim,maxconts,max_fg_procs),
9572 & zapas_recv(max_dim,maxconts,max_fg_procs)
9573 common /przechowalnia/ zapas
9574 integer i,j,ii,jj,iproc,itask(4),nn
9575 c write (iout,*) "itask",itask
9578 if (iproc.gt.0) then
9579 do j=1,num_cont_hb(ii)
9581 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9583 ncont_sent(iproc)=ncont_sent(iproc)+1
9584 nn=ncont_sent(iproc)
9585 zapas(1,nn,iproc)=ii
9586 zapas(2,nn,iproc)=jjc
9587 zapas(3,nn,iproc)=d_cont(j,ii)
9591 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9596 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9604 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9616 c------------------------------------------------------------------------------
9617 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9618 implicit real*8 (a-h,o-z)
9619 include 'DIMENSIONS'
9620 include 'COMMON.IOUNITS'
9621 include 'COMMON.DERIV'
9622 include 'COMMON.INTERACT'
9623 include 'COMMON.CONTACTS'
9624 include 'COMMON.SHIELD'
9625 include 'COMMON.CONTROL'
9626 double precision gx(3),gx1(3)
9629 C print *,"wchodze",fac_shield(i),shield_mode
9637 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9639 C & fac_shield(i)**2*fac_shield(j)**2
9640 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9641 C Following 4 lines for diagnostics.
9646 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9647 c & 'Contacts ',i,j,
9648 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9649 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9651 C Calculate the multi-body contribution to energy.
9652 C ecorr=ecorr+ekont*ees
9653 C Calculate multi-body contributions to the gradient.
9654 coeffpees0pij=coeffp*ees0pij
9655 coeffmees0mij=coeffm*ees0mij
9656 coeffpees0pkl=coeffp*ees0pkl
9657 coeffmees0mkl=coeffm*ees0mkl
9659 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9660 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9661 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9662 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9663 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9664 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9665 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9666 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9667 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9668 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9669 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9670 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9671 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9672 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9673 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9674 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9675 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9676 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9677 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9678 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9679 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9680 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9681 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9682 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9683 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9688 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9689 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9690 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9691 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9696 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9697 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9698 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9699 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9702 c write (iout,*) "ehbcorr",ekont*ees
9703 C print *,ekont,ees,i,k
9705 C now gradient over shielding
9707 if (shield_mode.gt.0) then
9710 C print *,i,j,fac_shield(i),fac_shield(j),
9711 C &fac_shield(k),fac_shield(l)
9712 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9713 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9714 do ilist=1,ishield_list(i)
9715 iresshield=shield_list(ilist,i)
9717 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9719 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9721 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9722 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9726 do ilist=1,ishield_list(j)
9727 iresshield=shield_list(ilist,j)
9729 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9731 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9733 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9734 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9739 do ilist=1,ishield_list(k)
9740 iresshield=shield_list(ilist,k)
9742 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9744 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9746 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9747 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9751 do ilist=1,ishield_list(l)
9752 iresshield=shield_list(ilist,l)
9754 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9756 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9758 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9759 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9763 C print *,gshieldx(m,iresshield)
9765 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9766 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9767 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9768 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9769 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9770 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9771 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9772 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9774 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9775 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9776 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9777 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9778 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9779 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9780 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9781 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9789 C---------------------------------------------------------------------------
9790 subroutine dipole(i,j,jj)
9791 implicit real*8 (a-h,o-z)
9792 include 'DIMENSIONS'
9793 include 'COMMON.IOUNITS'
9794 include 'COMMON.CHAIN'
9795 include 'COMMON.FFIELD'
9796 include 'COMMON.DERIV'
9797 include 'COMMON.INTERACT'
9798 include 'COMMON.CONTACTS'
9799 include 'COMMON.TORSION'
9800 include 'COMMON.VAR'
9801 include 'COMMON.GEO'
9802 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9804 iti1 = itortyp(itype(i+1))
9805 if (j.lt.nres-1) then
9806 itj1 = itype2loc(itype(j+1))
9811 dipi(iii,1)=Ub2(iii,i)
9812 dipderi(iii)=Ub2der(iii,i)
9813 dipi(iii,2)=b1(iii,i+1)
9814 dipj(iii,1)=Ub2(iii,j)
9815 dipderj(iii)=Ub2der(iii,j)
9816 dipj(iii,2)=b1(iii,j+1)
9820 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9823 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9830 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9834 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9839 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9840 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9842 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9844 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9846 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9851 C---------------------------------------------------------------------------
9852 subroutine calc_eello(i,j,k,l,jj,kk)
9854 C This subroutine computes matrices and vectors needed to calculate
9855 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9857 implicit real*8 (a-h,o-z)
9858 include 'DIMENSIONS'
9859 include 'COMMON.IOUNITS'
9860 include 'COMMON.CHAIN'
9861 include 'COMMON.DERIV'
9862 include 'COMMON.INTERACT'
9863 include 'COMMON.CONTACTS'
9864 include 'COMMON.TORSION'
9865 include 'COMMON.VAR'
9866 include 'COMMON.GEO'
9867 include 'COMMON.FFIELD'
9868 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9869 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9872 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9873 cd & ' jj=',jj,' kk=',kk
9874 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9875 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9876 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9879 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9880 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9883 call transpose2(aa1(1,1),aa1t(1,1))
9884 call transpose2(aa2(1,1),aa2t(1,1))
9887 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9888 & aa1tder(1,1,lll,kkk))
9889 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9890 & aa2tder(1,1,lll,kkk))
9894 C parallel orientation of the two CA-CA-CA frames.
9896 iti=itype2loc(itype(i))
9900 itk1=itype2loc(itype(k+1))
9901 itj=itype2loc(itype(j))
9902 if (l.lt.nres-1) then
9903 itl1=itype2loc(itype(l+1))
9907 C A1 kernel(j+1) A2T
9909 cd write (iout,'(3f10.5,5x,3f10.5)')
9910 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9912 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9913 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9914 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9915 C Following matrices are needed only for 6-th order cumulants
9916 IF (wcorr6.gt.0.0d0) THEN
9917 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9918 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9919 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9920 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9921 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9922 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9923 & ADtEAderx(1,1,1,1,1,1))
9925 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9926 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9927 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9928 & ADtEA1derx(1,1,1,1,1,1))
9930 C End 6-th order cumulants
9933 cd write (2,*) 'In calc_eello6'
9935 cd write (2,*) 'iii=',iii
9937 cd write (2,*) 'kkk=',kkk
9939 cd write (2,'(3(2f10.5),5x)')
9940 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9945 call transpose2(EUgder(1,1,k),auxmat(1,1))
9946 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9947 call transpose2(EUg(1,1,k),auxmat(1,1))
9948 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9949 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9950 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9951 c in theta; to be sriten later.
9953 c call transpose2(gtEE(1,1,k),auxmat(1,1))
9954 c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9955 c call transpose2(EUg(1,1,k),auxmat(1,1))
9956 c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9961 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9962 & EAEAderx(1,1,lll,kkk,iii,1))
9966 C A1T kernel(i+1) A2
9967 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9968 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9969 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9970 C Following matrices are needed only for 6-th order cumulants
9971 IF (wcorr6.gt.0.0d0) THEN
9972 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9973 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9974 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9975 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9976 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9977 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9978 & ADtEAderx(1,1,1,1,1,2))
9979 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9980 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9981 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9982 & ADtEA1derx(1,1,1,1,1,2))
9984 C End 6-th order cumulants
9985 call transpose2(EUgder(1,1,l),auxmat(1,1))
9986 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9987 call transpose2(EUg(1,1,l),auxmat(1,1))
9988 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9989 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9993 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9994 & EAEAderx(1,1,lll,kkk,iii,2))
9999 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10000 C They are needed only when the fifth- or the sixth-order cumulants are
10002 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10003 call transpose2(AEA(1,1,1),auxmat(1,1))
10004 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10005 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10006 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10007 call transpose2(AEAderg(1,1,1),auxmat(1,1))
10008 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10009 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10010 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10011 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10012 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10013 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10014 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10015 call transpose2(AEA(1,1,2),auxmat(1,1))
10016 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10017 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10018 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10019 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10020 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10021 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10022 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10023 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10024 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10025 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10026 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10027 C Calculate the Cartesian derivatives of the vectors.
10031 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10032 call matvec2(auxmat(1,1),b1(1,i),
10033 & AEAb1derx(1,lll,kkk,iii,1,1))
10034 call matvec2(auxmat(1,1),Ub2(1,i),
10035 & AEAb2derx(1,lll,kkk,iii,1,1))
10036 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10037 & AEAb1derx(1,lll,kkk,iii,2,1))
10038 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10039 & AEAb2derx(1,lll,kkk,iii,2,1))
10040 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10041 call matvec2(auxmat(1,1),b1(1,j),
10042 & AEAb1derx(1,lll,kkk,iii,1,2))
10043 call matvec2(auxmat(1,1),Ub2(1,j),
10044 & AEAb2derx(1,lll,kkk,iii,1,2))
10045 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10046 & AEAb1derx(1,lll,kkk,iii,2,2))
10047 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10048 & AEAb2derx(1,lll,kkk,iii,2,2))
10055 C Antiparallel orientation of the two CA-CA-CA frames.
10057 iti=itype2loc(itype(i))
10061 itk1=itype2loc(itype(k+1))
10062 itl=itype2loc(itype(l))
10063 itj=itype2loc(itype(j))
10064 if (j.lt.nres-1) then
10065 itj1=itype2loc(itype(j+1))
10069 C A2 kernel(j-1)T A1T
10070 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10071 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10072 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10073 C Following matrices are needed only for 6-th order cumulants
10074 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10075 & j.eq.i+4 .and. l.eq.i+3)) THEN
10076 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10077 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10078 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10079 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10080 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10081 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10082 & ADtEAderx(1,1,1,1,1,1))
10083 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10084 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10085 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10086 & ADtEA1derx(1,1,1,1,1,1))
10088 C End 6-th order cumulants
10089 call transpose2(EUgder(1,1,k),auxmat(1,1))
10090 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10091 call transpose2(EUg(1,1,k),auxmat(1,1))
10092 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10093 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10097 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10098 & EAEAderx(1,1,lll,kkk,iii,1))
10102 C A2T kernel(i+1)T A1
10103 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10104 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10105 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10106 C Following matrices are needed only for 6-th order cumulants
10107 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10108 & j.eq.i+4 .and. l.eq.i+3)) THEN
10109 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10110 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10111 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10112 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10113 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10114 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10115 & ADtEAderx(1,1,1,1,1,2))
10116 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10117 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10118 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10119 & ADtEA1derx(1,1,1,1,1,2))
10121 C End 6-th order cumulants
10122 call transpose2(EUgder(1,1,j),auxmat(1,1))
10123 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10124 call transpose2(EUg(1,1,j),auxmat(1,1))
10125 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10126 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10130 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10131 & EAEAderx(1,1,lll,kkk,iii,2))
10136 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10137 C They are needed only when the fifth- or the sixth-order cumulants are
10139 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10140 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10141 call transpose2(AEA(1,1,1),auxmat(1,1))
10142 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10143 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10144 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10145 call transpose2(AEAderg(1,1,1),auxmat(1,1))
10146 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10147 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10148 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10149 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10150 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10151 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10152 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10153 call transpose2(AEA(1,1,2),auxmat(1,1))
10154 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10155 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10156 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10157 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10158 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10159 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10160 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10161 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10162 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10163 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10164 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10165 C Calculate the Cartesian derivatives of the vectors.
10169 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10170 call matvec2(auxmat(1,1),b1(1,i),
10171 & AEAb1derx(1,lll,kkk,iii,1,1))
10172 call matvec2(auxmat(1,1),Ub2(1,i),
10173 & AEAb2derx(1,lll,kkk,iii,1,1))
10174 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10175 & AEAb1derx(1,lll,kkk,iii,2,1))
10176 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10177 & AEAb2derx(1,lll,kkk,iii,2,1))
10178 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10179 call matvec2(auxmat(1,1),b1(1,l),
10180 & AEAb1derx(1,lll,kkk,iii,1,2))
10181 call matvec2(auxmat(1,1),Ub2(1,l),
10182 & AEAb2derx(1,lll,kkk,iii,1,2))
10183 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10184 & AEAb1derx(1,lll,kkk,iii,2,2))
10185 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10186 & AEAb2derx(1,lll,kkk,iii,2,2))
10195 C---------------------------------------------------------------------------
10196 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10197 & KK,KKderg,AKA,AKAderg,AKAderx)
10201 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10202 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10203 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10204 integer iii,kkk,lll
10207 common /kutas/ lprn
10208 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10210 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10211 & AKAderg(1,1,iii))
10213 cd if (lprn) write (2,*) 'In kernel'
10215 cd if (lprn) write (2,*) 'kkk=',kkk
10217 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10218 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10220 cd write (2,*) 'lll=',lll
10221 cd write (2,*) 'iii=1'
10223 cd write (2,'(3(2f10.5),5x)')
10224 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10227 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10228 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10230 cd write (2,*) 'lll=',lll
10231 cd write (2,*) 'iii=2'
10233 cd write (2,'(3(2f10.5),5x)')
10234 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10241 C---------------------------------------------------------------------------
10242 double precision function eello4(i,j,k,l,jj,kk)
10243 implicit real*8 (a-h,o-z)
10244 include 'DIMENSIONS'
10245 include 'COMMON.IOUNITS'
10246 include 'COMMON.CHAIN'
10247 include 'COMMON.DERIV'
10248 include 'COMMON.INTERACT'
10249 include 'COMMON.CONTACTS'
10250 include 'COMMON.TORSION'
10251 include 'COMMON.VAR'
10252 include 'COMMON.GEO'
10253 double precision pizda(2,2),ggg1(3),ggg2(3)
10254 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10258 cd print *,'eello4:',i,j,k,l,jj,kk
10259 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
10260 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
10261 cold eij=facont_hb(jj,i)
10262 cold ekl=facont_hb(kk,k)
10264 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10265 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10266 gcorr_loc(k-1)=gcorr_loc(k-1)
10267 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10269 gcorr_loc(l-1)=gcorr_loc(l-1)
10270 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10271 C Al 4/16/16: Derivatives in theta, to be added later.
10273 c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10274 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10277 gcorr_loc(j-1)=gcorr_loc(j-1)
10278 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10280 c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10281 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10287 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10288 & -EAEAderx(2,2,lll,kkk,iii,1)
10289 cd derx(lll,kkk,iii)=0.0d0
10293 cd gcorr_loc(l-1)=0.0d0
10294 cd gcorr_loc(j-1)=0.0d0
10295 cd gcorr_loc(k-1)=0.0d0
10297 cd write (iout,*)'Contacts have occurred for peptide groups',
10298 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
10299 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10300 if (j.lt.nres-1) then
10307 if (l.lt.nres-1) then
10315 cgrad ggg1(ll)=eel4*g_contij(ll,1)
10316 cgrad ggg2(ll)=eel4*g_contij(ll,2)
10317 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10318 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10319 cgrad ghalf=0.5d0*ggg1(ll)
10320 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10321 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10322 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10323 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10324 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10325 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10326 cgrad ghalf=0.5d0*ggg2(ll)
10327 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10328 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10329 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10330 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10331 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10332 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10336 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10341 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10346 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10351 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10355 cd write (2,*) iii,gcorr_loc(iii)
10358 cd write (2,*) 'ekont',ekont
10359 cd write (iout,*) 'eello4',ekont*eel4
10362 C---------------------------------------------------------------------------
10363 double precision function eello5(i,j,k,l,jj,kk)
10364 implicit real*8 (a-h,o-z)
10365 include 'DIMENSIONS'
10366 include 'COMMON.IOUNITS'
10367 include 'COMMON.CHAIN'
10368 include 'COMMON.DERIV'
10369 include 'COMMON.INTERACT'
10370 include 'COMMON.CONTACTS'
10371 include 'COMMON.TORSION'
10372 include 'COMMON.VAR'
10373 include 'COMMON.GEO'
10374 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10375 double precision ggg1(3),ggg2(3)
10376 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10378 C Parallel chains C
10381 C /l\ / \ \ / \ / \ / C
10382 C / \ / \ \ / \ / \ / C
10383 C j| o |l1 | o | o| o | | o |o C
10384 C \ |/k\| |/ \| / |/ \| |/ \| C
10385 C \i/ \ / \ / / \ / \ C
10387 C (I) (II) (III) (IV) C
10389 C eello5_1 eello5_2 eello5_3 eello5_4 C
10391 C Antiparallel chains C
10394 C /j\ / \ \ / \ / \ / C
10395 C / \ / \ \ / \ / \ / C
10396 C j1| o |l | o | o| o | | o |o C
10397 C \ |/k\| |/ \| / |/ \| |/ \| C
10398 C \i/ \ / \ / / \ / \ C
10400 C (I) (II) (III) (IV) C
10402 C eello5_1 eello5_2 eello5_3 eello5_4 C
10404 C o denotes a local interaction, vertical lines an electrostatic interaction. C
10406 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10407 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10412 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
10414 itk=itype2loc(itype(k))
10415 itl=itype2loc(itype(l))
10416 itj=itype2loc(itype(j))
10421 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10422 cd & eel5_3_num,eel5_4_num)
10426 derx(lll,kkk,iii)=0.0d0
10430 cd eij=facont_hb(jj,i)
10431 cd ekl=facont_hb(kk,k)
10433 cd write (iout,*)'Contacts have occurred for peptide groups',
10434 cd & i,j,' fcont:',eij,' eij',' and ',k,l
10436 C Contribution from the graph I.
10437 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10438 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10439 call transpose2(EUg(1,1,k),auxmat(1,1))
10440 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10441 vv(1)=pizda(1,1)-pizda(2,2)
10442 vv(2)=pizda(1,2)+pizda(2,1)
10443 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10444 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10445 C Explicit gradient in virtual-dihedral angles.
10446 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10447 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10448 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10449 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10450 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10451 vv(1)=pizda(1,1)-pizda(2,2)
10452 vv(2)=pizda(1,2)+pizda(2,1)
10453 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10454 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10455 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10456 call matmat2(AEAderg(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)
10460 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10461 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10462 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10464 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10465 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10466 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10468 C Cartesian gradient
10472 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10474 vv(1)=pizda(1,1)-pizda(2,2)
10475 vv(2)=pizda(1,2)+pizda(2,1)
10476 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10477 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10478 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10484 C Contribution from graph II
10485 call transpose2(EE(1,1,k),auxmat(1,1))
10486 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10487 vv(1)=pizda(1,1)+pizda(2,2)
10488 vv(2)=pizda(2,1)-pizda(1,2)
10489 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10490 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10491 C Explicit gradient in virtual-dihedral angles.
10492 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10493 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10494 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10495 vv(1)=pizda(1,1)+pizda(2,2)
10496 vv(2)=pizda(2,1)-pizda(1,2)
10498 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10499 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10500 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10502 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10503 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10504 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10506 C Cartesian gradient
10510 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10512 vv(1)=pizda(1,1)+pizda(2,2)
10513 vv(2)=pizda(2,1)-pizda(1,2)
10514 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10515 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10516 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10524 C Parallel orientation
10525 C Contribution from graph III
10526 call transpose2(EUg(1,1,l),auxmat(1,1))
10527 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10528 vv(1)=pizda(1,1)-pizda(2,2)
10529 vv(2)=pizda(1,2)+pizda(2,1)
10530 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10531 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10532 C Explicit gradient in virtual-dihedral angles.
10533 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10534 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10535 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10536 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10537 vv(1)=pizda(1,1)-pizda(2,2)
10538 vv(2)=pizda(1,2)+pizda(2,1)
10539 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10540 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10541 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10542 call transpose2(EUgder(1,1,l),auxmat1(1,1))
10543 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10544 vv(1)=pizda(1,1)-pizda(2,2)
10545 vv(2)=pizda(1,2)+pizda(2,1)
10546 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10547 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10548 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10549 C Cartesian gradient
10553 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10555 vv(1)=pizda(1,1)-pizda(2,2)
10556 vv(2)=pizda(1,2)+pizda(2,1)
10557 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10558 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10559 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10564 C Contribution from graph IV
10566 call transpose2(EE(1,1,l),auxmat(1,1))
10567 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10568 vv(1)=pizda(1,1)+pizda(2,2)
10569 vv(2)=pizda(2,1)-pizda(1,2)
10570 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10571 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10572 C Explicit gradient in virtual-dihedral angles.
10573 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10574 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10575 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10576 vv(1)=pizda(1,1)+pizda(2,2)
10577 vv(2)=pizda(2,1)-pizda(1,2)
10578 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10579 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10580 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10581 C Cartesian gradient
10585 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10587 vv(1)=pizda(1,1)+pizda(2,2)
10588 vv(2)=pizda(2,1)-pizda(1,2)
10589 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10590 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10591 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10596 C Antiparallel orientation
10597 C Contribution from graph III
10599 call transpose2(EUg(1,1,j),auxmat(1,1))
10600 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10601 vv(1)=pizda(1,1)-pizda(2,2)
10602 vv(2)=pizda(1,2)+pizda(2,1)
10603 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10604 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10605 C Explicit gradient in virtual-dihedral angles.
10606 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10607 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10608 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10609 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10610 vv(1)=pizda(1,1)-pizda(2,2)
10611 vv(2)=pizda(1,2)+pizda(2,1)
10612 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10613 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10614 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10615 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10616 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10617 vv(1)=pizda(1,1)-pizda(2,2)
10618 vv(2)=pizda(1,2)+pizda(2,1)
10619 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10620 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10621 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10622 C Cartesian gradient
10626 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10628 vv(1)=pizda(1,1)-pizda(2,2)
10629 vv(2)=pizda(1,2)+pizda(2,1)
10630 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10631 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10632 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10637 C Contribution from graph IV
10639 call transpose2(EE(1,1,j),auxmat(1,1))
10640 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10641 vv(1)=pizda(1,1)+pizda(2,2)
10642 vv(2)=pizda(2,1)-pizda(1,2)
10643 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10644 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10645 C Explicit gradient in virtual-dihedral angles.
10646 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10647 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10648 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10649 vv(1)=pizda(1,1)+pizda(2,2)
10650 vv(2)=pizda(2,1)-pizda(1,2)
10651 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10652 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10653 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10654 C Cartesian gradient
10658 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10660 vv(1)=pizda(1,1)+pizda(2,2)
10661 vv(2)=pizda(2,1)-pizda(1,2)
10662 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10663 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10664 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10670 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10671 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10672 cd write (2,*) 'ijkl',i,j,k,l
10673 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10674 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10676 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10677 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10678 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10679 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10680 if (j.lt.nres-1) then
10687 if (l.lt.nres-1) then
10697 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10698 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10699 C summed up outside the subrouine as for the other subroutines
10700 C handling long-range interactions. The old code is commented out
10701 C with "cgrad" to keep track of changes.
10703 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10704 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10705 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10706 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10707 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10708 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10709 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10710 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10711 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10712 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10714 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10715 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10716 cgrad ghalf=0.5d0*ggg1(ll)
10718 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10719 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10720 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10721 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10722 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10723 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10724 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10725 cgrad ghalf=0.5d0*ggg2(ll)
10727 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10728 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10729 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10730 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10731 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10732 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10737 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10738 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10743 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10744 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10750 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10755 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10759 cd write (2,*) iii,g_corr5_loc(iii)
10762 cd write (2,*) 'ekont',ekont
10763 cd write (iout,*) 'eello5',ekont*eel5
10766 c--------------------------------------------------------------------------
10767 double precision function eello6(i,j,k,l,jj,kk)
10768 implicit real*8 (a-h,o-z)
10769 include 'DIMENSIONS'
10770 include 'COMMON.IOUNITS'
10771 include 'COMMON.CHAIN'
10772 include 'COMMON.DERIV'
10773 include 'COMMON.INTERACT'
10774 include 'COMMON.CONTACTS'
10775 include 'COMMON.TORSION'
10776 include 'COMMON.VAR'
10777 include 'COMMON.GEO'
10778 include 'COMMON.FFIELD'
10779 double precision ggg1(3),ggg2(3)
10780 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10785 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10793 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10794 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10798 derx(lll,kkk,iii)=0.0d0
10802 cd eij=facont_hb(jj,i)
10803 cd ekl=facont_hb(kk,k)
10809 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10810 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10811 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10812 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10813 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10814 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10816 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10817 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10818 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10819 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10820 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10821 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10825 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10827 C If turn contributions are considered, they will be handled separately.
10828 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10829 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10830 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10831 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10832 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10833 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10834 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10836 if (j.lt.nres-1) then
10843 if (l.lt.nres-1) then
10851 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10852 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10853 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10854 cgrad ghalf=0.5d0*ggg1(ll)
10856 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10857 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10858 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10859 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10860 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10861 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10862 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10863 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10864 cgrad ghalf=0.5d0*ggg2(ll)
10865 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10867 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10868 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10869 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10870 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10871 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10872 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10877 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10878 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10883 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10884 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10890 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10895 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10899 cd write (2,*) iii,g_corr6_loc(iii)
10902 cd write (2,*) 'ekont',ekont
10903 cd write (iout,*) 'eello6',ekont*eel6
10906 c--------------------------------------------------------------------------
10907 double precision function eello6_graph1(i,j,k,l,imat,swap)
10908 implicit real*8 (a-h,o-z)
10909 include 'DIMENSIONS'
10910 include 'COMMON.IOUNITS'
10911 include 'COMMON.CHAIN'
10912 include 'COMMON.DERIV'
10913 include 'COMMON.INTERACT'
10914 include 'COMMON.CONTACTS'
10915 include 'COMMON.TORSION'
10916 include 'COMMON.VAR'
10917 include 'COMMON.GEO'
10918 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10921 common /kutas/ lprn
10922 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10924 C Parallel Antiparallel C
10930 C \ j|/k\| / \ |/k\|l / C
10931 C \ / \ / \ / \ / C
10935 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10936 itk=itype2loc(itype(k))
10937 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10938 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10939 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10940 call transpose2(EUgC(1,1,k),auxmat(1,1))
10941 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10942 vv1(1)=pizda1(1,1)-pizda1(2,2)
10943 vv1(2)=pizda1(1,2)+pizda1(2,1)
10944 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10945 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10946 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10947 s5=scalar2(vv(1),Dtobr2(1,i))
10948 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10949 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10950 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10951 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10952 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10953 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10954 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10955 & +scalar2(vv(1),Dtobr2der(1,i)))
10956 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10957 vv1(1)=pizda1(1,1)-pizda1(2,2)
10958 vv1(2)=pizda1(1,2)+pizda1(2,1)
10959 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10960 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10962 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10963 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10964 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10965 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10966 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10968 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10969 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10970 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10971 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10972 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10974 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10975 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10976 vv1(1)=pizda1(1,1)-pizda1(2,2)
10977 vv1(2)=pizda1(1,2)+pizda1(2,1)
10978 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10979 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10980 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10981 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10990 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10991 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10992 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10993 call transpose2(EUgC(1,1,k),auxmat(1,1))
10994 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10996 vv1(1)=pizda1(1,1)-pizda1(2,2)
10997 vv1(2)=pizda1(1,2)+pizda1(2,1)
10998 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10999 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11000 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11001 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11002 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11003 s5=scalar2(vv(1),Dtobr2(1,i))
11004 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11010 c----------------------------------------------------------------------------
11011 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11012 implicit real*8 (a-h,o-z)
11013 include 'DIMENSIONS'
11014 include 'COMMON.IOUNITS'
11015 include 'COMMON.CHAIN'
11016 include 'COMMON.DERIV'
11017 include 'COMMON.INTERACT'
11018 include 'COMMON.CONTACTS'
11019 include 'COMMON.TORSION'
11020 include 'COMMON.VAR'
11021 include 'COMMON.GEO'
11023 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11024 & auxvec1(2),auxvec2(2),auxmat1(2,2)
11026 common /kutas/ lprn
11027 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11029 C Parallel Antiparallel C
11035 C \ j|/k\| \ |/k\|l C
11040 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11041 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11042 C AL 7/4/01 s1 would occur in the sixth-order moment,
11043 C but not in a cluster cumulant
11045 s1=dip(1,jj,i)*dip(1,kk,k)
11047 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11048 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11049 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11050 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11051 call transpose2(EUg(1,1,k),auxmat(1,1))
11052 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11053 vv(1)=pizda(1,1)-pizda(2,2)
11054 vv(2)=pizda(1,2)+pizda(2,1)
11055 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11056 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11058 eello6_graph2=-(s1+s2+s3+s4)
11060 eello6_graph2=-(s2+s3+s4)
11062 c eello6_graph2=-s3
11063 C Derivatives in gamma(i-1)
11066 s1=dipderg(1,jj,i)*dip(1,kk,k)
11068 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11069 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11070 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11071 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11073 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11075 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11077 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11079 C Derivatives in gamma(k-1)
11081 s1=dip(1,jj,i)*dipderg(1,kk,k)
11083 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11084 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11085 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11086 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11087 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11088 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11089 vv(1)=pizda(1,1)-pizda(2,2)
11090 vv(2)=pizda(1,2)+pizda(2,1)
11091 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11093 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11095 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11097 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11098 C Derivatives in gamma(j-1) or gamma(l-1)
11101 s1=dipderg(3,jj,i)*dip(1,kk,k)
11103 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11104 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11105 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11106 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11107 vv(1)=pizda(1,1)-pizda(2,2)
11108 vv(2)=pizda(1,2)+pizda(2,1)
11109 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11112 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11114 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11117 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11118 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11120 C Derivatives in gamma(l-1) or gamma(j-1)
11123 s1=dip(1,jj,i)*dipderg(3,kk,k)
11125 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11126 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11127 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11128 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11129 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11130 vv(1)=pizda(1,1)-pizda(2,2)
11131 vv(2)=pizda(1,2)+pizda(2,1)
11132 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11135 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11137 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11140 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11141 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11143 C Cartesian derivatives.
11145 write (2,*) 'In eello6_graph2'
11147 write (2,*) 'iii=',iii
11149 write (2,*) 'kkk=',kkk
11151 write (2,'(3(2f10.5),5x)')
11152 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11162 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11164 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11167 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11169 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11170 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11172 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11173 call transpose2(EUg(1,1,k),auxmat(1,1))
11174 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11176 vv(1)=pizda(1,1)-pizda(2,2)
11177 vv(2)=pizda(1,2)+pizda(2,1)
11178 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11179 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11181 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11183 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11186 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11188 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11195 c----------------------------------------------------------------------------
11196 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11197 implicit real*8 (a-h,o-z)
11198 include 'DIMENSIONS'
11199 include 'COMMON.IOUNITS'
11200 include 'COMMON.CHAIN'
11201 include 'COMMON.DERIV'
11202 include 'COMMON.INTERACT'
11203 include 'COMMON.CONTACTS'
11204 include 'COMMON.TORSION'
11205 include 'COMMON.VAR'
11206 include 'COMMON.GEO'
11207 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11209 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11211 C Parallel Antiparallel C
11216 C /| o |o o| o |\ C
11217 C j|/k\| / |/k\|l / C
11222 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11224 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11225 C energy moment and not to the cluster cumulant.
11226 iti=itortyp(itype(i))
11227 if (j.lt.nres-1) then
11228 itj1=itype2loc(itype(j+1))
11232 itk=itype2loc(itype(k))
11233 itk1=itype2loc(itype(k+1))
11234 if (l.lt.nres-1) then
11235 itl1=itype2loc(itype(l+1))
11240 s1=dip(4,jj,i)*dip(4,kk,k)
11242 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11243 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11244 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11245 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11246 call transpose2(EE(1,1,k),auxmat(1,1))
11247 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11248 vv(1)=pizda(1,1)+pizda(2,2)
11249 vv(2)=pizda(2,1)-pizda(1,2)
11250 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11251 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11252 cd & "sum",-(s2+s3+s4)
11254 eello6_graph3=-(s1+s2+s3+s4)
11256 eello6_graph3=-(s2+s3+s4)
11258 c eello6_graph3=-s4
11259 C Derivatives in gamma(k-1)
11260 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11261 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11262 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11263 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11264 C Derivatives in gamma(l-1)
11265 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11266 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11267 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11268 vv(1)=pizda(1,1)+pizda(2,2)
11269 vv(2)=pizda(2,1)-pizda(1,2)
11270 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11271 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11272 C Cartesian derivatives.
11278 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11280 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11283 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11285 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11286 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11288 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11289 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11291 vv(1)=pizda(1,1)+pizda(2,2)
11292 vv(2)=pizda(2,1)-pizda(1,2)
11293 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11295 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11297 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11300 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11302 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11304 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11310 c----------------------------------------------------------------------------
11311 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11312 implicit real*8 (a-h,o-z)
11313 include 'DIMENSIONS'
11314 include 'COMMON.IOUNITS'
11315 include 'COMMON.CHAIN'
11316 include 'COMMON.DERIV'
11317 include 'COMMON.INTERACT'
11318 include 'COMMON.CONTACTS'
11319 include 'COMMON.TORSION'
11320 include 'COMMON.VAR'
11321 include 'COMMON.GEO'
11322 include 'COMMON.FFIELD'
11323 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11324 & auxvec1(2),auxmat1(2,2)
11326 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11328 C Parallel Antiparallel C
11333 C /| o |o o| o |\ C
11334 C \ j|/k\| \ |/k\|l C
11339 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11341 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11342 C energy moment and not to the cluster cumulant.
11343 cd write (2,*) 'eello_graph4: wturn6',wturn6
11344 iti=itype2loc(itype(i))
11345 itj=itype2loc(itype(j))
11346 if (j.lt.nres-1) then
11347 itj1=itype2loc(itype(j+1))
11351 itk=itype2loc(itype(k))
11352 if (k.lt.nres-1) then
11353 itk1=itype2loc(itype(k+1))
11357 itl=itype2loc(itype(l))
11358 if (l.lt.nres-1) then
11359 itl1=itype2loc(itype(l+1))
11363 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11364 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11365 cd & ' itl',itl,' itl1',itl1
11367 if (imat.eq.1) then
11368 s1=dip(3,jj,i)*dip(3,kk,k)
11370 s1=dip(2,jj,j)*dip(2,kk,l)
11373 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11374 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11376 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11377 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11379 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11380 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11382 call transpose2(EUg(1,1,k),auxmat(1,1))
11383 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11384 vv(1)=pizda(1,1)-pizda(2,2)
11385 vv(2)=pizda(2,1)+pizda(1,2)
11386 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11387 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11389 eello6_graph4=-(s1+s2+s3+s4)
11391 eello6_graph4=-(s2+s3+s4)
11393 C Derivatives in gamma(i-1)
11396 if (imat.eq.1) then
11397 s1=dipderg(2,jj,i)*dip(3,kk,k)
11399 s1=dipderg(4,jj,j)*dip(2,kk,l)
11402 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11404 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11405 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11407 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11408 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11410 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11411 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11412 cd write (2,*) 'turn6 derivatives'
11414 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11416 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11420 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11422 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11426 C Derivatives in gamma(k-1)
11428 if (imat.eq.1) then
11429 s1=dip(3,jj,i)*dipderg(2,kk,k)
11431 s1=dip(2,jj,j)*dipderg(4,kk,l)
11434 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11435 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11437 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11438 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11440 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11441 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11443 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11444 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11445 vv(1)=pizda(1,1)-pizda(2,2)
11446 vv(2)=pizda(2,1)+pizda(1,2)
11447 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11448 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11450 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11452 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11456 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11458 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11461 C Derivatives in gamma(j-1) or gamma(l-1)
11462 if (l.eq.j+1 .and. l.gt.1) then
11463 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11464 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11465 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11466 vv(1)=pizda(1,1)-pizda(2,2)
11467 vv(2)=pizda(2,1)+pizda(1,2)
11468 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11469 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11470 else if (j.gt.1) then
11471 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11472 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11473 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11474 vv(1)=pizda(1,1)-pizda(2,2)
11475 vv(2)=pizda(2,1)+pizda(1,2)
11476 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11477 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11478 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11480 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11483 C Cartesian derivatives.
11489 if (imat.eq.1) then
11490 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11492 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11495 if (imat.eq.1) then
11496 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11498 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11502 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11504 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11506 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11507 & b1(1,j+1),auxvec(1))
11508 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11510 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11511 & b1(1,l+1),auxvec(1))
11512 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11514 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11516 vv(1)=pizda(1,1)-pizda(2,2)
11517 vv(2)=pizda(2,1)+pizda(1,2)
11518 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11520 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11522 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11525 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11528 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11531 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11533 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11535 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11539 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11541 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11544 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11546 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11554 c----------------------------------------------------------------------------
11555 double precision function eello_turn6(i,jj,kk)
11556 implicit real*8 (a-h,o-z)
11557 include 'DIMENSIONS'
11558 include 'COMMON.IOUNITS'
11559 include 'COMMON.CHAIN'
11560 include 'COMMON.DERIV'
11561 include 'COMMON.INTERACT'
11562 include 'COMMON.CONTACTS'
11563 include 'COMMON.TORSION'
11564 include 'COMMON.VAR'
11565 include 'COMMON.GEO'
11566 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11567 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11569 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11570 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11571 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11572 C the respective energy moment and not to the cluster cumulant.
11581 iti=itype2loc(itype(i))
11582 itk=itype2loc(itype(k))
11583 itk1=itype2loc(itype(k+1))
11584 itl=itype2loc(itype(l))
11585 itj=itype2loc(itype(j))
11586 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11587 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11588 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11593 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11595 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11599 derx_turn(lll,kkk,iii)=0.0d0
11606 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11608 cd write (2,*) 'eello6_5',eello6_5
11610 call transpose2(AEA(1,1,1),auxmat(1,1))
11611 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11612 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11613 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11615 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11616 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11617 s2 = scalar2(b1(1,k),vtemp1(1))
11619 call transpose2(AEA(1,1,2),atemp(1,1))
11620 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11621 call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11622 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11624 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11625 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11626 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11628 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11629 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11630 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11631 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11632 ss13 = scalar2(b1(1,k),vtemp4(1))
11633 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11635 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11641 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11642 C Derivatives in gamma(i+2)
11646 call transpose2(AEA(1,1,1),auxmatd(1,1))
11647 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11648 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11649 call transpose2(AEAderg(1,1,2),atempd(1,1))
11650 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11651 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11653 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11654 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11655 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11661 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11662 C Derivatives in gamma(i+3)
11664 call transpose2(AEA(1,1,1),auxmatd(1,1))
11665 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11666 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11667 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11669 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11670 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11671 s2d = scalar2(b1(1,k),vtemp1d(1))
11673 call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11674 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11676 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11678 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11679 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11680 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11688 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11689 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11691 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11692 & -0.5d0*ekont*(s2d+s12d)
11694 C Derivatives in gamma(i+4)
11695 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11696 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11697 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11699 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11700 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11701 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11709 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11711 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11713 C Derivatives in gamma(i+5)
11715 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11716 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11717 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11719 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11720 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11721 s2d = scalar2(b1(1,k),vtemp1d(1))
11723 call transpose2(AEA(1,1,2),atempd(1,1))
11724 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11725 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11727 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11728 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11730 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11731 ss13d = scalar2(b1(1,k),vtemp4d(1))
11732 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11740 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11741 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11743 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11744 & -0.5d0*ekont*(s2d+s12d)
11746 C Cartesian derivatives
11751 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11752 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11753 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11755 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11756 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11758 s2d = scalar2(b1(1,k),vtemp1d(1))
11760 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11761 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11762 s8d = -(atempd(1,1)+atempd(2,2))*
11763 & scalar2(cc(1,1,l),vtemp2(1))
11765 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11767 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11768 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11775 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11776 & - 0.5d0*(s1d+s2d)
11778 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11782 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11783 & - 0.5d0*(s8d+s12d)
11785 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11794 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11795 & achuj_tempd(1,1))
11796 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11797 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11798 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11799 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11800 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11802 ss13d = scalar2(b1(1,k),vtemp4d(1))
11803 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11804 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11808 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11809 cd & 16*eel_turn6_num
11811 if (j.lt.nres-1) then
11818 if (l.lt.nres-1) then
11826 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11827 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11828 cgrad ghalf=0.5d0*ggg1(ll)
11830 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11831 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11832 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11833 & +ekont*derx_turn(ll,2,1)
11834 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11835 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11836 & +ekont*derx_turn(ll,4,1)
11837 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11838 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11839 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11840 cgrad ghalf=0.5d0*ggg2(ll)
11842 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11843 & +ekont*derx_turn(ll,2,2)
11844 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11845 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11846 & +ekont*derx_turn(ll,4,2)
11847 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11848 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11849 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11854 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11859 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11865 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11870 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11874 cd write (2,*) iii,g_corr6_loc(iii)
11876 eello_turn6=ekont*eel_turn6
11877 cd write (2,*) 'ekont',ekont
11878 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11882 C-----------------------------------------------------------------------------
11883 double precision function scalar(u,v)
11884 !DIR$ INLINEALWAYS scalar
11886 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11889 double precision u(3),v(3)
11890 cd double precision sc
11898 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11901 crc-------------------------------------------------
11902 SUBROUTINE MATVEC2(A1,V1,V2)
11903 !DIR$ INLINEALWAYS MATVEC2
11905 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11907 implicit real*8 (a-h,o-z)
11908 include 'DIMENSIONS'
11909 DIMENSION A1(2,2),V1(2),V2(2)
11913 c 3 VI=VI+A1(I,K)*V1(K)
11917 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11918 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11923 C---------------------------------------
11924 SUBROUTINE MATMAT2(A1,A2,A3)
11926 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11928 implicit real*8 (a-h,o-z)
11929 include 'DIMENSIONS'
11930 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11931 c DIMENSION AI3(2,2)
11935 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11941 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11942 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11943 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11944 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11952 c-------------------------------------------------------------------------
11953 double precision function scalar2(u,v)
11954 !DIR$ INLINEALWAYS scalar2
11956 double precision u(2),v(2)
11957 double precision sc
11959 scalar2=u(1)*v(1)+u(2)*v(2)
11963 C-----------------------------------------------------------------------------
11965 subroutine transpose2(a,at)
11966 !DIR$ INLINEALWAYS transpose2
11968 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11971 double precision a(2,2),at(2,2)
11978 c--------------------------------------------------------------------------
11979 subroutine transpose(n,a,at)
11982 double precision a(n,n),at(n,n)
11990 C---------------------------------------------------------------------------
11991 subroutine prodmat3(a1,a2,kk,transp,prod)
11992 !DIR$ INLINEALWAYS prodmat3
11994 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11998 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12000 crc double precision auxmat(2,2),prod_(2,2)
12003 crc call transpose2(kk(1,1),auxmat(1,1))
12004 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12005 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12007 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12008 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12009 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12010 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12011 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12012 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12013 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12014 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12017 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12018 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12020 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12021 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12022 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12023 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12024 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12025 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12026 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12027 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12030 c call transpose2(a2(1,1),a2t(1,1))
12033 crc print *,((prod_(i,j),i=1,2),j=1,2)
12034 crc print *,((prod(i,j),i=1,2),j=1,2)
12038 CCC----------------------------------------------
12039 subroutine Eliptransfer(eliptran)
12040 implicit real*8 (a-h,o-z)
12041 include 'DIMENSIONS'
12042 include 'COMMON.GEO'
12043 include 'COMMON.VAR'
12044 include 'COMMON.LOCAL'
12045 include 'COMMON.CHAIN'
12046 include 'COMMON.DERIV'
12047 include 'COMMON.NAMES'
12048 include 'COMMON.INTERACT'
12049 include 'COMMON.IOUNITS'
12050 include 'COMMON.CALC'
12051 include 'COMMON.CONTROL'
12052 include 'COMMON.SPLITELE'
12053 include 'COMMON.SBRIDGE'
12054 C this is done by Adasko
12055 C print *,"wchodze"
12056 C structure of box:
12058 C--bordliptop-- buffore starts
12059 C--bufliptop--- here true lipid starts
12061 C--buflipbot--- lipid ends buffore starts
12062 C--bordlipbot--buffore ends
12064 do i=ilip_start,ilip_end
12066 if (itype(i).eq.ntyp1) cycle
12068 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12069 if (positi.le.0.0) positi=positi+boxzsize
12071 C first for peptide groups
12072 c for each residue check if it is in lipid or lipid water border area
12073 if ((positi.gt.bordlipbot)
12074 &.and.(positi.lt.bordliptop)) then
12075 C the energy transfer exist
12076 if (positi.lt.buflipbot) then
12077 C what fraction I am in
12079 & ((positi-bordlipbot)/lipbufthick)
12080 C lipbufthick is thickenes of lipid buffore
12081 sslip=sscalelip(fracinbuf)
12082 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12083 eliptran=eliptran+sslip*pepliptran
12084 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12085 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12086 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12088 C print *,"doing sccale for lower part"
12089 C print *,i,sslip,fracinbuf,ssgradlip
12090 elseif (positi.gt.bufliptop) then
12091 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12092 sslip=sscalelip(fracinbuf)
12093 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12094 eliptran=eliptran+sslip*pepliptran
12095 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12096 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12097 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12098 C print *, "doing sscalefor top part"
12099 C print *,i,sslip,fracinbuf,ssgradlip
12101 eliptran=eliptran+pepliptran
12102 C print *,"I am in true lipid"
12105 C eliptran=elpitran+0.0 ! I am in water
12108 C print *, "nic nie bylo w lipidzie?"
12109 C now multiply all by the peptide group transfer factor
12110 C eliptran=eliptran*pepliptran
12111 C now the same for side chains
12113 do i=ilip_start,ilip_end
12114 if (itype(i).eq.ntyp1) cycle
12115 positi=(mod(c(3,i+nres),boxzsize))
12116 if (positi.le.0) positi=positi+boxzsize
12117 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12118 c for each residue check if it is in lipid or lipid water border area
12119 C respos=mod(c(3,i+nres),boxzsize)
12120 C print *,positi,bordlipbot,buflipbot
12121 if ((positi.gt.bordlipbot)
12122 & .and.(positi.lt.bordliptop)) then
12123 C the energy transfer exist
12124 if (positi.lt.buflipbot) then
12126 & ((positi-bordlipbot)/lipbufthick)
12127 C lipbufthick is thickenes of lipid buffore
12128 sslip=sscalelip(fracinbuf)
12129 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12130 eliptran=eliptran+sslip*liptranene(itype(i))
12131 gliptranx(3,i)=gliptranx(3,i)
12132 &+ssgradlip*liptranene(itype(i))
12133 gliptranc(3,i-1)= gliptranc(3,i-1)
12134 &+ssgradlip*liptranene(itype(i))
12135 C print *,"doing sccale for lower part"
12136 elseif (positi.gt.bufliptop) then
12138 &((bordliptop-positi)/lipbufthick)
12139 sslip=sscalelip(fracinbuf)
12140 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12141 eliptran=eliptran+sslip*liptranene(itype(i))
12142 gliptranx(3,i)=gliptranx(3,i)
12143 &+ssgradlip*liptranene(itype(i))
12144 gliptranc(3,i-1)= gliptranc(3,i-1)
12145 &+ssgradlip*liptranene(itype(i))
12146 C print *, "doing sscalefor top part",sslip,fracinbuf
12148 eliptran=eliptran+liptranene(itype(i))
12149 C print *,"I am in true lipid"
12151 endif ! if in lipid or buffor
12153 C eliptran=elpitran+0.0 ! I am in water
12157 C---------------------------------------------------------
12158 C AFM soubroutine for constant force
12159 subroutine AFMforce(Eafmforce)
12160 implicit real*8 (a-h,o-z)
12161 include 'DIMENSIONS'
12162 include 'COMMON.GEO'
12163 include 'COMMON.VAR'
12164 include 'COMMON.LOCAL'
12165 include 'COMMON.CHAIN'
12166 include 'COMMON.DERIV'
12167 include 'COMMON.NAMES'
12168 include 'COMMON.INTERACT'
12169 include 'COMMON.IOUNITS'
12170 include 'COMMON.CALC'
12171 include 'COMMON.CONTROL'
12172 include 'COMMON.SPLITELE'
12173 include 'COMMON.SBRIDGE'
12178 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12179 dist=dist+diffafm(i)**2
12182 Eafmforce=-forceAFMconst*(dist-distafminit)
12184 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12185 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12187 C print *,'AFM',Eafmforce
12190 C---------------------------------------------------------
12191 C AFM subroutine with pseudoconstant velocity
12192 subroutine AFMvel(Eafmforce)
12193 implicit real*8 (a-h,o-z)
12194 include 'DIMENSIONS'
12195 include 'COMMON.GEO'
12196 include 'COMMON.VAR'
12197 include 'COMMON.LOCAL'
12198 include 'COMMON.CHAIN'
12199 include 'COMMON.DERIV'
12200 include 'COMMON.NAMES'
12201 include 'COMMON.INTERACT'
12202 include 'COMMON.IOUNITS'
12203 include 'COMMON.CALC'
12204 include 'COMMON.CONTROL'
12205 include 'COMMON.SPLITELE'
12206 include 'COMMON.SBRIDGE'
12208 C Only for check grad COMMENT if not used for checkgrad
12210 C--------------------------------------------------------
12211 C print *,"wchodze"
12215 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12216 dist=dist+diffafm(i)**2
12219 Eafmforce=0.5d0*forceAFMconst
12220 & *(distafminit+totTafm*velAFMconst-dist)**2
12221 C Eafmforce=-forceAFMconst*(dist-distafminit)
12223 gradafm(i,afmend-1)=-forceAFMconst*
12224 &(distafminit+totTafm*velAFMconst-dist)
12226 gradafm(i,afmbeg-1)=forceAFMconst*
12227 &(distafminit+totTafm*velAFMconst-dist)
12230 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12233 C-----------------------------------------------------------
12234 C first for shielding is setting of function of side-chains
12235 subroutine set_shield_fac
12236 implicit real*8 (a-h,o-z)
12237 include 'DIMENSIONS'
12238 include 'COMMON.CHAIN'
12239 include 'COMMON.DERIV'
12240 include 'COMMON.IOUNITS'
12241 include 'COMMON.SHIELD'
12242 include 'COMMON.INTERACT'
12243 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12244 double precision div77_81/0.974996043d0/,
12245 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12247 C the vector between center of side_chain and peptide group
12248 double precision pep_side(3),long,side_calf(3),
12249 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12250 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12251 C the line belowe needs to be changed for FGPROC>1
12253 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12255 Cif there two consequtive dummy atoms there is no peptide group between them
12256 C the line below has to be changed for FGPROC>1
12259 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12263 C first lets set vector conecting the ithe side-chain with kth side-chain
12264 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12265 C pep_side(j)=2.0d0
12266 C and vector conecting the side-chain with its proper calfa
12267 side_calf(j)=c(j,k+nres)-c(j,k)
12268 C side_calf(j)=2.0d0
12269 pept_group(j)=c(j,i)-c(j,i+1)
12270 C lets have their lenght
12271 dist_pep_side=pep_side(j)**2+dist_pep_side
12272 dist_side_calf=dist_side_calf+side_calf(j)**2
12273 dist_pept_group=dist_pept_group+pept_group(j)**2
12275 dist_pep_side=dsqrt(dist_pep_side)
12276 dist_pept_group=dsqrt(dist_pept_group)
12277 dist_side_calf=dsqrt(dist_side_calf)
12279 pep_side_norm(j)=pep_side(j)/dist_pep_side
12280 side_calf_norm(j)=dist_side_calf
12282 C now sscale fraction
12283 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12284 C print *,buff_shield,"buff"
12286 if (sh_frac_dist.le.0.0) cycle
12287 C If we reach here it means that this side chain reaches the shielding sphere
12288 C Lets add him to the list for gradient
12289 ishield_list(i)=ishield_list(i)+1
12290 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12291 C this list is essential otherwise problem would be O3
12292 shield_list(ishield_list(i),i)=k
12293 C Lets have the sscale value
12294 if (sh_frac_dist.gt.1.0) then
12295 scale_fac_dist=1.0d0
12297 sh_frac_dist_grad(j)=0.0d0
12300 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12301 & *(2.0*sh_frac_dist-3.0d0)
12302 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12303 & /dist_pep_side/buff_shield*0.5
12304 C remember for the final gradient multiply sh_frac_dist_grad(j)
12305 C for side_chain by factor -2 !
12307 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12308 C print *,"jestem",scale_fac_dist,fac_help_scale,
12309 C & sh_frac_dist_grad(j)
12312 C if ((i.eq.3).and.(k.eq.2)) then
12313 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12317 C this is what is now we have the distance scaling now volume...
12318 short=short_r_sidechain(itype(k))
12319 long=long_r_sidechain(itype(k))
12320 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12323 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12324 C costhet_fac=0.0d0
12326 costhet_grad(j)=costhet_fac*pep_side(j)
12328 C remember for the final gradient multiply costhet_grad(j)
12329 C for side_chain by factor -2 !
12330 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12331 C pep_side0pept_group is vector multiplication
12332 pep_side0pept_group=0.0
12334 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12336 cosalfa=(pep_side0pept_group/
12337 & (dist_pep_side*dist_side_calf))
12338 fac_alfa_sin=1.0-cosalfa**2
12339 fac_alfa_sin=dsqrt(fac_alfa_sin)
12340 rkprim=fac_alfa_sin*(long-short)+short
12342 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12343 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12346 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12347 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12348 &*(long-short)/fac_alfa_sin*cosalfa/
12349 &((dist_pep_side*dist_side_calf))*
12350 &((side_calf(j))-cosalfa*
12351 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12353 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12354 &*(long-short)/fac_alfa_sin*cosalfa
12355 &/((dist_pep_side*dist_side_calf))*
12357 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12360 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12363 C now the gradient...
12364 C grad_shield is gradient of Calfa for peptide groups
12365 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12367 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12368 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12370 grad_shield(j,i)=grad_shield(j,i)
12371 C gradient po skalowaniu
12372 & +(sh_frac_dist_grad(j)
12373 C gradient po costhet
12374 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12375 &-scale_fac_dist*(cosphi_grad_long(j))
12376 &/(1.0-cosphi) )*div77_81
12378 C grad_shield_side is Cbeta sidechain gradient
12379 grad_shield_side(j,ishield_list(i),i)=
12380 & (sh_frac_dist_grad(j)*(-2.0d0)
12381 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12382 & +scale_fac_dist*(cosphi_grad_long(j))
12383 & *2.0d0/(1.0-cosphi))
12384 & *div77_81*VofOverlap
12386 grad_shield_loc(j,ishield_list(i),i)=
12387 & scale_fac_dist*cosphi_grad_loc(j)
12388 & *2.0d0/(1.0-cosphi)
12389 & *div77_81*VofOverlap
12391 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12393 fac_shield(i)=VolumeTotal*div77_81+div4_81
12394 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12398 C--------------------------------------------------------------------------
12399 double precision function tschebyshev(m,n,x,y)
12401 include "DIMENSIONS"
12403 double precision x(n),y,yy(0:maxvar),aux
12404 c Tschebyshev polynomial. Note that the first term is omitted
12405 c m=0: the constant term is included
12406 c m=1: the constant term is not included
12410 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12419 C--------------------------------------------------------------------------
12420 double precision function gradtschebyshev(m,n,x,y)
12422 include "DIMENSIONS"
12424 double precision x(n+1),y,yy(0:maxvar),aux
12425 c Tschebyshev polynomial. Note that the first term is omitted
12426 c m=0: the constant term is included
12427 c m=1: the constant term is not included
12431 yy(i)=2*y*yy(i-1)-yy(i-2)
12435 aux=aux+x(i+1)*yy(i)*(i+1)
12436 C print *, x(i+1),yy(i),i
12438 gradtschebyshev=aux
12441 C------------------------------------------------------------------------
12442 C first for shielding is setting of function of side-chains
12443 subroutine set_shield_fac2
12444 implicit real*8 (a-h,o-z)
12445 include 'DIMENSIONS'
12446 include 'COMMON.CHAIN'
12447 include 'COMMON.DERIV'
12448 include 'COMMON.IOUNITS'
12449 include 'COMMON.SHIELD'
12450 include 'COMMON.INTERACT'
12451 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12452 double precision div77_81/0.974996043d0/,
12453 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12455 C the vector between center of side_chain and peptide group
12456 double precision pep_side(3),long,side_calf(3),
12457 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12458 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12459 C the line belowe needs to be changed for FGPROC>1
12461 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12463 Cif there two consequtive dummy atoms there is no peptide group between them
12464 C the line below has to be changed for FGPROC>1
12467 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12471 C first lets set vector conecting the ithe side-chain with kth side-chain
12472 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12473 C pep_side(j)=2.0d0
12474 C and vector conecting the side-chain with its proper calfa
12475 side_calf(j)=c(j,k+nres)-c(j,k)
12476 C side_calf(j)=2.0d0
12477 pept_group(j)=c(j,i)-c(j,i+1)
12478 C lets have their lenght
12479 dist_pep_side=pep_side(j)**2+dist_pep_side
12480 dist_side_calf=dist_side_calf+side_calf(j)**2
12481 dist_pept_group=dist_pept_group+pept_group(j)**2
12483 dist_pep_side=dsqrt(dist_pep_side)
12484 dist_pept_group=dsqrt(dist_pept_group)
12485 dist_side_calf=dsqrt(dist_side_calf)
12487 pep_side_norm(j)=pep_side(j)/dist_pep_side
12488 side_calf_norm(j)=dist_side_calf
12490 C now sscale fraction
12491 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12492 C print *,buff_shield,"buff"
12494 if (sh_frac_dist.le.0.0) cycle
12495 C If we reach here it means that this side chain reaches the shielding sphere
12496 C Lets add him to the list for gradient
12497 ishield_list(i)=ishield_list(i)+1
12498 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12499 C this list is essential otherwise problem would be O3
12500 shield_list(ishield_list(i),i)=k
12501 C Lets have the sscale value
12502 if (sh_frac_dist.gt.1.0) then
12503 scale_fac_dist=1.0d0
12505 sh_frac_dist_grad(j)=0.0d0
12508 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12509 & *(2.0d0*sh_frac_dist-3.0d0)
12510 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12511 & /dist_pep_side/buff_shield*0.5d0
12512 C remember for the final gradient multiply sh_frac_dist_grad(j)
12513 C for side_chain by factor -2 !
12515 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12516 C sh_frac_dist_grad(j)=0.0d0
12517 C scale_fac_dist=1.0d0
12518 C print *,"jestem",scale_fac_dist,fac_help_scale,
12519 C & sh_frac_dist_grad(j)
12522 C this is what is now we have the distance scaling now volume...
12523 short=short_r_sidechain(itype(k))
12524 long=long_r_sidechain(itype(k))
12525 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12526 sinthet=short/dist_pep_side*costhet
12530 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12531 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12532 C & -short/dist_pep_side**2/costhet)
12533 C costhet_fac=0.0d0
12535 costhet_grad(j)=costhet_fac*pep_side(j)
12537 C remember for the final gradient multiply costhet_grad(j)
12538 C for side_chain by factor -2 !
12539 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12540 C pep_side0pept_group is vector multiplication
12541 pep_side0pept_group=0.0d0
12543 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12545 cosalfa=(pep_side0pept_group/
12546 & (dist_pep_side*dist_side_calf))
12547 fac_alfa_sin=1.0d0-cosalfa**2
12548 fac_alfa_sin=dsqrt(fac_alfa_sin)
12549 rkprim=fac_alfa_sin*(long-short)+short
12553 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12555 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12556 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12557 & dist_pep_side**2)
12560 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12561 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12562 &*(long-short)/fac_alfa_sin*cosalfa/
12563 &((dist_pep_side*dist_side_calf))*
12564 &((side_calf(j))-cosalfa*
12565 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12566 C cosphi_grad_long(j)=0.0d0
12567 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12568 &*(long-short)/fac_alfa_sin*cosalfa
12569 &/((dist_pep_side*dist_side_calf))*
12571 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12572 C cosphi_grad_loc(j)=0.0d0
12574 C print *,sinphi,sinthet
12575 c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12576 c & VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12577 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12580 C now the gradient...
12582 grad_shield(j,i)=grad_shield(j,i)
12583 C gradient po skalowaniu
12584 & +(sh_frac_dist_grad(j)*VofOverlap
12585 C gradient po costhet
12586 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12587 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12588 & sinphi/sinthet*costhet*costhet_grad(j)
12589 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12591 C grad_shield_side is Cbeta sidechain gradient
12592 grad_shield_side(j,ishield_list(i),i)=
12593 & (sh_frac_dist_grad(j)*(-2.0d0)
12595 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12596 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12597 & sinphi/sinthet*costhet*costhet_grad(j)
12598 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12601 grad_shield_loc(j,ishield_list(i),i)=
12602 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12603 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12604 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12608 c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12610 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12612 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12613 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12614 c & " wshield",wshield
12615 c write(2,*) "TU",rpp(1,1),short,long,buff_shield
12619 C-----------------------------------------------------------------------
12620 C-----------------------------------------------------------
12621 C This subroutine is to mimic the histone like structure but as well can be
12622 C utilizet to nanostructures (infinit) small modification has to be used to
12623 C make it finite (z gradient at the ends has to be changes as well as the x,y
12624 C gradient has to be modified at the ends
12625 C The energy function is Kihara potential
12626 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12627 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12628 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12629 C simple Kihara potential
12630 subroutine calctube(Etube)
12631 implicit real*8 (a-h,o-z)
12632 include 'DIMENSIONS'
12633 include 'COMMON.GEO'
12634 include 'COMMON.VAR'
12635 include 'COMMON.LOCAL'
12636 include 'COMMON.CHAIN'
12637 include 'COMMON.DERIV'
12638 include 'COMMON.NAMES'
12639 include 'COMMON.INTERACT'
12640 include 'COMMON.IOUNITS'
12641 include 'COMMON.CALC'
12642 include 'COMMON.CONTROL'
12643 include 'COMMON.SPLITELE'
12644 include 'COMMON.SBRIDGE'
12645 double precision tub_r,vectube(3),enetube(maxres*2)
12650 C first we calculate the distance from tube center
12651 C first sugare-phosphate group for NARES this would be peptide group
12654 C lets ommit dummy atoms for now
12655 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12656 C now calculate distance from center of tube and direction vectors
12657 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12658 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12659 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12660 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12661 vectube(1)=vectube(1)-tubecenter(1)
12662 vectube(2)=vectube(2)-tubecenter(2)
12664 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12665 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12667 C as the tube is infinity we do not calculate the Z-vector use of Z
12670 C now calculte the distance
12671 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12672 C now normalize vector
12673 vectube(1)=vectube(1)/tub_r
12674 vectube(2)=vectube(2)/tub_r
12675 C calculte rdiffrence between r and r0
12678 rdiff6=rdiff**6.0d0
12679 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12680 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12681 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12682 C print *,rdiff,rdiff6,pep_aa_tube
12683 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12684 C now we calculate gradient
12685 fac=(-12.0d0*pep_aa_tube/rdiff6+
12686 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12687 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12690 C now direction of gg_tube vector
12692 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12693 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12696 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12698 C Lets not jump over memory as we use many times iti
12700 C lets ommit dummy atoms for now
12702 C in UNRES uncomment the line below as GLY has no side-chain...
12705 vectube(1)=c(1,i+nres)
12706 vectube(1)=mod(vectube(1),boxxsize)
12707 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12708 vectube(2)=c(2,i+nres)
12709 vectube(2)=mod(vectube(2),boxxsize)
12710 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12712 vectube(1)=vectube(1)-tubecenter(1)
12713 vectube(2)=vectube(2)-tubecenter(2)
12715 C as the tube is infinity we do not calculate the Z-vector use of Z
12718 C now calculte the distance
12719 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12720 C now normalize vector
12721 vectube(1)=vectube(1)/tub_r
12722 vectube(2)=vectube(2)/tub_r
12723 C calculte rdiffrence between r and r0
12726 rdiff6=rdiff**6.0d0
12727 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12728 sc_aa_tube=sc_aa_tube_par(iti)
12729 sc_bb_tube=sc_bb_tube_par(iti)
12730 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12731 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12732 C now we calculate gradient
12733 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12734 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12735 C now direction of gg_tube vector
12737 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12738 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12742 Etube=Etube+enetube(i)
12744 C print *,"ETUBE", etube
12747 C TO DO 1) add to total energy
12748 C 2) add to gradient summation
12749 C 3) add reading parameters (AND of course oppening of PARAM file)
12750 C 4) add reading the center of tube
12752 C 6) add to zerograd
12754 C-----------------------------------------------------------------------
12755 C-----------------------------------------------------------
12756 C This subroutine is to mimic the histone like structure but as well can be
12757 C utilizet to nanostructures (infinit) small modification has to be used to
12758 C make it finite (z gradient at the ends has to be changes as well as the x,y
12759 C gradient has to be modified at the ends
12760 C The energy function is Kihara potential
12761 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12762 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12763 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12764 C simple Kihara potential
12765 subroutine calctube2(Etube)
12766 implicit real*8 (a-h,o-z)
12767 include 'DIMENSIONS'
12768 include 'COMMON.GEO'
12769 include 'COMMON.VAR'
12770 include 'COMMON.LOCAL'
12771 include 'COMMON.CHAIN'
12772 include 'COMMON.DERIV'
12773 include 'COMMON.NAMES'
12774 include 'COMMON.INTERACT'
12775 include 'COMMON.IOUNITS'
12776 include 'COMMON.CALC'
12777 include 'COMMON.CONTROL'
12778 include 'COMMON.SPLITELE'
12779 include 'COMMON.SBRIDGE'
12780 double precision tub_r,vectube(3),enetube(maxres*2)
12785 C first we calculate the distance from tube center
12786 C first sugare-phosphate group for NARES this would be peptide group
12789 C lets ommit dummy atoms for now
12790 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12791 C now calculate distance from center of tube and direction vectors
12792 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12793 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12794 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12795 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12796 vectube(1)=vectube(1)-tubecenter(1)
12797 vectube(2)=vectube(2)-tubecenter(2)
12799 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12800 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12802 C as the tube is infinity we do not calculate the Z-vector use of Z
12805 C now calculte the distance
12806 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12807 C now normalize vector
12808 vectube(1)=vectube(1)/tub_r
12809 vectube(2)=vectube(2)/tub_r
12810 C calculte rdiffrence between r and r0
12813 rdiff6=rdiff**6.0d0
12814 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12815 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12816 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12817 C print *,rdiff,rdiff6,pep_aa_tube
12818 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12819 C now we calculate gradient
12820 fac=(-12.0d0*pep_aa_tube/rdiff6+
12821 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12822 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12825 C now direction of gg_tube vector
12827 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12828 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12831 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12833 C Lets not jump over memory as we use many times iti
12835 C lets ommit dummy atoms for now
12837 C in UNRES uncomment the line below as GLY has no side-chain...
12840 vectube(1)=c(1,i+nres)
12841 vectube(1)=mod(vectube(1),boxxsize)
12842 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12843 vectube(2)=c(2,i+nres)
12844 vectube(2)=mod(vectube(2),boxxsize)
12845 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12847 vectube(1)=vectube(1)-tubecenter(1)
12848 vectube(2)=vectube(2)-tubecenter(2)
12849 C THIS FRAGMENT MAKES TUBE FINITE
12850 positi=(mod(c(3,i+nres),boxzsize))
12851 if (positi.le.0) positi=positi+boxzsize
12852 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12853 c for each residue check if it is in lipid or lipid water border area
12854 C respos=mod(c(3,i+nres),boxzsize)
12855 print *,positi,bordtubebot,buftubebot,bordtubetop
12856 if ((positi.gt.bordtubebot)
12857 & .and.(positi.lt.bordtubetop)) then
12858 C the energy transfer exist
12859 if (positi.lt.buftubebot) then
12861 & ((positi-bordtubebot)/tubebufthick)
12862 C lipbufthick is thickenes of lipid buffore
12863 sstube=sscalelip(fracinbuf)
12864 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12865 print *,ssgradtube, sstube,tubetranene(itype(i))
12866 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12867 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12868 &+ssgradtube*tubetranene(itype(i))
12869 gg_tube(3,i-1)= gg_tube(3,i-1)
12870 &+ssgradtube*tubetranene(itype(i))
12871 C print *,"doing sccale for lower part"
12872 elseif (positi.gt.buftubetop) then
12874 &((bordtubetop-positi)/tubebufthick)
12875 sstube=sscalelip(fracinbuf)
12876 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12877 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12878 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12879 C &+ssgradtube*tubetranene(itype(i))
12880 C gg_tube(3,i-1)= gg_tube(3,i-1)
12881 C &+ssgradtube*tubetranene(itype(i))
12882 C print *, "doing sscalefor top part",sslip,fracinbuf
12886 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12887 C print *,"I am in true lipid"
12893 endif ! if in lipid or buffor
12894 CEND OF FINITE FRAGMENT
12895 C as the tube is infinity we do not calculate the Z-vector use of Z
12898 C now calculte the distance
12899 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12900 C now normalize vector
12901 vectube(1)=vectube(1)/tub_r
12902 vectube(2)=vectube(2)/tub_r
12903 C calculte rdiffrence between r and r0
12906 rdiff6=rdiff**6.0d0
12907 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12908 sc_aa_tube=sc_aa_tube_par(iti)
12909 sc_bb_tube=sc_bb_tube_par(iti)
12910 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12911 & *sstube+enetube(i+nres)
12912 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12913 C now we calculate gradient
12914 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12915 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12916 C now direction of gg_tube vector
12918 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12919 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12921 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12922 &+ssgradtube*enetube(i+nres)/sstube
12923 gg_tube(3,i-1)= gg_tube(3,i-1)
12924 &+ssgradtube*enetube(i+nres)/sstube
12928 Etube=Etube+enetube(i)
12930 C print *,"ETUBE", etube
12933 C TO DO 1) add to total energy
12934 C 2) add to gradient summation
12935 C 3) add reading parameters (AND of course oppening of PARAM file)
12936 C 4) add reading the center of tube
12938 C 6) add to zerograd
12939 c----------------------------------------------------------------------------
12940 subroutine e_saxs(Esaxs_constr)
12942 include 'DIMENSIONS'
12945 include "COMMON.SETUP"
12948 include 'COMMON.SBRIDGE'
12949 include 'COMMON.CHAIN'
12950 include 'COMMON.GEO'
12951 include 'COMMON.DERIV'
12952 include 'COMMON.LOCAL'
12953 include 'COMMON.INTERACT'
12954 include 'COMMON.VAR'
12955 include 'COMMON.IOUNITS'
12956 include 'COMMON.MD'
12957 include 'COMMON.CONTROL'
12958 include 'COMMON.NAMES'
12959 include 'COMMON.TIME1'
12960 include 'COMMON.FFIELD'
12962 double precision Esaxs_constr
12963 integer i,iint,j,k,l
12964 double precision PgradC(maxSAXS,3,maxres),
12965 & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12967 double precision PgradC_(maxSAXS,3,maxres),
12968 & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12970 double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12971 & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12972 & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12973 & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12974 double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12975 double precision dist,mygauss,mygaussder
12977 integer llicz,lllicz
12978 double precision time01
12979 c SAXS restraint penalty function
12981 write(iout,*) "------- SAXS penalty function start -------"
12982 write (iout,*) "nsaxs",nsaxs
12983 write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12984 write (iout,*) "Psaxs"
12986 write (iout,'(i5,e15.5)') i, Psaxs(i)
12992 Esaxs_constr = 0.0d0
12997 PgradC(k,l,j)=0.0d0
12998 PgradX(k,l,j)=0.0d0
13003 do i=iatsc_s,iatsc_e
13004 if (itype(i).eq.ntyp1) cycle
13005 do iint=1,nint_gr(i)
13006 do j=istart(i,iint),iend(i,iint)
13007 if (itype(j).eq.ntyp1) cycle
13010 dijCASC=dist(i,j+nres)
13011 dijSCCA=dist(i+nres,j)
13012 dijSCSC=dist(i+nres,j+nres)
13013 sigma2CACA=2.0d0/(pstok**2)
13014 sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13015 sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13016 sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13019 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13020 if (itype(j).ne.10) then
13021 expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13025 if (itype(i).ne.10) then
13026 expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13030 if (itype(i).ne.10 .and. itype(j).ne.10) then
13031 expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13035 Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13037 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13039 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13040 CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13041 SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13042 SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13045 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13046 PgradC(k,l,i) = PgradC(k,l,i)-aux
13047 PgradC(k,l,j) = PgradC(k,l,j)+aux
13049 if (itype(j).ne.10) then
13050 aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13051 PgradC(k,l,i) = PgradC(k,l,i)-aux
13052 PgradC(k,l,j) = PgradC(k,l,j)+aux
13053 PgradX(k,l,j) = PgradX(k,l,j)+aux
13056 if (itype(i).ne.10) then
13057 aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13058 PgradX(k,l,i) = PgradX(k,l,i)-aux
13059 PgradC(k,l,i) = PgradC(k,l,i)-aux
13060 PgradC(k,l,j) = PgradC(k,l,j)+aux
13063 if (itype(i).ne.10 .and. itype(j).ne.10) then
13064 aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13065 PgradC(k,l,i) = PgradC(k,l,i)-aux
13066 PgradC(k,l,j) = PgradC(k,l,j)+aux
13067 PgradX(k,l,i) = PgradX(k,l,i)-aux
13068 PgradX(k,l,j) = PgradX(k,l,j)+aux
13074 sigma2CACA=scal_rad**2*0.25d0/
13075 & (restok(itype(j))**2+restok(itype(i))**2)
13076 c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13077 c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13079 sigmaCACA=dsqrt(sigma2CACA)
13080 threesig=3.0d0/sigmaCACA
13084 if (dabs(dijCACA-dk).ge.threesig) cycle
13087 aux = sigmaCACA*(dijCACA-dk)
13088 expCACA = mygauss(aux)
13089 c if (expcaca.eq.0.0d0) cycle
13090 Pcalc(k) = Pcalc(k)+expCACA
13091 CACAgrad = -sigmaCACA*mygaussder(aux)
13092 c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13094 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13095 PgradC(k,l,i) = PgradC(k,l,i)-aux
13096 PgradC(k,l,j) = PgradC(k,l,j)+aux
13099 c write (iout,*) "i",i," j",j," llicz",llicz
13101 IF (saxs_cutoff.eq.0) THEN
13104 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13105 Pcalc(k) = Pcalc(k)+expCACA
13106 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13108 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13109 PgradC(k,l,i) = PgradC(k,l,i)-aux
13110 PgradC(k,l,j) = PgradC(k,l,j)+aux
13114 rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13117 c write (2,*) "ijk",i,j,k
13118 sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13119 if (sss2.eq.0.0d0) cycle
13120 ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13121 if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13122 & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13123 & 1.0d0/dsqrt(sigma2CACA),rrr,dk,
13125 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13126 Pcalc(k) = Pcalc(k)+expCACA
13128 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13130 CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13131 & ssgrad2*expCACA/sss2
13134 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13135 PgradC(k,l,i) = PgradC(k,l,i)+aux
13136 PgradC(k,l,j) = PgradC(k,l,j)-aux
13146 c time_SAXS=time_SAXS+MPI_Wtime()-time01
13148 c write (iout,*) "lllicz",lllicz
13150 c time01=MPI_Wtime()
13153 if (nfgtasks.gt.1) then
13154 call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13155 & MPI_SUM,FG_COMM,IERR)
13156 c if (fg_rank.eq.king) then
13158 Pcalc(k) = Pcalc_(k)
13161 c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13162 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13163 c if (fg_rank.eq.king) then
13167 c PgradC(k,l,i) = PgradC_(k,l,i)
13173 c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13174 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13175 c if (fg_rank.eq.king) then
13179 c PgradX(k,l,i) = PgradX_(k,l,i)
13189 Cnorm = Cnorm + Pcalc(k)
13192 if (fg_rank.eq.king) then
13194 Esaxs_constr = dlog(Cnorm)-wsaxs0
13196 if (Pcalc(k).gt.0.0d0)
13197 & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13199 write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13203 write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13218 & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13219 auxC1 = auxC1+PgradC(k,l,i)
13221 auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13222 auxX1 = auxX1+PgradX(k,l,i)
13225 gsaxsC(l,i) = auxC - auxC1/Cnorm
13227 gsaxsX(l,i) = auxX - auxX1/Cnorm
13229 c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13230 c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
13231 c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13232 c * " gradX",wsaxs*gsaxsX(l,i)
13236 time_SAXS=time_SAXS+MPI_Wtime()-time01
13239 write (iout,*) "gsaxsc"
13241 write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13249 c----------------------------------------------------------------------------
13250 subroutine e_saxsC(Esaxs_constr)
13252 include 'DIMENSIONS'
13255 include "COMMON.SETUP"
13258 include 'COMMON.SBRIDGE'
13259 include 'COMMON.CHAIN'
13260 include 'COMMON.GEO'
13261 include 'COMMON.DERIV'
13262 include 'COMMON.LOCAL'
13263 include 'COMMON.INTERACT'
13264 include 'COMMON.VAR'
13265 include 'COMMON.IOUNITS'
13266 include 'COMMON.MD'
13267 include 'COMMON.CONTROL'
13268 include 'COMMON.NAMES'
13269 include 'COMMON.TIME1'
13270 include 'COMMON.FFIELD'
13272 double precision Esaxs_constr
13273 integer i,iint,j,k,l
13274 double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13276 double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13278 double precision dk,dijCASPH,dijSCSPH,
13279 & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13280 & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13282 c SAXS restraint penalty function
13284 write(iout,*) "------- SAXS penalty function start -------"
13285 write (iout,*) "nsaxs",nsaxs
13288 print *,MyRank,"C",i,(C(j,i),j=1,3)
13291 print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13294 Esaxs_constr = 0.0d0
13296 do j=isaxs_start,isaxs_end
13305 if (itype(i).eq.ntyp1) cycle
13309 dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13311 if (itype(i).ne.10) then
13313 dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13316 sigma2CA=2.0d0/pstok**2
13317 sigma2SC=4.0d0/restok(itype(i))**2
13318 expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13319 expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13320 Pcalc = Pcalc+expCASPH+expSCSPH
13322 write(*,*) "processor i j Pcalc",
13323 & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13325 CASPHgrad = sigma2CA*expCASPH
13326 SCSPHgrad = sigma2SC*expSCSPH
13328 aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13329 PgradX(l,i) = PgradX(l,i) + aux
13330 PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13335 gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13336 gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13339 logPtot = logPtot - dlog(Pcalc)
13340 c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13341 c & " logPtot",logPtot
13344 if (nfgtasks.gt.1) then
13345 c write (iout,*) "logPtot before reduction",logPtot
13346 call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13347 & MPI_SUM,king,FG_COMM,IERR)
13349 c write (iout,*) "logPtot after reduction",logPtot
13350 call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13351 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13352 if (fg_rank.eq.king) then
13355 gsaxsC(l,i) = gsaxsC_(l,i)
13359 call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13360 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13361 if (fg_rank.eq.king) then
13364 gsaxsX(l,i) = gsaxsX_(l,i)
13370 Esaxs_constr = logPtot
13373 c----------------------------------------------------------------------------
13374 double precision function sscale2(r,r_cut,r0,rlamb)
13376 double precision r,gamm,r_cut,r0,rlamb,rr
13378 c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13379 c write (2,*) "rr",rr
13380 if(rr.lt.r_cut-rlamb) then
13382 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13383 gamm=(rr-(r_cut-rlamb))/rlamb
13384 sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13390 C-----------------------------------------------------------------------
13391 double precision function sscalgrad2(r,r_cut,r0,rlamb)
13393 double precision r,gamm,r_cut,r0,rlamb,rr
13395 if(rr.lt.r_cut-rlamb) then
13397 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13398 gamm=(rr-(r_cut-rlamb))/rlamb
13400 sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13402 sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb