1 subroutine etotal(energia)
7 cMS$ATTRIBUTES C :: proc_proc
12 double precision weights_(n_ene)
13 double precision time00
16 include 'COMMON.SETUP'
17 include 'COMMON.IOUNITS'
18 double precision energia(0:n_ene)
19 include 'COMMON.LOCAL'
20 include 'COMMON.FFIELD'
21 include 'COMMON.DERIV'
22 include 'COMMON.INTERACT'
23 include 'COMMON.SBRIDGE'
24 include 'COMMON.CHAIN'
27 include 'COMMON.QRESTR'
28 include 'COMMON.CONTROL'
29 include 'COMMON.TIME1'
30 include 'COMMON.SPLITELE'
31 include 'COMMON.TORCNSTR'
33 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
34 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
35 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
36 & eliptran,Eafmforce,Etube,
37 & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
38 integer n_corr,n_corr1
40 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
41 c & " nfgtasks",nfgtasks
42 if (nfgtasks.gt.1) then
44 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
45 if (fg_rank.eq.0) then
46 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
47 c print *,"Processor",myrank," BROADCAST iorder"
48 C FG master sets up the WEIGHTS_ array which will be broadcast to the
49 C FG slaves as WEIGHTS array.
71 weights_(28)=wdfa_dist
74 weights_(31)=wdfa_beta
75 C FG Master broadcasts the WEIGHTS_ array
76 call MPI_Bcast(weights_(1),n_ene,
77 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
79 C FG slaves receive the WEIGHTS array
80 call MPI_Bcast(weights(1),n_ene,
81 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
103 wdfa_dist=weights_(28)
104 wdfa_tor=weights_(29)
105 wdfa_nei=weights_(30)
106 wdfa_beta=weights_(31)
108 time_Bcast=time_Bcast+MPI_Wtime()-time00
109 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
110 c call chainbuild_cart
118 c print *,'Processor',myrank,' calling etotal ipot=',ipot
119 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
121 c if (modecalc.eq.12.or.modecalc.eq.14) then
122 c call int_from_cart1(.false.)
129 C Compute the side-chain and electrostatic interaction energy
132 goto (101,102,103,104,105,106) ipot
133 C Lennard-Jones potential.
135 cd print '(a)','Exit ELJ'
137 C Lennard-Jones-Kihara potential (shifted).
140 C Berne-Pechukas potential (dilated LJ, angular dependence).
143 C Gay-Berne potential (shifted LJ, angular dependence).
145 C print *,"bylem w egb"
147 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
150 C Soft-sphere potential
151 106 call e_softsphere(evdw)
153 C Calculate electrostatic (H-bonding) energy of the main chain.
157 C BARTEK for dfa test!
158 if (wdfa_dist.gt.0) then
163 c print*, 'edfad is finished!', edfadis
164 if (wdfa_tor.gt.0) then
169 c print*, 'edfat is finished!', edfator
170 if (wdfa_nei.gt.0) then
175 c print*, 'edfan is finished!', edfanei
176 if (wdfa_beta.gt.0) then
183 cmc Sep-06: egb takes care of dynamic ss bonds too
185 c if (dyn_ss) call dyn_set_nss
187 c print *,"Processor",myrank," computed USCSC"
193 time_vec=time_vec+MPI_Wtime()-time01
195 C Introduction of shielding effect first for each peptide group
196 C the shielding factor is set this factor is describing how each
197 C peptide group is shielded by side-chains
198 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
199 C write (iout,*) "shield_mode",shield_mode
200 if (shield_mode.eq.1) then
202 else if (shield_mode.eq.2) then
205 c print *,"Processor",myrank," left VEC_AND_DERIV"
208 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
209 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
210 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
211 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
213 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
214 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
215 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
216 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
218 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
227 write (iout,*) "Soft-spheer ELEC potential"
228 c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
232 c time_enecalc=time_enecalc+MPI_Wtime()-time00
234 c print *,"Processor",myrank," computed UELEC"
236 C Calculate excluded-volume interaction energy between peptide groups
241 call escp(evdw2,evdw2_14)
247 c write (iout,*) "Soft-sphere SCP potential"
248 call escp_soft_sphere(evdw2,evdw2_14)
251 c Calculate the bond-stretching energy
255 C Calculate the disulfide-bridge and other energy and the contributions
256 C from other distance constraints.
257 cd write (iout,*) 'Calling EHPB'
259 cd print *,'EHPB exitted succesfully.'
261 C Calculate the virtual-bond-angle energy.
263 if (wang.gt.0d0) then
264 if (tor_mode.eq.0) then
267 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
275 if (with_theta_constr) call etheta_constr(ethetacnstr)
276 c print *,"Processor",myrank," computed UB"
278 C Calculate the SC local energy.
280 C print *,"TU DOCHODZE?"
282 c print *,"Processor",myrank," computed USC"
284 C Calculate the virtual-bond torsional energy.
286 cd print *,'nterm=',nterm
287 C print *,"tor",tor_mode
288 if (wtor.gt.0.0d0) then
289 if (tor_mode.eq.0) then
292 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
300 if (ndih_constr.gt.0) call etor_constr(edihcnstr)
301 c print *,"Processor",myrank," computed Utor"
302 if (constr_homology.ge.1) then
303 call e_modeller(ehomology_constr)
304 c print *,'iset=',iset,'me=',me,ehomology_constr,
305 c & 'Processor',fg_rank,' CG group',kolor,
306 c & ' absolute rank',MyRank
308 ehomology_constr=0.0d0
311 C 6/23/01 Calculate double-torsional energy
313 if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
318 c print *,"Processor",myrank," computed Utord"
320 C 21/5/07 Calculate local sicdechain correlation energy
322 if (wsccor.gt.0.0d0) then
323 call eback_sc_corr(esccor)
328 C print *,"PRZED MULIt"
329 c print *,"Processor",myrank," computed Usccorr"
331 C 12/1/95 Multi-body terms
335 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
336 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
337 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
338 c write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
339 c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
347 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
348 c write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
351 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
352 c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
357 c print *,"Processor",myrank," computed Ucorr"
358 c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
359 if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
360 call e_saxs(Esaxs_constr)
361 c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
362 else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
363 call e_saxsC(Esaxs_constr)
364 c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
369 C If performing constraint dynamics, call the constraint energy
370 C after the equilibration time
371 c if(usampl.and.totT.gt.eq_time) then
372 c write (iout,*) "usampl",usampl
376 call Econstr_back_qlike
384 C 01/27/2015 added by adasko
385 C the energy component below is energy transfer into lipid environment
386 C based on partition function
387 C print *,"przed lipidami"
388 if (wliptran.gt.0) then
389 call Eliptransfer(eliptran)
391 C print *,"za lipidami"
392 if (AFMlog.gt.0) then
393 call AFMforce(Eafmforce)
394 else if (selfguide.gt.0) then
395 call AFMvel(Eafmforce)
397 if (TUBElog.eq.1) then
398 C print *,"just before call"
400 elseif (TUBElog.eq.2) then
401 call calctube2(Etube)
407 time_enecalc=time_enecalc+MPI_Wtime()-time00
409 c print *,"Processor",myrank," computed Uconstr"
418 energia(2)=evdw2-evdw2_14
435 energia(8)=eello_turn3
436 energia(9)=eello_turn4
443 energia(19)=edihcnstr
445 energia(20)=Uconst+Uconst_back
448 energia(23)=Eafmforce
449 energia(24)=ethetacnstr
451 energia(26)=Esaxs_constr
452 energia(27)=ehomology_constr
457 c write (iout,*) "esaxs_constr",energia(26)
458 c Here are the energies showed per procesor if the are more processors
459 c per molecule then we sum it up in sum_energy subroutine
460 c print *," Processor",myrank," calls SUM_ENERGY"
461 call sum_energy(energia,.true.)
462 c write (iout,*) "After sum_energy: esaxs_constr",energia(26)
463 if (dyn_ss) call dyn_set_nss
464 c print *," Processor",myrank," left SUM_ENERGY"
466 time_sumene=time_sumene+MPI_Wtime()-time00
470 c-------------------------------------------------------------------------------
471 subroutine sum_energy(energia,reduce)
477 cMS$ATTRIBUTES C :: proc_proc
483 double precision time00
485 include 'COMMON.SETUP'
486 include 'COMMON.IOUNITS'
487 double precision energia(0:n_ene),enebuff(0:n_ene+1)
488 include 'COMMON.FFIELD'
489 include 'COMMON.DERIV'
490 include 'COMMON.INTERACT'
491 include 'COMMON.SBRIDGE'
492 include 'COMMON.CHAIN'
494 include 'COMMON.CONTROL'
495 include 'COMMON.TIME1'
498 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
499 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
500 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
501 & eliptran,Eafmforce,Etube,
502 & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
503 double precision Uconst,etot
505 if (nfgtasks.gt.1 .and. reduce) then
507 write (iout,*) "energies before REDUCE"
508 call enerprint(energia)
512 enebuff(i)=energia(i)
515 call MPI_Barrier(FG_COMM,IERR)
516 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
518 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
519 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
521 write (iout,*) "energies after REDUCE"
522 call enerprint(energia)
525 time_Reduce=time_Reduce+MPI_Wtime()-time00
527 if (fg_rank.eq.0) then
531 evdw2=energia(2)+energia(18)
547 eello_turn3=energia(8)
548 eello_turn4=energia(9)
555 edihcnstr=energia(19)
560 Eafmforce=energia(23)
561 ethetacnstr=energia(24)
563 esaxs_constr=energia(26)
564 ehomology_constr=energia(27)
570 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
571 & +wang*ebe+wtor*etors+wscloc*escloc
572 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
573 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
574 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
575 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
576 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
577 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
580 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
581 & +wang*ebe+wtor*etors+wscloc*escloc
582 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
583 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
584 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
585 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
587 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
588 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
595 if (isnan(etot).ne.0) energia(0)=1.0d+99
597 if (isnan(etot)) energia(0)=1.0d+99
602 idumm=proc_proc(etot,i)
604 call proc_proc(etot,i)
606 if(i.eq.1)energia(0)=1.0d+99
613 c-------------------------------------------------------------------------------
614 subroutine sum_gradient
620 cMS$ATTRIBUTES C :: proc_proc
626 double precision time00,time01
628 double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
629 & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
630 & ,gloc_scbuf(3,-1:maxres)
631 include 'COMMON.SETUP'
632 include 'COMMON.IOUNITS'
633 include 'COMMON.FFIELD'
634 include 'COMMON.DERIV'
635 include 'COMMON.INTERACT'
636 include 'COMMON.SBRIDGE'
637 include 'COMMON.CHAIN'
639 include 'COMMON.CONTROL'
640 include 'COMMON.TIME1'
641 include 'COMMON.MAXGRAD'
642 include 'COMMON.SCCOR'
643 c include 'COMMON.MD'
644 include 'COMMON.QRESTR'
646 double precision scalar
647 double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
648 &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
649 &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
650 &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
651 &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
657 write (iout,*) "sum_gradient gvdwc, gvdwx"
659 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
660 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
665 write (iout,*) "sum_gradient gsaxsc, gsaxsx"
667 write (iout,'(i3,3e15.5,5x,3e15.5)')
668 & i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
673 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
674 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
675 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
678 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
679 C in virtual-bond-vector coordinates
682 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
684 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
685 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
687 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
689 c write (iout,'(i5,3f10.5,2x,f10.5)')
690 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
692 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
694 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
695 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
701 write (iout,*) "gsaxsc"
703 write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
710 gradbufc(j,i)=wsc*gvdwc(j,i)+
711 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
712 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
713 & wel_loc*gel_loc_long(j,i)+
714 & wcorr*gradcorr_long(j,i)+
715 & wcorr5*gradcorr5_long(j,i)+
716 & wcorr6*gradcorr6_long(j,i)+
717 & wturn6*gcorr6_turn_long(j,i)+
719 & +wliptran*gliptranc(j,i)
721 & +welec*gshieldc(j,i)
722 & +wcorr*gshieldc_ec(j,i)
723 & +wturn3*gshieldc_t3(j,i)
724 & +wturn4*gshieldc_t4(j,i)
725 & +wel_loc*gshieldc_ll(j,i)
726 & +wtube*gg_tube(j,i)
733 gradbufc(j,i)=wsc*gvdwc(j,i)+
734 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
735 & welec*gelc_long(j,i)+
737 & wel_loc*gel_loc_long(j,i)+
738 & wcorr*gradcorr_long(j,i)+
739 & wcorr5*gradcorr5_long(j,i)+
740 & wcorr6*gradcorr6_long(j,i)+
741 & wturn6*gcorr6_turn_long(j,i)+
743 & +wliptran*gliptranc(j,i)
745 & +welec*gshieldc(j,i)
746 & +wcorr*gshieldc_ec(j,i)
747 & +wturn4*gshieldc_t4(j,i)
748 & +wel_loc*gshieldc_ll(j,i)
749 & +wtube*gg_tube(j,i)
756 gradbufc(j,i)=gradbufc(j,i)+
757 & wdfa_dist*gdfad(j,i)+
758 & wdfa_tor*gdfat(j,i)+
759 & wdfa_nei*gdfan(j,i)+
760 & wdfa_beta*gdfab(j,i)
764 write (iout,*) "gradc from gradbufc"
766 write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
771 if (nfgtasks.gt.1) then
774 write (iout,*) "gradbufc before allreduce"
776 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
782 gradbufc_sum(j,i)=gradbufc(j,i)
785 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
786 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
787 c time_reduce=time_reduce+MPI_Wtime()-time00
789 c write (iout,*) "gradbufc_sum after allreduce"
791 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
796 c time_allreduce=time_allreduce+MPI_Wtime()-time00
804 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
805 write (iout,*) (i," jgrad_start",jgrad_start(i),
806 & " jgrad_end ",jgrad_end(i),
807 & i=igrad_start,igrad_end)
810 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
811 c do not parallelize this part.
813 c do i=igrad_start,igrad_end
814 c do j=jgrad_start(i),jgrad_end(i)
816 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
821 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
825 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
829 write (iout,*) "gradbufc after summing"
831 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
838 write (iout,*) "gradbufc"
840 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
846 gradbufc_sum(j,i)=gradbufc(j,i)
851 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
855 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
860 c gradbufc(k,i)=0.0d0
864 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
869 write (iout,*) "gradbufc after summing"
871 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
879 gradbufc(k,nres)=0.0d0
884 C print *,gradbufc(1,13)
885 C print *,welec*gelc(1,13)
886 C print *,wel_loc*gel_loc(1,13)
887 C print *,0.5d0*(wscp*gvdwc_scpp(1,13))
888 C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
889 C print *,wel_loc*gel_loc_long(1,13)
890 C print *,gradafm(1,13),"AFM"
891 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
892 & wel_loc*gel_loc(j,i)+
893 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
894 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
895 & wel_loc*gel_loc_long(j,i)+
896 & wcorr*gradcorr_long(j,i)+
897 & wcorr5*gradcorr5_long(j,i)+
898 & wcorr6*gradcorr6_long(j,i)+
899 & wturn6*gcorr6_turn_long(j,i))+
901 & wcorr*gradcorr(j,i)+
902 & wturn3*gcorr3_turn(j,i)+
903 & wturn4*gcorr4_turn(j,i)+
904 & wcorr5*gradcorr5(j,i)+
905 & wcorr6*gradcorr6(j,i)+
906 & wturn6*gcorr6_turn(j,i)+
907 & wsccor*gsccorc(j,i)
908 & +wscloc*gscloc(j,i)
909 & +wliptran*gliptranc(j,i)
911 & +welec*gshieldc(j,i)
912 & +welec*gshieldc_loc(j,i)
913 & +wcorr*gshieldc_ec(j,i)
914 & +wcorr*gshieldc_loc_ec(j,i)
915 & +wturn3*gshieldc_t3(j,i)
916 & +wturn3*gshieldc_loc_t3(j,i)
917 & +wturn4*gshieldc_t4(j,i)
918 & +wturn4*gshieldc_loc_t4(j,i)
919 & +wel_loc*gshieldc_ll(j,i)
920 & +wel_loc*gshieldc_loc_ll(j,i)
921 & +wtube*gg_tube(j,i)
924 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
925 & wel_loc*gel_loc(j,i)+
926 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
927 & welec*gelc_long(j,i)+
928 & wel_loc*gel_loc_long(j,i)+
929 & wcorr*gcorr_long(j,i)+
930 & wcorr5*gradcorr5_long(j,i)+
931 & wcorr6*gradcorr6_long(j,i)+
932 & wturn6*gcorr6_turn_long(j,i))+
934 & wcorr*gradcorr(j,i)+
935 & wturn3*gcorr3_turn(j,i)+
936 & wturn4*gcorr4_turn(j,i)+
937 & wcorr5*gradcorr5(j,i)+
938 & wcorr6*gradcorr6(j,i)+
939 & wturn6*gcorr6_turn(j,i)+
940 & wsccor*gsccorc(j,i)
941 & +wscloc*gscloc(j,i)
942 & +wliptran*gliptranc(j,i)
944 & +welec*gshieldc(j,i)
945 & +welec*gshieldc_loc(j,i)
946 & +wcorr*gshieldc_ec(j,i)
947 & +wcorr*gshieldc_loc_ec(j,i)
948 & +wturn3*gshieldc_t3(j,i)
949 & +wturn3*gshieldc_loc_t3(j,i)
950 & +wturn4*gshieldc_t4(j,i)
951 & +wturn4*gshieldc_loc_t4(j,i)
952 & +wel_loc*gshieldc_ll(j,i)
953 & +wel_loc*gshieldc_loc_ll(j,i)
954 & +wtube*gg_tube(j,i)
958 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
960 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
961 & wsccor*gsccorx(j,i)
962 & +wscloc*gsclocx(j,i)
963 & +wliptran*gliptranx(j,i)
964 & +welec*gshieldx(j,i)
965 & +wcorr*gshieldx_ec(j,i)
966 & +wturn3*gshieldx_t3(j,i)
967 & +wturn4*gshieldx_t4(j,i)
968 & +wel_loc*gshieldx_ll(j,i)
969 & +wtube*gg_tube_sc(j,i)
976 if (constr_homology.gt.0) then
979 gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
980 gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
985 write (iout,*) "gradc gradx gloc after adding"
987 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
988 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
992 write (iout,*) "gloc before adding corr"
994 write (iout,*) i,gloc(i,icg)
998 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
999 & +wcorr5*g_corr5_loc(i)
1000 & +wcorr6*g_corr6_loc(i)
1001 & +wturn4*gel_loc_turn4(i)
1002 & +wturn3*gel_loc_turn3(i)
1003 & +wturn6*gel_loc_turn6(i)
1004 & +wel_loc*gel_loc_loc(i)
1007 write (iout,*) "gloc after adding corr"
1009 write (iout,*) i,gloc(i,icg)
1013 if (nfgtasks.gt.1) then
1016 gradbufc(j,i)=gradc(j,i,icg)
1017 gradbufx(j,i)=gradx(j,i,icg)
1021 glocbuf(i)=gloc(i,icg)
1025 write (iout,*) "gloc_sc before reduce"
1028 write (iout,*) i,j,gloc_sc(j,i,icg)
1035 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1039 call MPI_Barrier(FG_COMM,IERR)
1040 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1042 call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
1043 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1044 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1045 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1046 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1047 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1048 time_reduce=time_reduce+MPI_Wtime()-time00
1049 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1050 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1051 time_reduce=time_reduce+MPI_Wtime()-time00
1053 write (iout,*) "gradc after reduce"
1056 write (iout,*) i,j,gradc(j,i,icg)
1061 write (iout,*) "gloc_sc after reduce"
1064 write (iout,*) i,j,gloc_sc(j,i,icg)
1069 write (iout,*) "gloc after reduce"
1071 write (iout,*) i,gloc(i,icg)
1076 if (gnorm_check) then
1078 c Compute the maximum elements of the gradient
1088 gcorr3_turn_max=0.0d0
1089 gcorr4_turn_max=0.0d0
1092 gcorr6_turn_max=0.0d0
1102 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1103 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1104 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1105 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1106 & gvdwc_scp_max=gvdwc_scp_norm
1107 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1108 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1109 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1110 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1111 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1112 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1113 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1114 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1115 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1116 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1117 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1118 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1119 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1120 & gcorr3_turn(1,i)))
1121 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1122 & gcorr3_turn_max=gcorr3_turn_norm
1123 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1124 & gcorr4_turn(1,i)))
1125 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1126 & gcorr4_turn_max=gcorr4_turn_norm
1127 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1128 if (gradcorr5_norm.gt.gradcorr5_max)
1129 & gradcorr5_max=gradcorr5_norm
1130 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1131 if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1132 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1133 & gcorr6_turn(1,i)))
1134 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1135 & gcorr6_turn_max=gcorr6_turn_norm
1136 gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1137 if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1138 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1139 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1140 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1141 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1142 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1143 if (gradx_scp_norm.gt.gradx_scp_max)
1144 & gradx_scp_max=gradx_scp_norm
1145 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1146 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1147 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1148 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1149 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1150 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1151 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1152 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1155 #if (defined AIX || defined CRAY)
1156 open(istat,file=statname,position="append")
1158 open(istat,file=statname,access="append")
1160 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1161 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1162 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1163 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1164 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1165 & gsccorrx_max,gsclocx_max
1167 if (gvdwc_max.gt.1.0d4) then
1168 write (iout,*) "gvdwc gvdwx gradb gradbx"
1170 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1171 & gradb(j,i),gradbx(j,i),j=1,3)
1173 call pdbout(0.0d0,'cipiszcze',iout)
1179 write (iout,*) "gradc gradx gloc"
1181 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1182 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1186 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1190 c-------------------------------------------------------------------------------
1191 subroutine rescale_weights(t_bath)
1197 include 'DIMENSIONS'
1198 include 'COMMON.IOUNITS'
1199 include 'COMMON.FFIELD'
1200 include 'COMMON.SBRIDGE'
1201 include 'COMMON.CONTROL'
1202 double precision t_bath
1203 double precision facT,facT2,facT3,facT4,facT5
1204 double precision kfac /2.4d0/
1205 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1207 c facT=2*temp0/(t_bath+temp0)
1208 if (rescale_mode.eq.0) then
1214 else if (rescale_mode.eq.1) then
1215 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1216 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1217 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1218 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1219 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1220 else if (rescale_mode.eq.2) then
1226 facT=licznik/dlog(dexp(x)+dexp(-x))
1227 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1228 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1229 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1230 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1232 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1233 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1235 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1239 if (shield_mode.gt.0) then
1240 wscp=weights(2)*fact
1242 wvdwpp=weights(16)*fact
1244 welec=weights(3)*fact
1245 wcorr=weights(4)*fact3
1246 wcorr5=weights(5)*fact4
1247 wcorr6=weights(6)*fact5
1248 wel_loc=weights(7)*fact2
1249 wturn3=weights(8)*fact2
1250 wturn4=weights(9)*fact3
1251 wturn6=weights(10)*fact5
1252 wtor=weights(13)*fact
1253 wtor_d=weights(14)*fact2
1254 wsccor=weights(21)*fact
1255 if (scale_umb) wumb=t_bath/temp0
1256 c write (iout,*) "scale_umb",scale_umb
1257 c write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1261 C------------------------------------------------------------------------
1262 subroutine enerprint(energia)
1264 include 'DIMENSIONS'
1265 include 'COMMON.IOUNITS'
1266 include 'COMMON.FFIELD'
1267 include 'COMMON.SBRIDGE'
1268 include 'COMMON.QRESTR'
1269 double precision energia(0:n_ene)
1270 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1271 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1272 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1274 & eliptran,Eafmforce,Etube,
1275 & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1280 evdw2=energia(2)+energia(18)
1292 eello_turn3=energia(8)
1293 eello_turn4=energia(9)
1294 eello_turn6=energia(10)
1300 edihcnstr=energia(19)
1304 eliptran=energia(22)
1305 Eafmforce=energia(23)
1306 ethetacnstr=energia(24)
1309 ehomology_constr=energia(27)
1311 edfadis = energia(28)
1312 edfator = energia(29)
1313 edfanei = energia(30)
1314 edfabet = energia(31)
1316 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1317 & estr,wbond,ebe,wang,
1318 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1321 & ecorr5,wcorr5,ecorr6,wcorr6,
1323 & eel_loc,wel_loc,eello_turn3,wturn3,
1324 & eello_turn4,wturn4,
1326 & eello_turn6,wturn6,
1328 & esccor,wsccor,edihcnstr,
1329 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1330 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1331 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1332 & edfabet,wdfa_beta,
1334 10 format (/'Virtual-chain energies:'//
1335 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1336 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1337 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1338 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1339 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1340 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1341 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1342 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1343 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1344 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1345 & ' (SS bridges & dist. cnstr.)'/
1347 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1348 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1349 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1351 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1352 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1353 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1355 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1357 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1358 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1359 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1360 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1361 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1362 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1363 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1364 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1365 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1366 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1367 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1368 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1369 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1370 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1371 & 'ETOT= ',1pE16.6,' (total)')
1374 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1375 & estr,wbond,ebe,wang,
1376 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1379 & ecorr5,wcorr5,ecorr6,wcorr6,
1381 & eel_loc,wel_loc,eello_turn3,wturn3,
1382 & eello_turn4,wturn4,
1384 & eello_turn6,wturn6,
1386 & esccor,wsccor,edihcnstr,
1387 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1388 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1389 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1390 & edfabet,wdfa_beta,
1392 10 format (/'Virtual-chain energies:'//
1393 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1394 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1395 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1396 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1397 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1398 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1399 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1400 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1401 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1402 & ' (SS bridges & dist. restr.)'/
1404 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1405 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1406 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1408 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1409 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1410 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1412 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1414 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1415 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1416 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1417 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1418 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1419 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1420 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1421 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1422 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1423 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1424 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1425 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1426 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1427 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1428 & 'ETOT= ',1pE16.6,' (total)')
1432 C-----------------------------------------------------------------------
1433 subroutine elj(evdw)
1435 C This subroutine calculates the interaction energy of nonbonded side chains
1436 C assuming the LJ potential of interaction.
1439 double precision accur
1440 include 'DIMENSIONS'
1441 parameter (accur=1.0d-10)
1442 include 'COMMON.GEO'
1443 include 'COMMON.VAR'
1444 include 'COMMON.LOCAL'
1445 include 'COMMON.CHAIN'
1446 include 'COMMON.DERIV'
1447 include 'COMMON.INTERACT'
1448 include 'COMMON.TORSION'
1449 include 'COMMON.SBRIDGE'
1450 include 'COMMON.NAMES'
1451 include 'COMMON.IOUNITS'
1453 include 'COMMON.CONTACTS'
1454 include 'COMMON.CONTMAT'
1456 double precision gg(3)
1457 double precision evdw,evdwij
1458 integer i,j,k,itypi,itypj,itypi1,num_conti,iint
1459 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1461 double precision fcont,fprimcont
1462 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1464 do i=iatsc_s,iatsc_e
1465 itypi=iabs(itype(i))
1466 if (itypi.eq.ntyp1) cycle
1467 itypi1=iabs(itype(i+1))
1474 C Calculate SC interaction energy.
1476 do iint=1,nint_gr(i)
1477 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1478 cd & 'iend=',iend(i,iint)
1479 do j=istart(i,iint),iend(i,iint)
1480 itypj=iabs(itype(j))
1481 if (itypj.eq.ntyp1) cycle
1485 C Change 12/1/95 to calculate four-body interactions
1486 rij=xj*xj+yj*yj+zj*zj
1488 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1489 eps0ij=eps(itypi,itypj)
1491 C have you changed here?
1495 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1496 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1497 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1498 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1499 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1500 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1503 C Calculate the components of the gradient in DC and X
1505 fac=-rrij*(e1+evdwij)
1510 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1511 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1512 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1513 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1517 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1522 C 12/1/95, revised on 5/20/97
1524 C Calculate the contact function. The ith column of the array JCONT will
1525 C contain the numbers of atoms that make contacts with the atom I (of numbers
1526 C greater than I). The arrays FACONT and GACONT will contain the values of
1527 C the contact function and its derivative.
1529 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1530 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1531 C Uncomment next line, if the correlation interactions are contact function only
1532 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1534 sigij=sigma(itypi,itypj)
1535 r0ij=rs0(itypi,itypj)
1537 C Check whether the SC's are not too far to make a contact.
1540 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1541 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1543 if (fcont.gt.0.0D0) then
1544 C If the SC-SC distance if close to sigma, apply spline.
1545 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1546 cAdam & fcont1,fprimcont1)
1547 cAdam fcont1=1.0d0-fcont1
1548 cAdam if (fcont1.gt.0.0d0) then
1549 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1550 cAdam fcont=fcont*fcont1
1552 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1553 cga eps0ij=1.0d0/dsqrt(eps0ij)
1555 cga gg(k)=gg(k)*eps0ij
1557 cga eps0ij=-evdwij*eps0ij
1558 C Uncomment for AL's type of SC correlation interactions.
1559 cadam eps0ij=-evdwij
1560 num_conti=num_conti+1
1561 jcont(num_conti,i)=j
1562 facont(num_conti,i)=fcont*eps0ij
1563 fprimcont=eps0ij*fprimcont/rij
1565 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1566 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1567 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1568 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1569 gacont(1,num_conti,i)=-fprimcont*xj
1570 gacont(2,num_conti,i)=-fprimcont*yj
1571 gacont(3,num_conti,i)=-fprimcont*zj
1572 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1573 cd write (iout,'(2i3,3f10.5)')
1574 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1582 num_cont(i)=num_conti
1587 gvdwc(j,i)=expon*gvdwc(j,i)
1588 gvdwx(j,i)=expon*gvdwx(j,i)
1591 C******************************************************************************
1595 C To save time, the factor of EXPON has been extracted from ALL components
1596 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1599 C******************************************************************************
1602 C-----------------------------------------------------------------------------
1603 subroutine eljk(evdw)
1605 C This subroutine calculates the interaction energy of nonbonded side chains
1606 C assuming the LJK potential of interaction.
1609 include 'DIMENSIONS'
1610 include 'COMMON.GEO'
1611 include 'COMMON.VAR'
1612 include 'COMMON.LOCAL'
1613 include 'COMMON.CHAIN'
1614 include 'COMMON.DERIV'
1615 include 'COMMON.INTERACT'
1616 include 'COMMON.IOUNITS'
1617 include 'COMMON.NAMES'
1618 double precision gg(3)
1619 double precision evdw,evdwij
1620 integer i,j,k,itypi,itypj,itypi1,iint
1621 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1622 & fac_augm,e_augm,r_inv_ij,r_shift_inv
1624 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1626 do i=iatsc_s,iatsc_e
1627 itypi=iabs(itype(i))
1628 if (itypi.eq.ntyp1) cycle
1629 itypi1=iabs(itype(i+1))
1634 C Calculate SC interaction energy.
1636 do iint=1,nint_gr(i)
1637 do j=istart(i,iint),iend(i,iint)
1638 itypj=iabs(itype(j))
1639 if (itypj.eq.ntyp1) cycle
1643 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1644 fac_augm=rrij**expon
1645 e_augm=augm(itypi,itypj)*fac_augm
1646 r_inv_ij=dsqrt(rrij)
1648 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1649 fac=r_shift_inv**expon
1650 C have you changed here?
1654 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1655 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1656 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1657 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1658 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1659 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1660 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1663 C Calculate the components of the gradient in DC and X
1665 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1670 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1671 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1672 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1673 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1677 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1685 gvdwc(j,i)=expon*gvdwc(j,i)
1686 gvdwx(j,i)=expon*gvdwx(j,i)
1691 C-----------------------------------------------------------------------------
1692 subroutine ebp(evdw)
1694 C This subroutine calculates the interaction energy of nonbonded side chains
1695 C assuming the Berne-Pechukas potential of interaction.
1698 include 'DIMENSIONS'
1699 include 'COMMON.GEO'
1700 include 'COMMON.VAR'
1701 include 'COMMON.LOCAL'
1702 include 'COMMON.CHAIN'
1703 include 'COMMON.DERIV'
1704 include 'COMMON.NAMES'
1705 include 'COMMON.INTERACT'
1706 include 'COMMON.IOUNITS'
1707 include 'COMMON.CALC'
1709 common /srutu/ icall
1710 double precision evdw
1711 integer itypi,itypj,itypi1,iint,ind
1712 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1713 c double precision rrsave(maxdim)
1716 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1718 c if (icall.eq.0) then
1724 do i=iatsc_s,iatsc_e
1725 itypi=iabs(itype(i))
1726 if (itypi.eq.ntyp1) cycle
1727 itypi1=iabs(itype(i+1))
1731 dxi=dc_norm(1,nres+i)
1732 dyi=dc_norm(2,nres+i)
1733 dzi=dc_norm(3,nres+i)
1734 c dsci_inv=dsc_inv(itypi)
1735 dsci_inv=vbld_inv(i+nres)
1737 C Calculate SC interaction energy.
1739 do iint=1,nint_gr(i)
1740 do j=istart(i,iint),iend(i,iint)
1742 itypj=iabs(itype(j))
1743 if (itypj.eq.ntyp1) cycle
1744 c dscj_inv=dsc_inv(itypj)
1745 dscj_inv=vbld_inv(j+nres)
1746 chi1=chi(itypi,itypj)
1747 chi2=chi(itypj,itypi)
1754 alf12=0.5D0*(alf1+alf2)
1755 C For diagnostics only!!!
1768 dxj=dc_norm(1,nres+j)
1769 dyj=dc_norm(2,nres+j)
1770 dzj=dc_norm(3,nres+j)
1771 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1772 cd if (icall.eq.0) then
1778 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1780 C Calculate whole angle-dependent part of epsilon and contributions
1781 C to its derivatives
1782 C have you changed here?
1783 fac=(rrij*sigsq)**expon2
1786 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1787 eps2der=evdwij*eps3rt
1788 eps3der=evdwij*eps2rt
1789 evdwij=evdwij*eps2rt*eps3rt
1792 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1794 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1795 cd & restyp(itypi),i,restyp(itypj),j,
1796 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1797 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1798 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1801 C Calculate gradient components.
1802 e1=e1*eps1*eps2rt**2*eps3rt**2
1803 fac=-expon*(e1+evdwij)
1806 C Calculate radial part of the gradient
1810 C Calculate the angular part of the gradient and sum add the contributions
1811 C to the appropriate components of the Cartesian gradient.
1819 C-----------------------------------------------------------------------------
1820 subroutine egb(evdw)
1822 C This subroutine calculates the interaction energy of nonbonded side chains
1823 C assuming the Gay-Berne potential of interaction.
1826 include 'DIMENSIONS'
1827 include 'COMMON.GEO'
1828 include 'COMMON.VAR'
1829 include 'COMMON.LOCAL'
1830 include 'COMMON.CHAIN'
1831 include 'COMMON.DERIV'
1832 include 'COMMON.NAMES'
1833 include 'COMMON.INTERACT'
1834 include 'COMMON.IOUNITS'
1835 include 'COMMON.CALC'
1836 include 'COMMON.CONTROL'
1837 include 'COMMON.SPLITELE'
1838 include 'COMMON.SBRIDGE'
1840 integer xshift,yshift,zshift,subchap
1841 double precision evdw
1842 integer itypi,itypj,itypi1,iint,ind
1843 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1844 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1845 & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
1846 & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
1847 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1849 ccccc energy_dec=.false.
1850 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1853 c if (icall.eq.0) lprn=.false.
1855 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1856 C we have the original box)
1860 do i=iatsc_s,iatsc_e
1861 itypi=iabs(itype(i))
1862 if (itypi.eq.ntyp1) cycle
1863 itypi1=iabs(itype(i+1))
1867 C Return atom into box, boxxsize is size of box in x dimension
1869 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1870 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1871 C Condition for being inside the proper box
1872 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1873 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
1877 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1878 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1879 C Condition for being inside the proper box
1880 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1881 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
1885 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1886 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1887 C Condition for being inside the proper box
1888 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1889 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
1893 if (xi.lt.0) xi=xi+boxxsize
1895 if (yi.lt.0) yi=yi+boxysize
1897 if (zi.lt.0) zi=zi+boxzsize
1898 C define scaling factor for lipids
1900 C if (positi.le.0) positi=positi+boxzsize
1902 C first for peptide groups
1903 c for each residue check if it is in lipid or lipid water border area
1904 if ((zi.gt.bordlipbot)
1905 &.and.(zi.lt.bordliptop)) then
1906 C the energy transfer exist
1907 if (zi.lt.buflipbot) then
1908 C what fraction I am in
1910 & ((zi-bordlipbot)/lipbufthick)
1911 C lipbufthick is thickenes of lipid buffore
1912 sslipi=sscalelip(fracinbuf)
1913 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1914 elseif (zi.gt.bufliptop) then
1915 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1916 sslipi=sscalelip(fracinbuf)
1917 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1927 C xi=xi+xshift*boxxsize
1928 C yi=yi+yshift*boxysize
1929 C zi=zi+zshift*boxzsize
1931 dxi=dc_norm(1,nres+i)
1932 dyi=dc_norm(2,nres+i)
1933 dzi=dc_norm(3,nres+i)
1934 c dsci_inv=dsc_inv(itypi)
1935 dsci_inv=vbld_inv(i+nres)
1936 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1937 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1939 C Calculate SC interaction energy.
1941 do iint=1,nint_gr(i)
1942 do j=istart(i,iint),iend(i,iint)
1943 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1945 c write(iout,*) "PRZED ZWYKLE", evdwij
1946 call dyn_ssbond_ene(i,j,evdwij)
1947 c write(iout,*) "PO ZWYKLE", evdwij
1950 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1951 & 'evdw',i,j,evdwij,' ss'
1952 C triple bond artifac removal
1953 do k=j+1,iend(i,iint)
1954 C search over all next residues
1955 if (dyn_ss_mask(k)) then
1956 C check if they are cysteins
1957 C write(iout,*) 'k=',k
1959 c write(iout,*) "PRZED TRI", evdwij
1960 evdwij_przed_tri=evdwij
1961 call triple_ssbond_ene(i,j,k,evdwij)
1962 c if(evdwij_przed_tri.ne.evdwij) then
1963 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1966 c write(iout,*) "PO TRI", evdwij
1967 C call the energy function that removes the artifical triple disulfide
1968 C bond the soubroutine is located in ssMD.F
1970 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1971 & 'evdw',i,j,evdwij,'tss'
1972 endif!dyn_ss_mask(k)
1976 itypj=iabs(itype(j))
1977 if (itypj.eq.ntyp1) cycle
1978 c dscj_inv=dsc_inv(itypj)
1979 dscj_inv=vbld_inv(j+nres)
1980 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1981 c & 1.0d0/vbld(j+nres)
1982 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1983 sig0ij=sigma(itypi,itypj)
1984 chi1=chi(itypi,itypj)
1985 chi2=chi(itypj,itypi)
1992 alf12=0.5D0*(alf1+alf2)
1993 C For diagnostics only!!!
2006 C Return atom J into box the original box
2008 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2009 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2010 C Condition for being inside the proper box
2011 c if ((xj.gt.((0.5d0)*boxxsize)).or.
2012 c & (xj.lt.((-0.5d0)*boxxsize))) then
2016 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2017 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2018 C Condition for being inside the proper box
2019 c if ((yj.gt.((0.5d0)*boxysize)).or.
2020 c & (yj.lt.((-0.5d0)*boxysize))) then
2024 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2025 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2026 C Condition for being inside the proper box
2027 c if ((zj.gt.((0.5d0)*boxzsize)).or.
2028 c & (zj.lt.((-0.5d0)*boxzsize))) then
2032 if (xj.lt.0) xj=xj+boxxsize
2034 if (yj.lt.0) yj=yj+boxysize
2036 if (zj.lt.0) zj=zj+boxzsize
2037 if ((zj.gt.bordlipbot)
2038 &.and.(zj.lt.bordliptop)) then
2039 C the energy transfer exist
2040 if (zj.lt.buflipbot) then
2041 C what fraction I am in
2043 & ((zj-bordlipbot)/lipbufthick)
2044 C lipbufthick is thickenes of lipid buffore
2045 sslipj=sscalelip(fracinbuf)
2046 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2047 elseif (zj.gt.bufliptop) then
2048 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2049 sslipj=sscalelip(fracinbuf)
2050 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2059 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2060 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2061 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2062 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2063 C write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2064 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
2065 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2066 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2067 C print *,sslipi,sslipj,bordlipbot,zi,zj
2068 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2076 xj=xj_safe+xshift*boxxsize
2077 yj=yj_safe+yshift*boxysize
2078 zj=zj_safe+zshift*boxzsize
2079 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2080 if(dist_temp.lt.dist_init) then
2090 if (subchap.eq.1) then
2099 dxj=dc_norm(1,nres+j)
2100 dyj=dc_norm(2,nres+j)
2101 dzj=dc_norm(3,nres+j)
2105 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2106 c write (iout,*) "j",j," dc_norm",
2107 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2108 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2110 sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
2111 sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
2113 c write (iout,'(a7,4f8.3)')
2114 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2115 if (sss.gt.0.0d0) then
2116 C Calculate angle-dependent terms of energy and contributions to their
2120 sig=sig0ij*dsqrt(sigsq)
2121 rij_shift=1.0D0/rij-sig+sig0ij
2122 c for diagnostics; uncomment
2123 c rij_shift=1.2*sig0ij
2124 C I hate to put IF's in the loops, but here don't have another choice!!!!
2125 if (rij_shift.le.0.0D0) then
2127 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2128 cd & restyp(itypi),i,restyp(itypj),j,
2129 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2133 c---------------------------------------------------------------
2134 rij_shift=1.0D0/rij_shift
2135 fac=rij_shift**expon
2136 C here to start with
2141 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2142 eps2der=evdwij*eps3rt
2143 eps3der=evdwij*eps2rt
2144 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2145 C &((sslipi+sslipj)/2.0d0+
2146 C &(2.0d0-sslipi-sslipj)/2.0d0)
2147 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2148 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2149 evdwij=evdwij*eps2rt*eps3rt
2150 evdw=evdw+evdwij*sss
2152 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2154 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2155 & restyp(itypi),i,restyp(itypj),j,
2156 & epsi,sigm,chi1,chi2,chip1,chip2,
2157 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2158 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2162 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2165 C Calculate gradient components.
2166 e1=e1*eps1*eps2rt**2*eps3rt**2
2167 fac=-expon*(e1+evdwij)*rij_shift
2170 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
2171 c & evdwij,fac,sigma(itypi,itypj),expon
2172 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2174 C Calculate the radial part of the gradient
2175 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2176 &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2177 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2178 &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2179 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2180 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2186 C Calculate angular part of the gradient.
2196 c write (iout,*) "Number of loop steps in EGB:",ind
2197 cccc energy_dec=.false.
2200 C-----------------------------------------------------------------------------
2201 subroutine egbv(evdw)
2203 C This subroutine calculates the interaction energy of nonbonded side chains
2204 C assuming the Gay-Berne-Vorobjev potential of interaction.
2207 include 'DIMENSIONS'
2208 include 'COMMON.GEO'
2209 include 'COMMON.VAR'
2210 include 'COMMON.LOCAL'
2211 include 'COMMON.CHAIN'
2212 include 'COMMON.DERIV'
2213 include 'COMMON.NAMES'
2214 include 'COMMON.INTERACT'
2215 include 'COMMON.IOUNITS'
2216 include 'COMMON.CALC'
2217 integer xshift,yshift,zshift,subchap
2219 common /srutu/ icall
2221 double precision evdw
2222 integer itypi,itypj,itypi1,iint,ind
2223 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2224 & xi,yi,zi,fac_augm,e_augm
2225 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2226 & sslipj,ssgradlipj,ssgradlipi,dist_init,xj_safe,yj_safe,zj_safe,
2227 & xj_temp,yj_temp,zj_temp,dist_temp,sig,rij_shift,faclip
2228 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2230 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2233 c if (icall.eq.0) lprn=.true.
2235 do i=iatsc_s,iatsc_e
2236 itypi=iabs(itype(i))
2237 if (itypi.eq.ntyp1) cycle
2238 itypi1=iabs(itype(i+1))
2243 if (xi.lt.0) xi=xi+boxxsize
2245 if (yi.lt.0) yi=yi+boxysize
2247 if (zi.lt.0) zi=zi+boxzsize
2248 C define scaling factor for lipids
2250 C if (positi.le.0) positi=positi+boxzsize
2252 C first for peptide groups
2253 c for each residue check if it is in lipid or lipid water border area
2254 if ((zi.gt.bordlipbot)
2255 &.and.(zi.lt.bordliptop)) then
2256 C the energy transfer exist
2257 if (zi.lt.buflipbot) then
2258 C what fraction I am in
2260 & ((zi-bordlipbot)/lipbufthick)
2261 C lipbufthick is thickenes of lipid buffore
2262 sslipi=sscalelip(fracinbuf)
2263 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2264 elseif (zi.gt.bufliptop) then
2265 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2266 sslipi=sscalelip(fracinbuf)
2267 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2277 dxi=dc_norm(1,nres+i)
2278 dyi=dc_norm(2,nres+i)
2279 dzi=dc_norm(3,nres+i)
2280 c dsci_inv=dsc_inv(itypi)
2281 dsci_inv=vbld_inv(i+nres)
2283 C Calculate SC interaction energy.
2285 do iint=1,nint_gr(i)
2286 do j=istart(i,iint),iend(i,iint)
2288 itypj=iabs(itype(j))
2289 if (itypj.eq.ntyp1) cycle
2290 c dscj_inv=dsc_inv(itypj)
2291 dscj_inv=vbld_inv(j+nres)
2292 sig0ij=sigma(itypi,itypj)
2293 r0ij=r0(itypi,itypj)
2294 chi1=chi(itypi,itypj)
2295 chi2=chi(itypj,itypi)
2302 alf12=0.5D0*(alf1+alf2)
2303 C For diagnostics only!!!
2317 if (xj.lt.0) xj=xj+boxxsize
2319 if (yj.lt.0) yj=yj+boxysize
2321 if (zj.lt.0) zj=zj+boxzsize
2322 if ((zj.gt.bordlipbot)
2323 &.and.(zj.lt.bordliptop)) then
2324 C the energy transfer exist
2325 if (zj.lt.buflipbot) then
2326 C what fraction I am in
2328 & ((zj-bordlipbot)/lipbufthick)
2329 C lipbufthick is thickenes of lipid buffore
2330 sslipj=sscalelip(fracinbuf)
2331 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2332 elseif (zj.gt.bufliptop) then
2333 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2334 sslipj=sscalelip(fracinbuf)
2335 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2344 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2345 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2346 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2347 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2348 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2349 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2350 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2351 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2359 xj=xj_safe+xshift*boxxsize
2360 yj=yj_safe+yshift*boxysize
2361 zj=zj_safe+zshift*boxzsize
2362 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2363 if(dist_temp.lt.dist_init) then
2373 if (subchap.eq.1) then
2382 dxj=dc_norm(1,nres+j)
2383 dyj=dc_norm(2,nres+j)
2384 dzj=dc_norm(3,nres+j)
2385 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2387 C Calculate angle-dependent terms of energy and contributions to their
2391 sig=sig0ij*dsqrt(sigsq)
2392 rij_shift=1.0D0/rij-sig+r0ij
2393 C I hate to put IF's in the loops, but here don't have another choice!!!!
2394 if (rij_shift.le.0.0D0) then
2399 c---------------------------------------------------------------
2400 rij_shift=1.0D0/rij_shift
2401 fac=rij_shift**expon
2404 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2405 eps2der=evdwij*eps3rt
2406 eps3der=evdwij*eps2rt
2407 fac_augm=rrij**expon
2408 e_augm=augm(itypi,itypj)*fac_augm
2409 evdwij=evdwij*eps2rt*eps3rt
2410 evdw=evdw+evdwij+e_augm
2412 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2414 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2415 & restyp(itypi),i,restyp(itypj),j,
2416 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2417 & chi1,chi2,chip1,chip2,
2418 & eps1,eps2rt**2,eps3rt**2,
2419 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2422 C Calculate gradient components.
2423 e1=e1*eps1*eps2rt**2*eps3rt**2
2424 fac=-expon*(e1+evdwij)*rij_shift
2426 fac=rij*fac-2*expon*rrij*e_augm
2427 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2428 C Calculate the radial part of the gradient
2432 C Calculate angular part of the gradient.
2438 C-----------------------------------------------------------------------------
2439 subroutine sc_angular
2440 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2441 C om12. Called by ebp, egb, and egbv.
2443 include 'COMMON.CALC'
2444 include 'COMMON.IOUNITS'
2448 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2449 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2450 om12=dxi*dxj+dyi*dyj+dzi*dzj
2452 C Calculate eps1(om12) and its derivative in om12
2453 faceps1=1.0D0-om12*chiom12
2454 faceps1_inv=1.0D0/faceps1
2455 eps1=dsqrt(faceps1_inv)
2456 C Following variable is eps1*deps1/dom12
2457 eps1_om12=faceps1_inv*chiom12
2462 c write (iout,*) "om12",om12," eps1",eps1
2463 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2468 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2469 sigsq=1.0D0-facsig*faceps1_inv
2470 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2471 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2472 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2478 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2479 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2481 C Calculate eps2 and its derivatives in om1, om2, and om12.
2484 chipom12=chip12*om12
2485 facp=1.0D0-om12*chipom12
2487 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2488 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2489 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2490 C Following variable is the square root of eps2
2491 eps2rt=1.0D0-facp1*facp_inv
2492 C Following three variables are the derivatives of the square root of eps
2493 C in om1, om2, and om12.
2494 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2495 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2496 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2497 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2498 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2499 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2500 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2501 c & " eps2rt_om12",eps2rt_om12
2502 C Calculate whole angle-dependent part of epsilon and contributions
2503 C to its derivatives
2506 C----------------------------------------------------------------------------
2508 implicit real*8 (a-h,o-z)
2509 include 'DIMENSIONS'
2510 include 'COMMON.CHAIN'
2511 include 'COMMON.DERIV'
2512 include 'COMMON.CALC'
2513 include 'COMMON.IOUNITS'
2514 double precision dcosom1(3),dcosom2(3)
2515 cc print *,'sss=',sss
2516 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2517 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2518 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2519 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2523 c eom12=evdwij*eps1_om12
2525 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2526 c & " sigder",sigder
2527 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2528 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2530 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2531 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2534 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2536 c write (iout,*) "gg",(gg(k),k=1,3)
2538 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2539 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2540 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2541 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2542 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2543 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2544 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2545 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2546 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2547 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2550 C Calculate the components of the gradient in DC and X
2554 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2558 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2559 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2563 C-----------------------------------------------------------------------
2564 subroutine e_softsphere(evdw)
2566 C This subroutine calculates the interaction energy of nonbonded side chains
2567 C assuming the LJ potential of interaction.
2569 implicit real*8 (a-h,o-z)
2570 include 'DIMENSIONS'
2571 parameter (accur=1.0d-10)
2572 include 'COMMON.GEO'
2573 include 'COMMON.VAR'
2574 include 'COMMON.LOCAL'
2575 include 'COMMON.CHAIN'
2576 include 'COMMON.DERIV'
2577 include 'COMMON.INTERACT'
2578 include 'COMMON.TORSION'
2579 include 'COMMON.SBRIDGE'
2580 include 'COMMON.NAMES'
2581 include 'COMMON.IOUNITS'
2582 c include 'COMMON.CONTACTS'
2584 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2586 do i=iatsc_s,iatsc_e
2587 itypi=iabs(itype(i))
2588 if (itypi.eq.ntyp1) cycle
2589 itypi1=iabs(itype(i+1))
2594 C Calculate SC interaction energy.
2596 do iint=1,nint_gr(i)
2597 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2598 cd & 'iend=',iend(i,iint)
2599 do j=istart(i,iint),iend(i,iint)
2600 itypj=iabs(itype(j))
2601 if (itypj.eq.ntyp1) cycle
2605 rij=xj*xj+yj*yj+zj*zj
2606 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2607 r0ij=r0(itypi,itypj)
2609 c print *,i,j,r0ij,dsqrt(rij)
2610 if (rij.lt.r0ijsq) then
2611 evdwij=0.25d0*(rij-r0ijsq)**2
2619 C Calculate the components of the gradient in DC and X
2625 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2626 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2627 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2628 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2632 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2640 C--------------------------------------------------------------------------
2641 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2644 C Soft-sphere potential of p-p interaction
2646 implicit real*8 (a-h,o-z)
2647 include 'DIMENSIONS'
2648 include 'COMMON.CONTROL'
2649 include 'COMMON.IOUNITS'
2650 include 'COMMON.GEO'
2651 include 'COMMON.VAR'
2652 include 'COMMON.LOCAL'
2653 include 'COMMON.CHAIN'
2654 include 'COMMON.DERIV'
2655 include 'COMMON.INTERACT'
2656 c include 'COMMON.CONTACTS'
2657 include 'COMMON.TORSION'
2658 include 'COMMON.VECTORS'
2659 include 'COMMON.FFIELD'
2661 integer xshift,yshift,zshift
2662 C write(iout,*) 'In EELEC_soft_sphere'
2669 do i=iatel_s,iatel_e
2670 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2674 xmedi=c(1,i)+0.5d0*dxi
2675 ymedi=c(2,i)+0.5d0*dyi
2676 zmedi=c(3,i)+0.5d0*dzi
2677 xmedi=mod(xmedi,boxxsize)
2678 if (xmedi.lt.0) xmedi=xmedi+boxxsize
2679 ymedi=mod(ymedi,boxysize)
2680 if (ymedi.lt.0) ymedi=ymedi+boxysize
2681 zmedi=mod(zmedi,boxzsize)
2682 if (zmedi.lt.0) zmedi=zmedi+boxzsize
2684 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2685 do j=ielstart(i),ielend(i)
2686 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2690 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2691 r0ij=rpp(iteli,itelj)
2700 if (xj.lt.0) xj=xj+boxxsize
2702 if (yj.lt.0) yj=yj+boxysize
2704 if (zj.lt.0) zj=zj+boxzsize
2705 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2713 xj=xj_safe+xshift*boxxsize
2714 yj=yj_safe+yshift*boxysize
2715 zj=zj_safe+zshift*boxzsize
2716 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2717 if(dist_temp.lt.dist_init) then
2727 if (isubchap.eq.1) then
2736 rij=xj*xj+yj*yj+zj*zj
2737 sss=sscale(sqrt(rij))
2738 sssgrad=sscagrad(sqrt(rij))
2739 if (rij.lt.r0ijsq) then
2740 evdw1ij=0.25d0*(rij-r0ijsq)**2
2746 evdw1=evdw1+evdw1ij*sss
2748 C Calculate contributions to the Cartesian gradient.
2750 ggg(1)=fac*xj*sssgrad
2751 ggg(2)=fac*yj*sssgrad
2752 ggg(3)=fac*zj*sssgrad
2754 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2755 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2758 * Loop over residues i+1 thru j-1.
2762 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2767 cgrad do i=nnt,nct-1
2769 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2771 cgrad do j=i+1,nct-1
2773 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2779 c------------------------------------------------------------------------------
2780 subroutine vec_and_deriv
2781 implicit real*8 (a-h,o-z)
2782 include 'DIMENSIONS'
2786 include 'COMMON.IOUNITS'
2787 include 'COMMON.GEO'
2788 include 'COMMON.VAR'
2789 include 'COMMON.LOCAL'
2790 include 'COMMON.CHAIN'
2791 include 'COMMON.VECTORS'
2792 include 'COMMON.SETUP'
2793 include 'COMMON.TIME1'
2794 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2795 C Compute the local reference systems. For reference system (i), the
2796 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2797 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2799 do i=ivec_start,ivec_end
2803 if (i.eq.nres-1) then
2804 C Case of the last full residue
2805 C Compute the Z-axis
2806 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2807 costh=dcos(pi-theta(nres))
2808 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2812 C Compute the derivatives of uz
2814 uzder(2,1,1)=-dc_norm(3,i-1)
2815 uzder(3,1,1)= dc_norm(2,i-1)
2816 uzder(1,2,1)= dc_norm(3,i-1)
2818 uzder(3,2,1)=-dc_norm(1,i-1)
2819 uzder(1,3,1)=-dc_norm(2,i-1)
2820 uzder(2,3,1)= dc_norm(1,i-1)
2823 uzder(2,1,2)= dc_norm(3,i)
2824 uzder(3,1,2)=-dc_norm(2,i)
2825 uzder(1,2,2)=-dc_norm(3,i)
2827 uzder(3,2,2)= dc_norm(1,i)
2828 uzder(1,3,2)= dc_norm(2,i)
2829 uzder(2,3,2)=-dc_norm(1,i)
2831 C Compute the Y-axis
2834 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2836 C Compute the derivatives of uy
2839 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2840 & -dc_norm(k,i)*dc_norm(j,i-1)
2841 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2843 uyder(j,j,1)=uyder(j,j,1)-costh
2844 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2849 uygrad(l,k,j,i)=uyder(l,k,j)
2850 uzgrad(l,k,j,i)=uzder(l,k,j)
2854 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2855 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2856 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2857 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2860 C Compute the Z-axis
2861 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2862 costh=dcos(pi-theta(i+2))
2863 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2867 C Compute the derivatives of uz
2869 uzder(2,1,1)=-dc_norm(3,i+1)
2870 uzder(3,1,1)= dc_norm(2,i+1)
2871 uzder(1,2,1)= dc_norm(3,i+1)
2873 uzder(3,2,1)=-dc_norm(1,i+1)
2874 uzder(1,3,1)=-dc_norm(2,i+1)
2875 uzder(2,3,1)= dc_norm(1,i+1)
2878 uzder(2,1,2)= dc_norm(3,i)
2879 uzder(3,1,2)=-dc_norm(2,i)
2880 uzder(1,2,2)=-dc_norm(3,i)
2882 uzder(3,2,2)= dc_norm(1,i)
2883 uzder(1,3,2)= dc_norm(2,i)
2884 uzder(2,3,2)=-dc_norm(1,i)
2886 C Compute the Y-axis
2889 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2891 C Compute the derivatives of uy
2894 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2895 & -dc_norm(k,i)*dc_norm(j,i+1)
2896 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2898 uyder(j,j,1)=uyder(j,j,1)-costh
2899 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2904 uygrad(l,k,j,i)=uyder(l,k,j)
2905 uzgrad(l,k,j,i)=uzder(l,k,j)
2909 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2910 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2911 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2912 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2916 vbld_inv_temp(1)=vbld_inv(i+1)
2917 if (i.lt.nres-1) then
2918 vbld_inv_temp(2)=vbld_inv(i+2)
2920 vbld_inv_temp(2)=vbld_inv(i)
2925 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2926 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2931 #if defined(PARVEC) && defined(MPI)
2932 if (nfgtasks1.gt.1) then
2934 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2935 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2936 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2937 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2938 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2940 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2941 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2943 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2944 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2945 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2946 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2947 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2948 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2949 time_gather=time_gather+MPI_Wtime()-time00
2953 if (fg_rank.eq.0) then
2954 write (iout,*) "Arrays UY and UZ"
2956 write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2963 C--------------------------------------------------------------------------
2964 subroutine set_matrices
2965 implicit real*8 (a-h,o-z)
2966 include 'DIMENSIONS'
2969 include "COMMON.SETUP"
2971 integer status(MPI_STATUS_SIZE)
2973 include 'COMMON.IOUNITS'
2974 include 'COMMON.GEO'
2975 include 'COMMON.VAR'
2976 include 'COMMON.LOCAL'
2977 include 'COMMON.CHAIN'
2978 include 'COMMON.DERIV'
2979 include 'COMMON.INTERACT'
2980 include 'COMMON.CORRMAT'
2981 include 'COMMON.TORSION'
2982 include 'COMMON.VECTORS'
2983 include 'COMMON.FFIELD'
2984 double precision auxvec(2),auxmat(2,2)
2986 C Compute the virtual-bond-torsional-angle dependent quantities needed
2987 C to calculate the el-loc multibody terms of various order.
2989 c write(iout,*) 'nphi=',nphi,nres
2990 c write(iout,*) "itype2loc",itype2loc
2992 do i=ivec_start+2,ivec_end+2
2997 c write (iout,*) "i",i,i-2," ii",ii
2999 innt=chain_border(1,ii)
3000 inct=chain_border(2,ii)
3001 c write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
3002 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3003 if (i.gt. innt+2 .and. i.lt.inct+2) then
3004 iti = itype2loc(itype(i-2))
3008 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3009 if (i.gt. innt+1 .and. i.lt.inct+1) then
3010 iti1 = itype2loc(itype(i-1))
3014 c write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
3015 c & " iti1",itype(i-1),iti1
3017 cost1=dcos(theta(i-1))
3018 sint1=dsin(theta(i-1))
3020 sint1cub=sint1sq*sint1
3021 sint1cost1=2*sint1*cost1
3022 c write (iout,*) "bnew1",i,iti
3023 c write (iout,*) (bnew1(k,1,iti),k=1,3)
3024 c write (iout,*) (bnew1(k,2,iti),k=1,3)
3025 c write (iout,*) "bnew2",i,iti
3026 c write (iout,*) (bnew2(k,1,iti),k=1,3)
3027 c write (iout,*) (bnew2(k,2,iti),k=1,3)
3029 b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3031 gtb1(k,i-2)=cost1*b1k-sint1sq*
3032 & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3033 b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3035 gtb2(k,i-2)=cost1*b2k-sint1sq*
3036 & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3039 aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3040 cc(1,k,i-2)=sint1sq*aux
3041 gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3042 & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3043 aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3044 dd(1,k,i-2)=sint1sq*aux
3045 gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3046 & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3048 cc(2,1,i-2)=cc(1,2,i-2)
3049 cc(2,2,i-2)=-cc(1,1,i-2)
3050 gtcc(2,1,i-2)=gtcc(1,2,i-2)
3051 gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3052 dd(2,1,i-2)=dd(1,2,i-2)
3053 dd(2,2,i-2)=-dd(1,1,i-2)
3054 gtdd(2,1,i-2)=gtdd(1,2,i-2)
3055 gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3058 aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3059 EE(l,k,i-2)=sint1sq*aux
3060 gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3063 EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3064 EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3065 EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3066 EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3067 gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3068 gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3069 gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3070 c b1tilde(1,i-2)=b1(1,i-2)
3071 c b1tilde(2,i-2)=-b1(2,i-2)
3072 c b2tilde(1,i-2)=b2(1,i-2)
3073 c b2tilde(2,i-2)=-b2(2,i-2)
3075 write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3076 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3077 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3078 write (iout,*) 'theta=', theta(i-1)
3081 if (i.gt. innt+2 .and. i.lt.inct+2) then
3082 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3083 iti = itype2loc(itype(i-2))
3087 c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3088 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3089 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3090 iti1 = itype2loc(itype(i-1))
3100 CC(k,l,i-2)=ccold(k,l,iti)
3101 DD(k,l,i-2)=ddold(k,l,iti)
3102 EE(k,l,i-2)=eeold(k,l,iti)
3107 b1tilde(1,i-2)= b1(1,i-2)
3108 b1tilde(2,i-2)=-b1(2,i-2)
3109 b2tilde(1,i-2)= b2(1,i-2)
3110 b2tilde(2,i-2)=-b2(2,i-2)
3112 Ctilde(1,1,i-2)= CC(1,1,i-2)
3113 Ctilde(1,2,i-2)= CC(1,2,i-2)
3114 Ctilde(2,1,i-2)=-CC(2,1,i-2)
3115 Ctilde(2,2,i-2)=-CC(2,2,i-2)
3117 Dtilde(1,1,i-2)= DD(1,1,i-2)
3118 Dtilde(1,2,i-2)= DD(1,2,i-2)
3119 Dtilde(2,1,i-2)=-DD(2,1,i-2)
3120 Dtilde(2,2,i-2)=-DD(2,2,i-2)
3122 write(iout,*) "i",i," iti",iti
3123 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3124 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3129 do i=ivec_start+2,ivec_end+2
3133 c if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3134 if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3172 obrot_der(1,i-2)=-sin1
3173 obrot_der(2,i-2)= cos1
3174 Ugder(1,1,i-2)= sin1
3175 Ugder(1,2,i-2)=-cos1
3176 Ugder(2,1,i-2)=-cos1
3177 Ugder(2,2,i-2)=-sin1
3180 obrot2_der(1,i-2)=-dwasin2
3181 obrot2_der(2,i-2)= dwacos2
3182 Ug2der(1,1,i-2)= dwasin2
3183 Ug2der(1,2,i-2)=-dwacos2
3184 Ug2der(2,1,i-2)=-dwacos2
3185 Ug2der(2,2,i-2)=-dwasin2
3187 obrot_der(1,i-2)=0.0d0
3188 obrot_der(2,i-2)=0.0d0
3189 Ugder(1,1,i-2)=0.0d0
3190 Ugder(1,2,i-2)=0.0d0
3191 Ugder(2,1,i-2)=0.0d0
3192 Ugder(2,2,i-2)=0.0d0
3193 obrot2_der(1,i-2)=0.0d0
3194 obrot2_der(2,i-2)=0.0d0
3195 Ug2der(1,1,i-2)=0.0d0
3196 Ug2der(1,2,i-2)=0.0d0
3197 Ug2der(2,1,i-2)=0.0d0
3198 Ug2der(2,2,i-2)=0.0d0
3200 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3201 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3202 if (i.gt.nnt+2 .and.i.lt.nct+2) then
3203 iti = itype2loc(itype(i-2))
3207 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3208 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3209 iti1 = itype2loc(itype(i-1))
3213 cd write (iout,*) '*******i',i,' iti1',iti
3214 cd write (iout,*) 'b1',b1(:,iti)
3215 cd write (iout,*) 'b2',b2(:,iti)
3216 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3217 c if (i .gt. iatel_s+2) then
3218 if (i .gt. nnt+2) then
3219 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3221 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3222 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3224 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3225 c & EE(1,2,iti),EE(2,2,i)
3226 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3227 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3228 c write(iout,*) "Macierz EUG",
3229 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3232 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3234 call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3235 call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3236 call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3237 call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3238 call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3250 DtUg2(l,k,i-2)=0.0d0
3254 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3255 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3257 muder(k,i-2)=Ub2der(k,i-2)
3259 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3260 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3261 if (itype(i-1).le.ntyp) then
3262 iti1 = itype2loc(itype(i-1))
3270 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3271 c mu(k,i-2)=b1(k,i-1)
3272 c mu(k,i-2)=Ub2(k,i-2)
3275 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3276 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3277 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3278 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3279 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3280 & ((ee(l,k,i-2),l=1,2),k=1,2)
3282 cd write (iout,*) 'mu1',mu1(:,i-2)
3283 cd write (iout,*) 'mu2',mu2(:,i-2)
3284 cd write (iout,*) 'mu',i-2,mu(:,i-2)
3286 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3288 call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3289 call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3290 call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3291 call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3292 call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3293 C Vectors and matrices dependent on a single virtual-bond dihedral.
3294 call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3295 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3296 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3297 call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3298 call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3299 call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3300 call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3301 call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3302 call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3307 C Matrices dependent on two consecutive virtual-bond dihedrals.
3308 C The order of matrices is from left to right.
3309 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3311 c do i=max0(ivec_start,2),ivec_end
3313 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3314 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3315 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3316 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3317 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3318 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3319 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3320 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3324 #if defined(MPI) && defined(PARMAT)
3326 c if (fg_rank.eq.0) then
3327 write (iout,*) "Arrays UG and UGDER before GATHER"
3329 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3330 & ((ug(l,k,i),l=1,2),k=1,2),
3331 & ((ugder(l,k,i),l=1,2),k=1,2)
3333 write (iout,*) "Arrays UG2 and UG2DER"
3335 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3336 & ((ug2(l,k,i),l=1,2),k=1,2),
3337 & ((ug2der(l,k,i),l=1,2),k=1,2)
3339 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3341 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3342 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3343 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3345 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3347 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3348 & costab(i),sintab(i),costab2(i),sintab2(i)
3350 write (iout,*) "Array MUDER"
3352 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3356 if (nfgtasks.gt.1) then
3358 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3359 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3360 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3362 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3363 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3365 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3366 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3368 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3369 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3371 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3372 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3374 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3375 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3377 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3378 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3380 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3381 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3382 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3383 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3384 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3385 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3386 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3387 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3388 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3389 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3390 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3391 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3393 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3395 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3396 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3398 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3399 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3401 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3402 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3404 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3405 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3407 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3408 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3410 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3411 & ivec_count(fg_rank1),
3412 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3414 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3415 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3417 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3418 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3420 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3421 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3423 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3424 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3426 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3427 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3429 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3430 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3432 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3433 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3435 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3436 & ivec_count(fg_rank1),
3437 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3439 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3440 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3442 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3443 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3445 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3446 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3448 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3449 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3451 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3452 & ivec_count(fg_rank1),
3453 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3455 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3456 & ivec_count(fg_rank1),
3457 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3459 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3460 & ivec_count(fg_rank1),
3461 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3462 & MPI_MAT2,FG_COMM1,IERR)
3463 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3464 & ivec_count(fg_rank1),
3465 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3466 & MPI_MAT2,FG_COMM1,IERR)
3470 c Passes matrix info through the ring
3473 if (irecv.lt.0) irecv=nfgtasks1-1
3476 if (inext.ge.nfgtasks1) inext=0
3478 c write (iout,*) "isend",isend," irecv",irecv
3480 lensend=lentyp(isend)
3481 lenrecv=lentyp(irecv)
3482 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3483 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3484 c & MPI_ROTAT1(lensend),inext,2200+isend,
3485 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3486 c & iprev,2200+irecv,FG_COMM,status,IERR)
3487 c write (iout,*) "Gather ROTAT1"
3489 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3490 c & MPI_ROTAT2(lensend),inext,3300+isend,
3491 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3492 c & iprev,3300+irecv,FG_COMM,status,IERR)
3493 c write (iout,*) "Gather ROTAT2"
3495 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3496 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3497 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3498 & iprev,4400+irecv,FG_COMM,status,IERR)
3499 c write (iout,*) "Gather ROTAT_OLD"
3501 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3502 & MPI_PRECOMP11(lensend),inext,5500+isend,
3503 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3504 & iprev,5500+irecv,FG_COMM,status,IERR)
3505 c write (iout,*) "Gather PRECOMP11"
3507 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3508 & MPI_PRECOMP12(lensend),inext,6600+isend,
3509 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3510 & iprev,6600+irecv,FG_COMM,status,IERR)
3511 c write (iout,*) "Gather PRECOMP12"
3514 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3516 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3517 & MPI_ROTAT2(lensend),inext,7700+isend,
3518 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3519 & iprev,7700+irecv,FG_COMM,status,IERR)
3520 c write (iout,*) "Gather PRECOMP21"
3522 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3523 & MPI_PRECOMP22(lensend),inext,8800+isend,
3524 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3525 & iprev,8800+irecv,FG_COMM,status,IERR)
3526 c write (iout,*) "Gather PRECOMP22"
3528 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3529 & MPI_PRECOMP23(lensend),inext,9900+isend,
3530 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3531 & MPI_PRECOMP23(lenrecv),
3532 & iprev,9900+irecv,FG_COMM,status,IERR)
3534 c write (iout,*) "Gather PRECOMP23"
3539 if (irecv.lt.0) irecv=nfgtasks1-1
3542 time_gather=time_gather+MPI_Wtime()-time00
3545 c if (fg_rank.eq.0) then
3546 write (iout,*) "Arrays UG and UGDER"
3548 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3549 & ((ug(l,k,i),l=1,2),k=1,2),
3550 & ((ugder(l,k,i),l=1,2),k=1,2)
3552 write (iout,*) "Arrays UG2 and UG2DER"
3554 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3555 & ((ug2(l,k,i),l=1,2),k=1,2),
3556 & ((ug2der(l,k,i),l=1,2),k=1,2)
3558 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3560 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3561 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3562 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3564 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3566 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3567 & costab(i),sintab(i),costab2(i),sintab2(i)
3569 write (iout,*) "Array MUDER"
3571 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3577 cd iti = itype2loc(itype(i))
3580 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3581 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3586 C-----------------------------------------------------------------------------
3587 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3589 C This subroutine calculates the average interaction energy and its gradient
3590 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3591 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3592 C The potential depends both on the distance of peptide-group centers and on
3593 C the orientation of the CA-CA virtual bonds.
3595 implicit real*8 (a-h,o-z)
3599 include 'DIMENSIONS'
3600 include 'COMMON.CONTROL'
3601 include 'COMMON.SETUP'
3602 include 'COMMON.IOUNITS'
3603 include 'COMMON.GEO'
3604 include 'COMMON.VAR'
3605 include 'COMMON.LOCAL'
3606 include 'COMMON.CHAIN'
3607 include 'COMMON.DERIV'
3608 include 'COMMON.INTERACT'
3610 include 'COMMON.CONTACTS'
3611 include 'COMMON.CONTMAT'
3613 include 'COMMON.CORRMAT'
3614 include 'COMMON.TORSION'
3615 include 'COMMON.VECTORS'
3616 include 'COMMON.FFIELD'
3617 include 'COMMON.TIME1'
3618 include 'COMMON.SPLITELE'
3619 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3620 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3621 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3622 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3623 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3624 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3626 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3628 double precision scal_el /1.0d0/
3630 double precision scal_el /0.5d0/
3633 C 13-go grudnia roku pamietnego...
3634 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3635 & 0.0d0,1.0d0,0.0d0,
3636 & 0.0d0,0.0d0,1.0d0/
3637 cd write(iout,*) 'In EELEC'
3639 cd write(iout,*) 'Type',i
3640 cd write(iout,*) 'B1',B1(:,i)
3641 cd write(iout,*) 'B2',B2(:,i)
3642 cd write(iout,*) 'CC',CC(:,:,i)
3643 cd write(iout,*) 'DD',DD(:,:,i)
3644 cd write(iout,*) 'EE',EE(:,:,i)
3646 cd call check_vecgrad
3648 if (icheckgrad.eq.1) then
3650 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3652 dc_norm(k,i)=dc(k,i)*fac
3654 c write (iout,*) 'i',i,' fac',fac
3657 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3658 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3659 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3660 c call vec_and_deriv
3666 time_mat=time_mat+MPI_Wtime()-time01
3670 cd write (iout,*) 'i=',i
3672 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3675 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3676 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3691 cd print '(a)','Enter EELEC'
3692 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3694 gel_loc_loc(i)=0.0d0
3699 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3701 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3703 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3704 do i=iturn3_start,iturn3_end
3706 C write(iout,*) "tu jest i",i
3707 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3708 C changes suggested by Ana to avoid out of bounds
3709 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3710 c & .or.((i+4).gt.nres)
3711 c & .or.((i-1).le.0)
3712 C end of changes by Ana
3713 & .or. itype(i+2).eq.ntyp1
3714 & .or. itype(i+3).eq.ntyp1) cycle
3715 C Adam: Instructions below will switch off existing interactions
3717 c if(itype(i-1).eq.ntyp1)cycle
3719 c if(i.LT.nres-3)then
3720 c if (itype(i+4).eq.ntyp1) cycle
3725 dx_normi=dc_norm(1,i)
3726 dy_normi=dc_norm(2,i)
3727 dz_normi=dc_norm(3,i)
3728 xmedi=c(1,i)+0.5d0*dxi
3729 ymedi=c(2,i)+0.5d0*dyi
3730 zmedi=c(3,i)+0.5d0*dzi
3731 xmedi=mod(xmedi,boxxsize)
3732 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3733 ymedi=mod(ymedi,boxysize)
3734 if (ymedi.lt.0) ymedi=ymedi+boxysize
3735 zmedi=mod(zmedi,boxzsize)
3736 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3738 call eelecij(i,i+2,ees,evdw1,eel_loc)
3739 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3741 num_cont_hb(i)=num_conti
3744 do i=iturn4_start,iturn4_end
3746 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3747 C changes suggested by Ana to avoid out of bounds
3748 c & .or.((i+5).gt.nres)
3749 c & .or.((i-1).le.0)
3750 C end of changes suggested by Ana
3751 & .or. itype(i+3).eq.ntyp1
3752 & .or. itype(i+4).eq.ntyp1
3753 c & .or. itype(i+5).eq.ntyp1
3754 c & .or. itype(i).eq.ntyp1
3755 c & .or. itype(i-1).eq.ntyp1
3760 dx_normi=dc_norm(1,i)
3761 dy_normi=dc_norm(2,i)
3762 dz_normi=dc_norm(3,i)
3763 xmedi=c(1,i)+0.5d0*dxi
3764 ymedi=c(2,i)+0.5d0*dyi
3765 zmedi=c(3,i)+0.5d0*dzi
3766 C Return atom into box, boxxsize is size of box in x dimension
3768 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3769 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3770 C Condition for being inside the proper box
3771 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3772 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3776 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3777 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3778 C Condition for being inside the proper box
3779 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3780 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3784 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3785 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3786 C Condition for being inside the proper box
3787 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3788 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3791 xmedi=mod(xmedi,boxxsize)
3792 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3793 ymedi=mod(ymedi,boxysize)
3794 if (ymedi.lt.0) ymedi=ymedi+boxysize
3795 zmedi=mod(zmedi,boxzsize)
3796 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3799 num_conti=num_cont_hb(i)
3801 c write(iout,*) "JESTEM W PETLI"
3802 call eelecij(i,i+3,ees,evdw1,eel_loc)
3803 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3804 & call eturn4(i,eello_turn4)
3806 num_cont_hb(i)=num_conti
3809 C Loop over all neighbouring boxes
3814 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3817 do i=iatel_s,iatel_e
3820 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3821 C changes suggested by Ana to avoid out of bounds
3822 c & .or.((i+2).gt.nres)
3823 c & .or.((i-1).le.0)
3824 C end of changes by Ana
3825 c & .or. itype(i+2).eq.ntyp1
3826 c & .or. itype(i-1).eq.ntyp1
3831 dx_normi=dc_norm(1,i)
3832 dy_normi=dc_norm(2,i)
3833 dz_normi=dc_norm(3,i)
3834 xmedi=c(1,i)+0.5d0*dxi
3835 ymedi=c(2,i)+0.5d0*dyi
3836 zmedi=c(3,i)+0.5d0*dzi
3837 xmedi=mod(xmedi,boxxsize)
3838 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3839 ymedi=mod(ymedi,boxysize)
3840 if (ymedi.lt.0) ymedi=ymedi+boxysize
3841 zmedi=mod(zmedi,boxzsize)
3842 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3843 C xmedi=xmedi+xshift*boxxsize
3844 C ymedi=ymedi+yshift*boxysize
3845 C zmedi=zmedi+zshift*boxzsize
3847 C Return tom into box, boxxsize is size of box in x dimension
3849 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3850 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3851 C Condition for being inside the proper box
3852 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3853 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3857 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3858 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3859 C Condition for being inside the proper box
3860 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3861 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3865 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3866 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3867 cC Condition for being inside the proper box
3868 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3869 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3873 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3875 num_conti=num_cont_hb(i)
3878 do j=ielstart(i),ielend(i)
3880 C write (iout,*) i,j
3882 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3883 C changes suggested by Ana to avoid out of bounds
3884 c & .or.((j+2).gt.nres)
3885 c & .or.((j-1).le.0)
3886 C end of changes by Ana
3887 c & .or.itype(j+2).eq.ntyp1
3888 c & .or.itype(j-1).eq.ntyp1
3890 call eelecij(i,j,ees,evdw1,eel_loc)
3893 num_cont_hb(i)=num_conti
3900 c write (iout,*) "Number of loop steps in EELEC:",ind
3902 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3903 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3905 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3906 ccc eel_loc=eel_loc+eello_turn3
3907 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3910 C-------------------------------------------------------------------------------
3911 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3912 implicit real*8 (a-h,o-z)
3913 include 'DIMENSIONS'
3917 include 'COMMON.CONTROL'
3918 include 'COMMON.IOUNITS'
3919 include 'COMMON.GEO'
3920 include 'COMMON.VAR'
3921 include 'COMMON.LOCAL'
3922 include 'COMMON.CHAIN'
3923 include 'COMMON.DERIV'
3924 include 'COMMON.INTERACT'
3926 include 'COMMON.CONTACTS'
3927 include 'COMMON.CONTMAT'
3929 include 'COMMON.CORRMAT'
3930 include 'COMMON.TORSION'
3931 include 'COMMON.VECTORS'
3932 include 'COMMON.FFIELD'
3933 include 'COMMON.TIME1'
3934 include 'COMMON.SPLITELE'
3935 include 'COMMON.SHIELD'
3936 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3937 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3938 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3939 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3940 & gmuij2(4),gmuji2(4)
3941 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3942 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3944 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3946 double precision scal_el /1.0d0/
3948 double precision scal_el /0.5d0/
3951 C 13-go grudnia roku pamietnego...
3952 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3953 & 0.0d0,1.0d0,0.0d0,
3954 & 0.0d0,0.0d0,1.0d0/
3955 integer xshift,yshift,zshift
3956 c time00=MPI_Wtime()
3957 cd write (iout,*) "eelecij",i,j
3961 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3962 aaa=app(iteli,itelj)
3963 bbb=bpp(iteli,itelj)
3964 ael6i=ael6(iteli,itelj)
3965 ael3i=ael3(iteli,itelj)
3969 dx_normj=dc_norm(1,j)
3970 dy_normj=dc_norm(2,j)
3971 dz_normj=dc_norm(3,j)
3972 C xj=c(1,j)+0.5D0*dxj-xmedi
3973 C yj=c(2,j)+0.5D0*dyj-ymedi
3974 C zj=c(3,j)+0.5D0*dzj-zmedi
3979 if (xj.lt.0) xj=xj+boxxsize
3981 if (yj.lt.0) yj=yj+boxysize
3983 if (zj.lt.0) zj=zj+boxzsize
3984 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3985 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3993 xj=xj_safe+xshift*boxxsize
3994 yj=yj_safe+yshift*boxysize
3995 zj=zj_safe+zshift*boxzsize
3996 dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3997 if(dist_temp.lt.dist_init) then
4007 if (isubchap.eq.1) then
4016 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
4018 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4019 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4020 C Condition for being inside the proper box
4021 c if ((xj.gt.((0.5d0)*boxxsize)).or.
4022 c & (xj.lt.((-0.5d0)*boxxsize))) then
4026 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4027 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4028 C Condition for being inside the proper box
4029 c if ((yj.gt.((0.5d0)*boxysize)).or.
4030 c & (yj.lt.((-0.5d0)*boxysize))) then
4034 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4035 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4036 C Condition for being inside the proper box
4037 c if ((zj.gt.((0.5d0)*boxzsize)).or.
4038 c & (zj.lt.((-0.5d0)*boxzsize))) then
4041 C endif !endPBC condintion
4045 rij=xj*xj+yj*yj+zj*zj
4047 sss=sscale(sqrt(rij))
4048 sssgrad=sscagrad(sqrt(rij))
4049 c if (sss.gt.0.0d0) then
4055 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4056 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4057 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4058 fac=cosa-3.0D0*cosb*cosg
4060 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4061 if (j.eq.i+2) ev1=scal_el*ev1
4066 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4070 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4071 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4072 if (shield_mode.gt.0) then
4075 el1=el1*fac_shield(i)**2*fac_shield(j)**2
4076 el2=el2*fac_shield(i)**2*fac_shield(j)**2
4085 evdw1=evdw1+evdwij*sss
4086 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4087 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4088 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
4089 cd & xmedi,ymedi,zmedi,xj,yj,zj
4091 if (energy_dec) then
4092 write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
4094 &,iteli,itelj,aaa,evdw1,sss
4095 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4096 &fac_shield(i),fac_shield(j)
4100 C Calculate contributions to the Cartesian gradient.
4103 facvdw=-6*rrmij*(ev1+evdwij)*sss
4104 facel=-3*rrmij*(el1+eesij)
4111 * Radial derivatives. First process both termini of the fragment (i,j)
4116 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4117 & (shield_mode.gt.0)) then
4119 do ilist=1,ishield_list(i)
4120 iresshield=shield_list(ilist,i)
4122 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4124 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4126 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4127 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4128 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4129 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4130 C if (iresshield.gt.i) then
4131 C do ishi=i+1,iresshield-1
4132 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4133 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4137 C do ishi=iresshield,i
4138 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4139 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4145 do ilist=1,ishield_list(j)
4146 iresshield=shield_list(ilist,j)
4148 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4150 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4152 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4153 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4155 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4156 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4157 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4158 C if (iresshield.gt.j) then
4159 C do ishi=j+1,iresshield-1
4160 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4161 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4165 C do ishi=iresshield,j
4166 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4167 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4174 gshieldc(k,i)=gshieldc(k,i)+
4175 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4176 gshieldc(k,j)=gshieldc(k,j)+
4177 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4178 gshieldc(k,i-1)=gshieldc(k,i-1)+
4179 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4180 gshieldc(k,j-1)=gshieldc(k,j-1)+
4181 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4186 c ghalf=0.5D0*ggg(k)
4187 c gelc(k,i)=gelc(k,i)+ghalf
4188 c gelc(k,j)=gelc(k,j)+ghalf
4190 c 9/28/08 AL Gradient compotents will be summed only at the end
4191 C print *,"before", gelc_long(1,i), gelc_long(1,j)
4193 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4194 C & +grad_shield(k,j)*eesij/fac_shield(j)
4195 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4196 C & +grad_shield(k,i)*eesij/fac_shield(i)
4197 C gelc_long(k,i-1)=gelc_long(k,i-1)
4198 C & +grad_shield(k,i)*eesij/fac_shield(i)
4199 C gelc_long(k,j-1)=gelc_long(k,j-1)
4200 C & +grad_shield(k,j)*eesij/fac_shield(j)
4202 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4205 * Loop over residues i+1 thru j-1.
4209 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4212 if (sss.gt.0.0) then
4213 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4214 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4215 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4222 c ghalf=0.5D0*ggg(k)
4223 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4224 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4226 c 9/28/08 AL Gradient compotents will be summed only at the end
4228 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4229 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4232 * Loop over residues i+1 thru j-1.
4236 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4241 facvdw=(ev1+evdwij)*sss
4244 fac=-3*rrmij*(facvdw+facvdw+facel)
4249 * Radial derivatives. First process both termini of the fragment (i,j)
4252 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4254 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4256 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4258 c ghalf=0.5D0*ggg(k)
4259 c gelc(k,i)=gelc(k,i)+ghalf
4260 c gelc(k,j)=gelc(k,j)+ghalf
4262 c 9/28/08 AL Gradient compotents will be summed only at the end
4264 gelc_long(k,j)=gelc(k,j)+ggg(k)
4265 gelc_long(k,i)=gelc(k,i)-ggg(k)
4268 * Loop over residues i+1 thru j-1.
4272 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4275 c 9/28/08 AL Gradient compotents will be summed only at the end
4276 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4277 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4278 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4280 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4281 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4287 ecosa=2.0D0*fac3*fac1+fac4
4290 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4291 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4293 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4294 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4296 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4297 cd & (dcosg(k),k=1,3)
4299 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4300 & fac_shield(i)**2*fac_shield(j)**2
4303 c ghalf=0.5D0*ggg(k)
4304 c gelc(k,i)=gelc(k,i)+ghalf
4305 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4306 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4307 c gelc(k,j)=gelc(k,j)+ghalf
4308 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4309 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4313 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4316 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4319 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4320 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4321 & *fac_shield(i)**2*fac_shield(j)**2
4323 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4324 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4325 & *fac_shield(i)**2*fac_shield(j)**2
4326 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4327 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4329 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4333 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4334 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4335 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4337 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4338 C energy of a peptide unit is assumed in the form of a second-order
4339 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4340 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4341 C are computed for EVERY pair of non-contiguous peptide groups.
4344 if (j.lt.nres-1) then
4356 muij(kkk)=mu(k,i)*mu(l,j)
4357 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4359 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4360 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4361 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4362 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4363 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4364 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4369 write (iout,*) 'EELEC: i',i,' j',j
4370 write (iout,*) 'j',j,' j1',j1,' j2',j2
4371 write(iout,*) 'muij',muij
4373 ury=scalar(uy(1,i),erij)
4374 urz=scalar(uz(1,i),erij)
4375 vry=scalar(uy(1,j),erij)
4376 vrz=scalar(uz(1,j),erij)
4377 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4378 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4379 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4380 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4381 fac=dsqrt(-ael6i)*r3ij
4383 write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4384 write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4385 & "uyvz",scalar(uy(1,i),uz(1,j)),
4386 & "uzvy",scalar(uz(1,i),uy(1,j)),
4387 & "uzvz",scalar(uz(1,i),uz(1,j))
4388 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4389 write (iout,*) "fac",fac
4396 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4399 cd write (iout,'(4i5,4f10.5)')
4400 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4401 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4402 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4403 cd & uy(:,j),uz(:,j)
4404 cd write (iout,'(4f10.5)')
4405 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4406 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4407 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4408 cd write (iout,'(9f10.5/)')
4409 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4410 C Derivatives of the elements of A in virtual-bond vectors
4411 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4413 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4414 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4415 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4416 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4417 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4418 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4419 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4420 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4421 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4422 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4423 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4424 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4426 C Compute radial contributions to the gradient
4444 C Add the contributions coming from er
4447 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4448 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4449 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4450 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4453 C Derivatives in DC(i)
4454 cgrad ghalf1=0.5d0*agg(k,1)
4455 cgrad ghalf2=0.5d0*agg(k,2)
4456 cgrad ghalf3=0.5d0*agg(k,3)
4457 cgrad ghalf4=0.5d0*agg(k,4)
4458 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4459 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4460 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4461 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4462 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4463 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4464 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4465 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4466 C Derivatives in DC(i+1)
4467 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4468 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4469 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4470 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4471 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4472 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4473 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4474 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4475 C Derivatives in DC(j)
4476 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4477 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4478 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4479 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4480 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4481 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4482 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4483 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4484 C Derivatives in DC(j+1) or DC(nres-1)
4485 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4486 & -3.0d0*vryg(k,3)*ury)
4487 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4488 & -3.0d0*vrzg(k,3)*ury)
4489 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4490 & -3.0d0*vryg(k,3)*urz)
4491 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4492 & -3.0d0*vrzg(k,3)*urz)
4493 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4495 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4508 aggi(k,l)=-aggi(k,l)
4509 aggi1(k,l)=-aggi1(k,l)
4510 aggj(k,l)=-aggj(k,l)
4511 aggj1(k,l)=-aggj1(k,l)
4514 if (j.lt.nres-1) then
4520 aggi(k,l)=-aggi(k,l)
4521 aggi1(k,l)=-aggi1(k,l)
4522 aggj(k,l)=-aggj(k,l)
4523 aggj1(k,l)=-aggj1(k,l)
4534 aggi(k,l)=-aggi(k,l)
4535 aggi1(k,l)=-aggi1(k,l)
4536 aggj(k,l)=-aggj(k,l)
4537 aggj1(k,l)=-aggj1(k,l)
4542 IF (wel_loc.gt.0.0d0) THEN
4543 C Contribution to the local-electrostatic energy coming from the i-j pair
4544 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4547 write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4549 write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4550 & " wel_loc",wel_loc
4552 if (shield_mode.eq.0) then
4559 eel_loc_ij=eel_loc_ij
4560 & *fac_shield(i)*fac_shield(j)
4561 c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4562 c & 'eelloc',i,j,eel_loc_ij
4563 C Now derivative over eel_loc
4564 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4565 & (shield_mode.gt.0)) then
4568 do ilist=1,ishield_list(i)
4569 iresshield=shield_list(ilist,i)
4571 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4574 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4576 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4577 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4581 do ilist=1,ishield_list(j)
4582 iresshield=shield_list(ilist,j)
4584 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4587 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4589 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4590 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4597 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4598 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4599 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4600 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4601 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4602 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4603 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4604 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4609 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4610 c & ' eel_loc_ij',eel_loc_ij
4611 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4612 C Calculate patrial derivative for theta angle
4614 geel_loc_ij=(a22*gmuij1(1)
4618 & *fac_shield(i)*fac_shield(j)
4619 c write(iout,*) "derivative over thatai"
4620 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4622 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4623 & geel_loc_ij*wel_loc
4624 c write(iout,*) "derivative over thatai-1"
4625 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4632 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4633 & geel_loc_ij*wel_loc
4634 & *fac_shield(i)*fac_shield(j)
4636 c Derivative over j residue
4637 geel_loc_ji=a22*gmuji1(1)
4641 c write(iout,*) "derivative over thataj"
4642 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4645 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4646 & geel_loc_ji*wel_loc
4647 & *fac_shield(i)*fac_shield(j)
4654 c write(iout,*) "derivative over thataj-1"
4655 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4657 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4658 & geel_loc_ji*wel_loc
4659 & *fac_shield(i)*fac_shield(j)
4661 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4663 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4664 & 'eelloc',i,j,eel_loc_ij
4665 c if (eel_loc_ij.ne.0)
4666 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4667 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4669 eel_loc=eel_loc+eel_loc_ij
4670 C Partial derivatives in virtual-bond dihedral angles gamma
4672 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4673 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4674 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4675 & *fac_shield(i)*fac_shield(j)
4677 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4678 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4679 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4680 & *fac_shield(i)*fac_shield(j)
4681 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4683 ggg(l)=(agg(l,1)*muij(1)+
4684 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4685 & *fac_shield(i)*fac_shield(j)
4686 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4687 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4688 cgrad ghalf=0.5d0*ggg(l)
4689 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4690 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4694 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4697 C Remaining derivatives of eello
4699 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4700 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4701 & *fac_shield(i)*fac_shield(j)
4703 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4704 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4705 & *fac_shield(i)*fac_shield(j)
4707 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4708 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4709 & *fac_shield(i)*fac_shield(j)
4711 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4712 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4713 & *fac_shield(i)*fac_shield(j)
4717 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4718 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4720 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4721 & .and. num_conti.le.maxconts) then
4722 c write (iout,*) i,j," entered corr"
4724 C Calculate the contact function. The ith column of the array JCONT will
4725 C contain the numbers of atoms that make contacts with the atom I (of numbers
4726 C greater than I). The arrays FACONT and GACONT will contain the values of
4727 C the contact function and its derivative.
4728 c r0ij=1.02D0*rpp(iteli,itelj)
4729 c r0ij=1.11D0*rpp(iteli,itelj)
4730 r0ij=2.20D0*rpp(iteli,itelj)
4731 c r0ij=1.55D0*rpp(iteli,itelj)
4732 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4733 if (fcont.gt.0.0D0) then
4734 num_conti=num_conti+1
4735 if (num_conti.gt.maxconts) then
4736 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4737 & ' will skip next contacts for this conf.'
4739 jcont_hb(num_conti,i)=j
4740 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4741 cd & " jcont_hb",jcont_hb(num_conti,i)
4742 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4743 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4744 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4746 d_cont(num_conti,i)=rij
4747 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4748 C --- Electrostatic-interaction matrix ---
4749 a_chuj(1,1,num_conti,i)=a22
4750 a_chuj(1,2,num_conti,i)=a23
4751 a_chuj(2,1,num_conti,i)=a32
4752 a_chuj(2,2,num_conti,i)=a33
4753 C --- Gradient of rij
4755 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4762 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4763 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4764 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4765 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4766 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4771 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4772 C Calculate contact energies
4774 wij=cosa-3.0D0*cosb*cosg
4777 c fac3=dsqrt(-ael6i)/r0ij**3
4778 fac3=dsqrt(-ael6i)*r3ij
4779 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4780 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4781 if (ees0tmp.gt.0) then
4782 ees0pij=dsqrt(ees0tmp)
4786 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4787 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4788 if (ees0tmp.gt.0) then
4789 ees0mij=dsqrt(ees0tmp)
4794 if (shield_mode.eq.0) then
4798 ees0plist(num_conti,i)=j
4799 C fac_shield(i)=0.4d0
4800 C fac_shield(j)=0.6d0
4802 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4803 & *fac_shield(i)*fac_shield(j)
4804 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4805 & *fac_shield(i)*fac_shield(j)
4806 C Diagnostics. Comment out or remove after debugging!
4807 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4808 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4809 c ees0m(num_conti,i)=0.0D0
4811 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4812 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4813 C Angular derivatives of the contact function
4814 ees0pij1=fac3/ees0pij
4815 ees0mij1=fac3/ees0mij
4816 fac3p=-3.0D0*fac3*rrmij
4817 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4818 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4820 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4821 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4822 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4823 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4824 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4825 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4826 ecosap=ecosa1+ecosa2
4827 ecosbp=ecosb1+ecosb2
4828 ecosgp=ecosg1+ecosg2
4829 ecosam=ecosa1-ecosa2
4830 ecosbm=ecosb1-ecosb2
4831 ecosgm=ecosg1-ecosg2
4840 facont_hb(num_conti,i)=fcont
4841 fprimcont=fprimcont/rij
4842 cd facont_hb(num_conti,i)=1.0D0
4843 C Following line is for diagnostics.
4846 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4847 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4850 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4851 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4853 gggp(1)=gggp(1)+ees0pijp*xj
4854 gggp(2)=gggp(2)+ees0pijp*yj
4855 gggp(3)=gggp(3)+ees0pijp*zj
4856 gggm(1)=gggm(1)+ees0mijp*xj
4857 gggm(2)=gggm(2)+ees0mijp*yj
4858 gggm(3)=gggm(3)+ees0mijp*zj
4859 C Derivatives due to the contact function
4860 gacont_hbr(1,num_conti,i)=fprimcont*xj
4861 gacont_hbr(2,num_conti,i)=fprimcont*yj
4862 gacont_hbr(3,num_conti,i)=fprimcont*zj
4865 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4866 c following the change of gradient-summation algorithm.
4868 cgrad ghalfp=0.5D0*gggp(k)
4869 cgrad ghalfm=0.5D0*gggm(k)
4870 gacontp_hb1(k,num_conti,i)=!ghalfp
4871 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4872 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4873 & *fac_shield(i)*fac_shield(j)
4875 gacontp_hb2(k,num_conti,i)=!ghalfp
4876 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4877 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4878 & *fac_shield(i)*fac_shield(j)
4880 gacontp_hb3(k,num_conti,i)=gggp(k)
4881 & *fac_shield(i)*fac_shield(j)
4883 gacontm_hb1(k,num_conti,i)=!ghalfm
4884 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4885 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4886 & *fac_shield(i)*fac_shield(j)
4888 gacontm_hb2(k,num_conti,i)=!ghalfm
4889 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4890 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4891 & *fac_shield(i)*fac_shield(j)
4893 gacontm_hb3(k,num_conti,i)=gggm(k)
4894 & *fac_shield(i)*fac_shield(j)
4897 C Diagnostics. Comment out or remove after debugging!
4899 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4900 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4901 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4902 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4903 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4904 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4907 endif ! num_conti.le.maxconts
4911 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4914 ghalf=0.5d0*agg(l,k)
4915 aggi(l,k)=aggi(l,k)+ghalf
4916 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4917 aggj(l,k)=aggj(l,k)+ghalf
4920 if (j.eq.nres-1 .and. i.lt.j-2) then
4923 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4928 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4931 C-----------------------------------------------------------------------------
4932 subroutine eturn3(i,eello_turn3)
4933 C Third- and fourth-order contributions from turns
4934 implicit real*8 (a-h,o-z)
4935 include 'DIMENSIONS'
4936 include 'COMMON.IOUNITS'
4937 include 'COMMON.GEO'
4938 include 'COMMON.VAR'
4939 include 'COMMON.LOCAL'
4940 include 'COMMON.CHAIN'
4941 include 'COMMON.DERIV'
4942 include 'COMMON.INTERACT'
4943 include 'COMMON.CORRMAT'
4944 include 'COMMON.TORSION'
4945 include 'COMMON.VECTORS'
4946 include 'COMMON.FFIELD'
4947 include 'COMMON.CONTROL'
4948 include 'COMMON.SHIELD'
4950 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4951 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4952 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4953 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4954 & auxgmat2(2,2),auxgmatt2(2,2)
4955 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4956 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4957 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4958 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4961 c write (iout,*) "eturn3",i,j,j1,j2
4966 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4968 C Third-order contributions
4975 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4976 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4977 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4978 c auxalary matices for theta gradient
4979 c auxalary matrix for i+1 and constant i+2
4980 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4981 c auxalary matrix for i+2 and constant i+1
4982 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4983 call transpose2(auxmat(1,1),auxmat1(1,1))
4984 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4985 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4986 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4987 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4988 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4989 if (shield_mode.eq.0) then
4996 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4997 & *fac_shield(i)*fac_shield(j)
4998 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4999 & *fac_shield(i)*fac_shield(j)
5000 if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
5003 C Derivatives in theta
5004 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5005 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5006 & *fac_shield(i)*fac_shield(j)
5007 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5008 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5009 & *fac_shield(i)*fac_shield(j)
5012 C Derivatives in shield mode
5013 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5014 & (shield_mode.gt.0)) then
5017 do ilist=1,ishield_list(i)
5018 iresshield=shield_list(ilist,i)
5020 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5022 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5024 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5025 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5029 do ilist=1,ishield_list(j)
5030 iresshield=shield_list(ilist,j)
5032 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5034 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5036 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5037 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5044 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5045 & grad_shield(k,i)*eello_t3/fac_shield(i)
5046 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5047 & grad_shield(k,j)*eello_t3/fac_shield(j)
5048 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5049 & grad_shield(k,i)*eello_t3/fac_shield(i)
5050 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5051 & grad_shield(k,j)*eello_t3/fac_shield(j)
5055 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5056 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
5057 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
5058 cd & ' eello_turn3_num',4*eello_turn3_num
5059 C Derivatives in gamma(i)
5060 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5061 call transpose2(auxmat2(1,1),auxmat3(1,1))
5062 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5063 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5064 & *fac_shield(i)*fac_shield(j)
5065 C Derivatives in gamma(i+1)
5066 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5067 call transpose2(auxmat2(1,1),auxmat3(1,1))
5068 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5069 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5070 & +0.5d0*(pizda(1,1)+pizda(2,2))
5071 & *fac_shield(i)*fac_shield(j)
5072 C Cartesian derivatives
5074 c ghalf1=0.5d0*agg(l,1)
5075 c ghalf2=0.5d0*agg(l,2)
5076 c ghalf3=0.5d0*agg(l,3)
5077 c ghalf4=0.5d0*agg(l,4)
5078 a_temp(1,1)=aggi(l,1)!+ghalf1
5079 a_temp(1,2)=aggi(l,2)!+ghalf2
5080 a_temp(2,1)=aggi(l,3)!+ghalf3
5081 a_temp(2,2)=aggi(l,4)!+ghalf4
5082 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5083 gcorr3_turn(l,i)=gcorr3_turn(l,i)
5084 & +0.5d0*(pizda(1,1)+pizda(2,2))
5085 & *fac_shield(i)*fac_shield(j)
5087 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5088 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5089 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5090 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5091 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5092 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5093 & +0.5d0*(pizda(1,1)+pizda(2,2))
5094 & *fac_shield(i)*fac_shield(j)
5095 a_temp(1,1)=aggj(l,1)!+ghalf1
5096 a_temp(1,2)=aggj(l,2)!+ghalf2
5097 a_temp(2,1)=aggj(l,3)!+ghalf3
5098 a_temp(2,2)=aggj(l,4)!+ghalf4
5099 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5100 gcorr3_turn(l,j)=gcorr3_turn(l,j)
5101 & +0.5d0*(pizda(1,1)+pizda(2,2))
5102 & *fac_shield(i)*fac_shield(j)
5103 a_temp(1,1)=aggj1(l,1)
5104 a_temp(1,2)=aggj1(l,2)
5105 a_temp(2,1)=aggj1(l,3)
5106 a_temp(2,2)=aggj1(l,4)
5107 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5108 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5109 & +0.5d0*(pizda(1,1)+pizda(2,2))
5110 & *fac_shield(i)*fac_shield(j)
5114 C-------------------------------------------------------------------------------
5115 subroutine eturn4(i,eello_turn4)
5116 C Third- and fourth-order contributions from turns
5117 implicit real*8 (a-h,o-z)
5118 include 'DIMENSIONS'
5119 include 'COMMON.IOUNITS'
5120 include 'COMMON.GEO'
5121 include 'COMMON.VAR'
5122 include 'COMMON.LOCAL'
5123 include 'COMMON.CHAIN'
5124 include 'COMMON.DERIV'
5125 include 'COMMON.INTERACT'
5126 include 'COMMON.CORRMAT'
5127 include 'COMMON.TORSION'
5128 include 'COMMON.VECTORS'
5129 include 'COMMON.FFIELD'
5130 include 'COMMON.CONTROL'
5131 include 'COMMON.SHIELD'
5133 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5134 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5135 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5136 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5137 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
5138 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5139 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5140 double precision agg(3,4),aggi(3,4),aggi1(3,4),
5141 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5142 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5143 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5146 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5148 C Fourth-order contributions
5156 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5157 cd call checkint_turn4(i,a_temp,eello_turn4_num)
5158 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5159 c write(iout,*)"WCHODZE W PROGRAM"
5164 iti1=itype2loc(itype(i+1))
5165 iti2=itype2loc(itype(i+2))
5166 iti3=itype2loc(itype(i+3))
5167 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5168 call transpose2(EUg(1,1,i+1),e1t(1,1))
5169 call transpose2(Eug(1,1,i+2),e2t(1,1))
5170 call transpose2(Eug(1,1,i+3),e3t(1,1))
5171 C Ematrix derivative in theta
5172 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5173 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5174 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5175 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5176 c eta1 in derivative theta
5177 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5178 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5179 c auxgvec is derivative of Ub2 so i+3 theta
5180 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5181 c auxalary matrix of E i+1
5182 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5185 s1=scalar2(b1(1,i+2),auxvec(1))
5186 c derivative of theta i+2 with constant i+3
5187 gs23=scalar2(gtb1(1,i+2),auxvec(1))
5188 c derivative of theta i+2 with constant i+2
5189 gs32=scalar2(b1(1,i+2),auxgvec(1))
5190 c derivative of E matix in theta of i+1
5191 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5193 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5194 c ea31 in derivative theta
5195 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5196 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5197 c auxilary matrix auxgvec of Ub2 with constant E matirx
5198 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5199 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5200 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5204 s2=scalar2(b1(1,i+1),auxvec(1))
5205 c derivative of theta i+1 with constant i+3
5206 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5207 c derivative of theta i+2 with constant i+1
5208 gs21=scalar2(b1(1,i+1),auxgvec(1))
5209 c derivative of theta i+3 with constant i+1
5210 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5211 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5213 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5214 c two derivatives over diffetent matrices
5215 c gtae3e2 is derivative over i+3
5216 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5217 c ae3gte2 is derivative over i+2
5218 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5219 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5220 c three possible derivative over theta E matices
5222 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5224 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5226 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5227 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5229 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5230 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5231 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5232 if (shield_mode.eq.0) then
5239 eello_turn4=eello_turn4-(s1+s2+s3)
5240 & *fac_shield(i)*fac_shield(j)
5241 eello_t4=-(s1+s2+s3)
5242 & *fac_shield(i)*fac_shield(j)
5243 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5244 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5245 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5246 C Now derivative over shield:
5247 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5248 & (shield_mode.gt.0)) then
5251 do ilist=1,ishield_list(i)
5252 iresshield=shield_list(ilist,i)
5254 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5256 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5258 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5259 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5263 do ilist=1,ishield_list(j)
5264 iresshield=shield_list(ilist,j)
5266 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5268 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5270 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5271 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5278 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5279 & grad_shield(k,i)*eello_t4/fac_shield(i)
5280 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5281 & grad_shield(k,j)*eello_t4/fac_shield(j)
5282 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5283 & grad_shield(k,i)*eello_t4/fac_shield(i)
5284 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5285 & grad_shield(k,j)*eello_t4/fac_shield(j)
5294 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5295 cd & ' eello_turn4_num',8*eello_turn4_num
5297 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5298 & -(gs13+gsE13+gsEE1)*wturn4
5299 & *fac_shield(i)*fac_shield(j)
5300 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5301 & -(gs23+gs21+gsEE2)*wturn4
5302 & *fac_shield(i)*fac_shield(j)
5304 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5305 & -(gs32+gsE31+gsEE3)*wturn4
5306 & *fac_shield(i)*fac_shield(j)
5308 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5311 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5312 & 'eturn4',i,j,-(s1+s2+s3)
5313 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5314 c & ' eello_turn4_num',8*eello_turn4_num
5315 C Derivatives in gamma(i)
5316 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5317 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5318 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5319 s1=scalar2(b1(1,i+2),auxvec(1))
5320 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5321 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5322 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5323 & *fac_shield(i)*fac_shield(j)
5324 C Derivatives in gamma(i+1)
5325 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5326 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5327 s2=scalar2(b1(1,i+1),auxvec(1))
5328 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5329 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5330 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5331 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5332 & *fac_shield(i)*fac_shield(j)
5333 C Derivatives in gamma(i+2)
5334 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5335 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5336 s1=scalar2(b1(1,i+2),auxvec(1))
5337 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5338 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5339 s2=scalar2(b1(1,i+1),auxvec(1))
5340 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5341 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5342 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5343 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5344 & *fac_shield(i)*fac_shield(j)
5345 C Cartesian derivatives
5346 C Derivatives of this turn contributions in DC(i+2)
5347 if (j.lt.nres-1) then
5349 a_temp(1,1)=agg(l,1)
5350 a_temp(1,2)=agg(l,2)
5351 a_temp(2,1)=agg(l,3)
5352 a_temp(2,2)=agg(l,4)
5353 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5354 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5355 s1=scalar2(b1(1,i+2),auxvec(1))
5356 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5357 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5358 s2=scalar2(b1(1,i+1),auxvec(1))
5359 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5360 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5361 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5363 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5364 & *fac_shield(i)*fac_shield(j)
5367 C Remaining derivatives of this turn contribution
5369 a_temp(1,1)=aggi(l,1)
5370 a_temp(1,2)=aggi(l,2)
5371 a_temp(2,1)=aggi(l,3)
5372 a_temp(2,2)=aggi(l,4)
5373 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5374 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5375 s1=scalar2(b1(1,i+2),auxvec(1))
5376 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5377 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5378 s2=scalar2(b1(1,i+1),auxvec(1))
5379 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5380 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5381 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5382 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5383 & *fac_shield(i)*fac_shield(j)
5384 a_temp(1,1)=aggi1(l,1)
5385 a_temp(1,2)=aggi1(l,2)
5386 a_temp(2,1)=aggi1(l,3)
5387 a_temp(2,2)=aggi1(l,4)
5388 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5389 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5390 s1=scalar2(b1(1,i+2),auxvec(1))
5391 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5392 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5393 s2=scalar2(b1(1,i+1),auxvec(1))
5394 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5395 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5396 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5397 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5398 & *fac_shield(i)*fac_shield(j)
5399 a_temp(1,1)=aggj(l,1)
5400 a_temp(1,2)=aggj(l,2)
5401 a_temp(2,1)=aggj(l,3)
5402 a_temp(2,2)=aggj(l,4)
5403 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5404 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5405 s1=scalar2(b1(1,i+2),auxvec(1))
5406 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5407 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5408 s2=scalar2(b1(1,i+1),auxvec(1))
5409 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5410 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5411 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5412 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5413 & *fac_shield(i)*fac_shield(j)
5414 a_temp(1,1)=aggj1(l,1)
5415 a_temp(1,2)=aggj1(l,2)
5416 a_temp(2,1)=aggj1(l,3)
5417 a_temp(2,2)=aggj1(l,4)
5418 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5419 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5420 s1=scalar2(b1(1,i+2),auxvec(1))
5421 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5422 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5423 s2=scalar2(b1(1,i+1),auxvec(1))
5424 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5425 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5426 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5427 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5428 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5429 & *fac_shield(i)*fac_shield(j)
5433 C-----------------------------------------------------------------------------
5434 subroutine vecpr(u,v,w)
5435 implicit real*8(a-h,o-z)
5436 dimension u(3),v(3),w(3)
5437 w(1)=u(2)*v(3)-u(3)*v(2)
5438 w(2)=-u(1)*v(3)+u(3)*v(1)
5439 w(3)=u(1)*v(2)-u(2)*v(1)
5442 C-----------------------------------------------------------------------------
5443 subroutine unormderiv(u,ugrad,unorm,ungrad)
5444 C This subroutine computes the derivatives of a normalized vector u, given
5445 C the derivatives computed without normalization conditions, ugrad. Returns
5448 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5449 double precision vec(3)
5450 double precision scalar
5452 c write (2,*) 'ugrad',ugrad
5455 vec(i)=scalar(ugrad(1,i),u(1))
5457 c write (2,*) 'vec',vec
5460 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5463 c write (2,*) 'ungrad',ungrad
5466 C-----------------------------------------------------------------------------
5467 subroutine escp_soft_sphere(evdw2,evdw2_14)
5469 C This subroutine calculates the excluded-volume interaction energy between
5470 C peptide-group centers and side chains and its gradient in virtual-bond and
5471 C side-chain vectors.
5473 implicit real*8 (a-h,o-z)
5474 include 'DIMENSIONS'
5475 include 'COMMON.GEO'
5476 include 'COMMON.VAR'
5477 include 'COMMON.LOCAL'
5478 include 'COMMON.CHAIN'
5479 include 'COMMON.DERIV'
5480 include 'COMMON.INTERACT'
5481 include 'COMMON.FFIELD'
5482 include 'COMMON.IOUNITS'
5483 include 'COMMON.CONTROL'
5485 integer xshift,yshift,zshift
5489 cd print '(a)','Enter ESCP'
5490 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5494 do i=iatscp_s,iatscp_e
5495 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5497 xi=0.5D0*(c(1,i)+c(1,i+1))
5498 yi=0.5D0*(c(2,i)+c(2,i+1))
5499 zi=0.5D0*(c(3,i)+c(3,i+1))
5500 C Return atom into box, boxxsize is size of box in x dimension
5502 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5503 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5504 C Condition for being inside the proper box
5505 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5506 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5510 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5511 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5512 C Condition for being inside the proper box
5513 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5514 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5518 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5519 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5520 cC Condition for being inside the proper box
5521 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5522 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5526 if (xi.lt.0) xi=xi+boxxsize
5528 if (yi.lt.0) yi=yi+boxysize
5530 if (zi.lt.0) zi=zi+boxzsize
5531 C xi=xi+xshift*boxxsize
5532 C yi=yi+yshift*boxysize
5533 C zi=zi+zshift*boxzsize
5534 do iint=1,nscp_gr(i)
5536 do j=iscpstart(i,iint),iscpend(i,iint)
5537 if (itype(j).eq.ntyp1) cycle
5538 itypj=iabs(itype(j))
5539 C Uncomment following three lines for SC-p interactions
5543 C Uncomment following three lines for Ca-p interactions
5548 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5549 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5550 C Condition for being inside the proper box
5551 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5552 c & (xj.lt.((-0.5d0)*boxxsize))) then
5556 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5557 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5558 cC Condition for being inside the proper box
5559 c if ((yj.gt.((0.5d0)*boxysize)).or.
5560 c & (yj.lt.((-0.5d0)*boxysize))) then
5564 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5565 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5566 C Condition for being inside the proper box
5567 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5568 c & (zj.lt.((-0.5d0)*boxzsize))) then
5571 if (xj.lt.0) xj=xj+boxxsize
5573 if (yj.lt.0) yj=yj+boxysize
5575 if (zj.lt.0) zj=zj+boxzsize
5576 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5584 xj=xj_safe+xshift*boxxsize
5585 yj=yj_safe+yshift*boxysize
5586 zj=zj_safe+zshift*boxzsize
5587 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5588 if(dist_temp.lt.dist_init) then
5598 if (subchap.eq.1) then
5611 rij=xj*xj+yj*yj+zj*zj
5615 if (rij.lt.r0ijsq) then
5616 evdwij=0.25d0*(rij-r0ijsq)**2
5624 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5629 cgrad if (j.lt.i) then
5630 cd write (iout,*) 'j<i'
5631 C Uncomment following three lines for SC-p interactions
5633 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5636 cd write (iout,*) 'j>i'
5638 cgrad ggg(k)=-ggg(k)
5639 C Uncomment following line for SC-p interactions
5640 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5644 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5646 cgrad kstart=min0(i+1,j)
5647 cgrad kend=max0(i-1,j-1)
5648 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5649 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5650 cgrad do k=kstart,kend
5652 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5656 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5657 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5668 C-----------------------------------------------------------------------------
5669 subroutine escp(evdw2,evdw2_14)
5671 C This subroutine calculates the excluded-volume interaction energy between
5672 C peptide-group centers and side chains and its gradient in virtual-bond and
5673 C side-chain vectors.
5675 implicit real*8 (a-h,o-z)
5676 include 'DIMENSIONS'
5677 include 'COMMON.GEO'
5678 include 'COMMON.VAR'
5679 include 'COMMON.LOCAL'
5680 include 'COMMON.CHAIN'
5681 include 'COMMON.DERIV'
5682 include 'COMMON.INTERACT'
5683 include 'COMMON.FFIELD'
5684 include 'COMMON.IOUNITS'
5685 include 'COMMON.CONTROL'
5686 include 'COMMON.SPLITELE'
5687 integer xshift,yshift,zshift
5691 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5692 cd print '(a)','Enter ESCP'
5693 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5697 if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5698 do i=iatscp_s,iatscp_e
5699 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5701 xi=0.5D0*(c(1,i)+c(1,i+1))
5702 yi=0.5D0*(c(2,i)+c(2,i+1))
5703 zi=0.5D0*(c(3,i)+c(3,i+1))
5705 if (xi.lt.0) xi=xi+boxxsize
5707 if (yi.lt.0) yi=yi+boxysize
5709 if (zi.lt.0) zi=zi+boxzsize
5710 c xi=xi+xshift*boxxsize
5711 c yi=yi+yshift*boxysize
5712 c zi=zi+zshift*boxzsize
5713 c print *,xi,yi,zi,'polozenie i'
5714 C Return atom into box, boxxsize is size of box in x dimension
5716 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5717 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5718 C Condition for being inside the proper box
5719 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5720 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5724 c print *,xi,boxxsize,"pierwszy"
5726 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5727 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5728 C Condition for being inside the proper box
5729 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5730 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5734 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5735 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5736 C Condition for being inside the proper box
5737 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5738 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5741 do iint=1,nscp_gr(i)
5743 do j=iscpstart(i,iint),iscpend(i,iint)
5744 itypj=iabs(itype(j))
5745 if (itypj.eq.ntyp1) cycle
5746 C Uncomment following three lines for SC-p interactions
5750 C Uncomment following three lines for Ca-p interactions
5755 if (xj.lt.0) xj=xj+boxxsize
5757 if (yj.lt.0) yj=yj+boxysize
5759 if (zj.lt.0) zj=zj+boxzsize
5761 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5762 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5763 C Condition for being inside the proper box
5764 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5765 c & (xj.lt.((-0.5d0)*boxxsize))) then
5769 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5770 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5771 cC Condition for being inside the proper box
5772 c if ((yj.gt.((0.5d0)*boxysize)).or.
5773 c & (yj.lt.((-0.5d0)*boxysize))) then
5777 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5778 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5779 C Condition for being inside the proper box
5780 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5781 c & (zj.lt.((-0.5d0)*boxzsize))) then
5784 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5785 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5793 xj=xj_safe+xshift*boxxsize
5794 yj=yj_safe+yshift*boxysize
5795 zj=zj_safe+zshift*boxzsize
5796 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5797 if(dist_temp.lt.dist_init) then
5807 if (subchap.eq.1) then
5816 c print *,xj,yj,zj,'polozenie j'
5817 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5819 sss=sscale(1.0d0/(dsqrt(rrij)))
5820 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5821 c if (sss.eq.0) print *,'czasem jest OK'
5822 if (sss.le.0.0d0) cycle
5823 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5825 e1=fac*fac*aad(itypj,iteli)
5826 e2=fac*bad(itypj,iteli)
5827 if (iabs(j-i) .le. 2) then
5830 evdw2_14=evdw2_14+(e1+e2)*sss
5833 evdw2=evdw2+evdwij*sss
5834 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5835 & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5838 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5840 fac=-(evdwij+e1)*rrij*sss
5841 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5845 cgrad if (j.lt.i) then
5846 cd write (iout,*) 'j<i'
5847 C Uncomment following three lines for SC-p interactions
5849 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5852 cd write (iout,*) 'j>i'
5854 cgrad ggg(k)=-ggg(k)
5855 C Uncomment following line for SC-p interactions
5856 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5857 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5861 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5863 cgrad kstart=min0(i+1,j)
5864 cgrad kend=max0(i-1,j-1)
5865 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5866 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5867 cgrad do k=kstart,kend
5869 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5873 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5874 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5876 c endif !endif for sscale cutoff
5886 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5887 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5888 gradx_scp(j,i)=expon*gradx_scp(j,i)
5891 C******************************************************************************
5895 C To save time the factor EXPON has been extracted from ALL components
5896 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5899 C******************************************************************************
5902 C--------------------------------------------------------------------------
5903 subroutine edis(ehpb)
5905 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5907 implicit real*8 (a-h,o-z)
5908 include 'DIMENSIONS'
5909 include 'COMMON.SBRIDGE'
5910 include 'COMMON.CHAIN'
5911 include 'COMMON.DERIV'
5912 include 'COMMON.VAR'
5913 include 'COMMON.INTERACT'
5914 include 'COMMON.IOUNITS'
5915 include 'COMMON.CONTROL'
5916 dimension ggg(3),ggg_peak(3,1000)
5921 c 8/21/18 AL: added explicit restraints on reference coords
5922 c write (iout,*) "restr_on_coord",restr_on_coord
5923 if (restr_on_coord) then
5927 if (itype(i).eq.ntyp1) cycle
5929 ecoor=ecoor+(c(j,i)-cref(j,i))**2
5930 ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5932 if (itype(i).ne.10) then
5934 ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5935 ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5938 if (energy_dec) write (iout,*)
5939 & "i",i," bfac",bfac(i)," ecoor",ecoor
5940 ehpb=ehpb+0.5d0*bfac(i)*ecoor
5944 C write (iout,*) ,"link_end",link_end,constr_dist
5945 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5946 c write(iout,*)'link_start=',link_start,' link_end=',link_end,
5947 c & " constr_dist",constr_dist," link_start_peak",link_start_peak,
5948 c & " link_end_peak",link_end_peak
5949 if (link_end.eq.0.and.link_end_peak.eq.0) return
5950 do i=link_start_peak,link_end_peak
5952 c print *,"i",i," link_end_peak",link_end_peak," ipeak",
5953 c & ipeak(1,i),ipeak(2,i)
5954 do ip=ipeak(1,i),ipeak(2,i)
5959 C iii and jjj point to the residues for which the distance is assigned.
5960 c if (ii.gt.nres) then
5967 if (ii.gt.nres) then
5972 if (jj.gt.nres) then
5977 aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5978 aux=dexp(-scal_peak*aux)
5979 ehpb_peak=ehpb_peak+aux
5980 fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5981 & forcon_peak(ip))*aux/dd
5983 ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5985 if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5986 & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5987 & forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5989 c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5990 ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5991 do ip=ipeak(1,i),ipeak(2,i)
5994 ggg(j)=ggg_peak(j,iip)/ehpb_peak
5998 C iii and jjj point to the residues for which the distance is assigned.
5999 c if (ii.gt.nres) then
6006 if (ii.gt.nres) then
6011 if (jj.gt.nres) then
6018 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6023 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6027 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6028 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6032 do i=link_start,link_end
6033 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6034 C CA-CA distance used in regularization of structure.
6037 C iii and jjj point to the residues for which the distance is assigned.
6038 if (ii.gt.nres) then
6043 if (jj.gt.nres) then
6048 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6049 c & dhpb(i),dhpb1(i),forcon(i)
6050 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6051 C distance and angle dependent SS bond potential.
6052 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6053 C & iabs(itype(jjj)).eq.1) then
6054 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6055 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6056 if (.not.dyn_ss .and. i.le.nss) then
6057 C 15/02/13 CC dynamic SSbond - additional check
6058 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6059 & iabs(itype(jjj)).eq.1) then
6060 call ssbond_ene(iii,jjj,eij)
6063 cd write (iout,*) "eij",eij
6064 cd & ' waga=',waga,' fac=',fac
6065 ! else if (ii.gt.nres .and. jj.gt.nres) then
6067 C Calculate the distance between the two points and its difference from the
6070 if (irestr_type(i).eq.11) then
6071 ehpb=ehpb+fordepth(i)!**4.0d0
6072 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6073 fac=fordepth(i)!**4.0d0
6074 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6075 if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
6076 & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6077 & ehpb,irestr_type(i)
6078 else if (irestr_type(i).eq.10) then
6079 c AL 6//19/2018 cross-link restraints
6080 xdis = 0.5d0*(dd/forcon(i))**2
6081 expdis = dexp(-xdis)
6082 c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
6083 aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
6084 c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
6085 c & " wboltzd",wboltzd
6086 ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
6087 c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
6088 fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
6089 & *expdis/(aux*forcon(i)**2)
6090 if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
6091 & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
6092 & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
6093 else if (irestr_type(i).eq.2) then
6094 c Quartic restraints
6095 ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6096 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6097 & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6098 & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
6099 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6101 c Quadratic restraints
6103 C Get the force constant corresponding to this distance.
6105 C Calculate the contribution to energy.
6106 ehpb=ehpb+0.5d0*waga*rdis*rdis
6107 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
6108 & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
6109 & 0.5d0*waga*rdis*rdis,irestr_type(i)
6111 C Evaluate gradient.
6115 c Calculate Cartesian gradient
6117 ggg(j)=fac*(c(j,jj)-c(j,ii))
6119 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6120 C If this is a SC-SC distance, we need to calculate the contributions to the
6121 C Cartesian gradient in the SC vectors (ghpbx).
6124 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6129 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6133 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6134 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6140 C--------------------------------------------------------------------------
6141 subroutine ssbond_ene(i,j,eij)
6143 C Calculate the distance and angle dependent SS-bond potential energy
6144 C using a free-energy function derived based on RHF/6-31G** ab initio
6145 C calculations of diethyl disulfide.
6147 C A. Liwo and U. Kozlowska, 11/24/03
6149 implicit real*8 (a-h,o-z)
6150 include 'DIMENSIONS'
6151 include 'COMMON.SBRIDGE'
6152 include 'COMMON.CHAIN'
6153 include 'COMMON.DERIV'
6154 include 'COMMON.LOCAL'
6155 include 'COMMON.INTERACT'
6156 include 'COMMON.VAR'
6157 include 'COMMON.IOUNITS'
6158 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6159 itypi=iabs(itype(i))
6163 dxi=dc_norm(1,nres+i)
6164 dyi=dc_norm(2,nres+i)
6165 dzi=dc_norm(3,nres+i)
6166 c dsci_inv=dsc_inv(itypi)
6167 dsci_inv=vbld_inv(nres+i)
6168 itypj=iabs(itype(j))
6169 c dscj_inv=dsc_inv(itypj)
6170 dscj_inv=vbld_inv(nres+j)
6174 dxj=dc_norm(1,nres+j)
6175 dyj=dc_norm(2,nres+j)
6176 dzj=dc_norm(3,nres+j)
6177 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6182 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6183 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6184 om12=dxi*dxj+dyi*dyj+dzi*dzj
6186 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6187 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6193 deltat12=om2-om1+2.0d0
6195 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6196 & +akct*deltad*deltat12
6197 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6198 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6199 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6200 c & " deltat12",deltat12," eij",eij
6201 ed=2*akcm*deltad+akct*deltat12
6203 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6204 eom1=-2*akth*deltat1-pom1-om2*pom2
6205 eom2= 2*akth*deltat2+pom1-om1*pom2
6208 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6209 ghpbx(k,i)=ghpbx(k,i)-ggk
6210 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6211 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6212 ghpbx(k,j)=ghpbx(k,j)+ggk
6213 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6214 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6215 ghpbc(k,i)=ghpbc(k,i)-ggk
6216 ghpbc(k,j)=ghpbc(k,j)+ggk
6219 C Calculate the components of the gradient in DC and X
6223 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
6228 C--------------------------------------------------------------------------
6229 subroutine ebond(estr)
6231 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6233 implicit real*8 (a-h,o-z)
6234 include 'DIMENSIONS'
6235 include 'COMMON.LOCAL'
6236 include 'COMMON.GEO'
6237 include 'COMMON.INTERACT'
6238 include 'COMMON.DERIV'
6239 include 'COMMON.VAR'
6240 include 'COMMON.CHAIN'
6241 include 'COMMON.IOUNITS'
6242 include 'COMMON.NAMES'
6243 include 'COMMON.FFIELD'
6244 include 'COMMON.CONTROL'
6245 include 'COMMON.SETUP'
6246 double precision u(3),ud(3)
6249 do i=ibondp_start,ibondp_end
6250 c 3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
6253 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
6254 diff = vbld(i)-vbldp0
6256 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6257 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6259 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6260 c & *dc(j,i-1)/vbld(i)
6262 c if (energy_dec) write(iout,*)
6263 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6265 C Checking if it involves dummy (NH3+ or COO-) group
6266 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6267 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
6268 diff = vbld(i)-vbldpDUM
6269 if (energy_dec) write(iout,*) "dum_bond",i,diff
6271 C NO vbldp0 is the equlibrium length of spring for peptide group
6272 diff = vbld(i)-vbldp0
6275 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6276 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6279 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6281 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6285 estr=0.5d0*AKP*estr+estr1
6287 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6289 do i=ibond_start,ibond_end
6291 if (iti.ne.10 .and. iti.ne.ntyp1) then
6294 diff=vbld(i+nres)-vbldsc0(1,iti)
6295 if (energy_dec) write (iout,*)
6296 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6297 & AKSC(1,iti),AKSC(1,iti)*diff*diff
6298 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6300 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6304 diff=vbld(i+nres)-vbldsc0(j,iti)
6305 ud(j)=aksc(j,iti)*diff
6306 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6320 uprod2=uprod2*u(k)*u(k)
6324 usumsqder=usumsqder+ud(j)*uprod2
6326 estr=estr+uprod/usum
6328 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6336 C--------------------------------------------------------------------------
6337 subroutine ebend(etheta)
6339 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6340 C angles gamma and its derivatives in consecutive thetas and gammas.
6342 implicit real*8 (a-h,o-z)
6343 include 'DIMENSIONS'
6344 include 'COMMON.LOCAL'
6345 include 'COMMON.GEO'
6346 include 'COMMON.INTERACT'
6347 include 'COMMON.DERIV'
6348 include 'COMMON.VAR'
6349 include 'COMMON.CHAIN'
6350 include 'COMMON.IOUNITS'
6351 include 'COMMON.NAMES'
6352 include 'COMMON.FFIELD'
6353 include 'COMMON.CONTROL'
6354 include 'COMMON.TORCNSTR'
6355 common /calcthet/ term1,term2,termm,diffak,ratak,
6356 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6357 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6358 double precision y(2),z(2)
6360 c time11=dexp(-2*time)
6363 c write (*,'(a,i2)') 'EBEND ICG=',icg
6364 do i=ithet_start,ithet_end
6365 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6366 & .or.itype(i).eq.ntyp1) cycle
6367 C Zero the energy function and its derivative at 0 or pi.
6368 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6370 ichir1=isign(1,itype(i-2))
6371 ichir2=isign(1,itype(i))
6372 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6373 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6374 if (itype(i-1).eq.10) then
6375 itype1=isign(10,itype(i-2))
6376 ichir11=isign(1,itype(i-2))
6377 ichir12=isign(1,itype(i-2))
6378 itype2=isign(10,itype(i))
6379 ichir21=isign(1,itype(i))
6380 ichir22=isign(1,itype(i))
6383 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6386 if (phii.ne.phii) phii=150.0
6396 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6399 if (phii1.ne.phii1) phii1=150.0
6411 C Calculate the "mean" value of theta from the part of the distribution
6412 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6413 C In following comments this theta will be referred to as t_c.
6414 thet_pred_mean=0.0d0
6416 athetk=athet(k,it,ichir1,ichir2)
6417 bthetk=bthet(k,it,ichir1,ichir2)
6419 athetk=athet(k,itype1,ichir11,ichir12)
6420 bthetk=bthet(k,itype2,ichir21,ichir22)
6422 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6423 c write(iout,*) 'chuj tu', y(k),z(k)
6425 dthett=thet_pred_mean*ssd
6426 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6427 C Derivatives of the "mean" values in gamma1 and gamma2.
6428 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6429 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6430 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6431 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6433 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6434 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6435 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6436 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6438 if (theta(i).gt.pi-delta) then
6439 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6441 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6442 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6443 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6445 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6447 else if (theta(i).lt.delta) then
6448 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6449 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6450 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6452 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6453 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6456 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6459 etheta=etheta+ethetai
6460 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6461 & 'ebend',i,ethetai,theta(i),itype(i)
6462 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6463 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6464 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6467 C Ufff.... We've done all this!!!
6470 C---------------------------------------------------------------------------
6471 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6473 implicit real*8 (a-h,o-z)
6474 include 'DIMENSIONS'
6475 include 'COMMON.LOCAL'
6476 include 'COMMON.IOUNITS'
6477 common /calcthet/ term1,term2,termm,diffak,ratak,
6478 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6479 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6480 C Calculate the contributions to both Gaussian lobes.
6481 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6482 C The "polynomial part" of the "standard deviation" of this part of
6483 C the distributioni.
6484 ccc write (iout,*) thetai,thet_pred_mean
6487 sig=sig*thet_pred_mean+polthet(j,it)
6489 C Derivative of the "interior part" of the "standard deviation of the"
6490 C gamma-dependent Gaussian lobe in t_c.
6491 sigtc=3*polthet(3,it)
6493 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6496 C Set the parameters of both Gaussian lobes of the distribution.
6497 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6498 fac=sig*sig+sigc0(it)
6501 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6502 sigsqtc=-4.0D0*sigcsq*sigtc
6503 c print *,i,sig,sigtc,sigsqtc
6504 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6505 sigtc=-sigtc/(fac*fac)
6506 C Following variable is sigma(t_c)**(-2)
6507 sigcsq=sigcsq*sigcsq
6509 sig0inv=1.0D0/sig0i**2
6510 delthec=thetai-thet_pred_mean
6511 delthe0=thetai-theta0i
6512 term1=-0.5D0*sigcsq*delthec*delthec
6513 term2=-0.5D0*sig0inv*delthe0*delthe0
6514 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6515 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6516 C NaNs in taking the logarithm. We extract the largest exponent which is added
6517 C to the energy (this being the log of the distribution) at the end of energy
6518 C term evaluation for this virtual-bond angle.
6519 if (term1.gt.term2) then
6521 term2=dexp(term2-termm)
6525 term1=dexp(term1-termm)
6528 C The ratio between the gamma-independent and gamma-dependent lobes of
6529 C the distribution is a Gaussian function of thet_pred_mean too.
6530 diffak=gthet(2,it)-thet_pred_mean
6531 ratak=diffak/gthet(3,it)**2
6532 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6533 C Let's differentiate it in thet_pred_mean NOW.
6535 C Now put together the distribution terms to make complete distribution.
6536 termexp=term1+ak*term2
6537 termpre=sigc+ak*sig0i
6538 C Contribution of the bending energy from this theta is just the -log of
6539 C the sum of the contributions from the two lobes and the pre-exponential
6540 C factor. Simple enough, isn't it?
6541 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6542 C write (iout,*) 'termexp',termexp,termm,termpre,i
6543 C NOW the derivatives!!!
6544 C 6/6/97 Take into account the deformation.
6545 E_theta=(delthec*sigcsq*term1
6546 & +ak*delthe0*sig0inv*term2)/termexp
6547 E_tc=((sigtc+aktc*sig0i)/termpre
6548 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6549 & aktc*term2)/termexp)
6552 c-----------------------------------------------------------------------------
6553 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6554 implicit real*8 (a-h,o-z)
6555 include 'DIMENSIONS'
6556 include 'COMMON.LOCAL'
6557 include 'COMMON.IOUNITS'
6558 common /calcthet/ term1,term2,termm,diffak,ratak,
6559 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6560 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6561 delthec=thetai-thet_pred_mean
6562 delthe0=thetai-theta0i
6563 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6564 t3 = thetai-thet_pred_mean
6568 t14 = t12+t6*sigsqtc
6570 t21 = thetai-theta0i
6576 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6577 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6578 & *(-t12*t9-ak*sig0inv*t27)
6582 C--------------------------------------------------------------------------
6583 subroutine ebend(etheta)
6585 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6586 C angles gamma and its derivatives in consecutive thetas and gammas.
6587 C ab initio-derived potentials from
6588 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6590 implicit real*8 (a-h,o-z)
6591 include 'DIMENSIONS'
6592 include 'COMMON.LOCAL'
6593 include 'COMMON.GEO'
6594 include 'COMMON.INTERACT'
6595 include 'COMMON.DERIV'
6596 include 'COMMON.VAR'
6597 include 'COMMON.CHAIN'
6598 include 'COMMON.IOUNITS'
6599 include 'COMMON.NAMES'
6600 include 'COMMON.FFIELD'
6601 include 'COMMON.CONTROL'
6602 include 'COMMON.TORCNSTR'
6603 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6604 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6605 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6606 & sinph1ph2(maxdouble,maxdouble)
6607 logical lprn /.false./, lprn1 /.false./
6609 do i=ithet_start,ithet_end
6610 c print *,i,itype(i-1),itype(i),itype(i-2)
6611 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6612 & .or.itype(i).eq.ntyp1) cycle
6613 C print *,i,theta(i)
6614 if (iabs(itype(i+1)).eq.20) iblock=2
6615 if (iabs(itype(i+1)).ne.20) iblock=1
6619 theti2=0.5d0*theta(i)
6620 ityp2=ithetyp((itype(i-1)))
6622 coskt(k)=dcos(k*theti2)
6623 sinkt(k)=dsin(k*theti2)
6626 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6629 if (phii.ne.phii) phii=150.0
6633 ityp1=ithetyp((itype(i-2)))
6634 C propagation of chirality for glycine type
6636 cosph1(k)=dcos(k*phii)
6637 sinph1(k)=dsin(k*phii)
6642 ityp1=ithetyp((itype(i-2)))
6647 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6650 if (phii1.ne.phii1) phii1=150.0
6655 ityp3=ithetyp((itype(i)))
6657 cosph2(k)=dcos(k*phii1)
6658 sinph2(k)=dsin(k*phii1)
6662 ityp3=ithetyp((itype(i)))
6668 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6671 ccl=cosph1(l)*cosph2(k-l)
6672 ssl=sinph1(l)*sinph2(k-l)
6673 scl=sinph1(l)*cosph2(k-l)
6674 csl=cosph1(l)*sinph2(k-l)
6675 cosph1ph2(l,k)=ccl-ssl
6676 cosph1ph2(k,l)=ccl+ssl
6677 sinph1ph2(l,k)=scl+csl
6678 sinph1ph2(k,l)=scl-csl
6682 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6683 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6684 write (iout,*) "coskt and sinkt"
6686 write (iout,*) k,coskt(k),sinkt(k)
6690 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6691 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6694 & write (iout,*) "k",k,"
6695 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6696 & " ethetai",ethetai
6699 write (iout,*) "cosph and sinph"
6701 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6703 write (iout,*) "cosph1ph2 and sinph2ph2"
6706 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6707 & sinph1ph2(l,k),sinph1ph2(k,l)
6710 write(iout,*) "ethetai",ethetai
6715 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6716 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6717 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6718 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6719 ethetai=ethetai+sinkt(m)*aux
6720 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6721 dephii=dephii+k*sinkt(m)*(
6722 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6723 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6724 dephii1=dephii1+k*sinkt(m)*(
6725 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6726 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6728 & write (iout,*) "m",m," k",k," bbthet",
6729 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6730 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6731 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6732 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6733 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6736 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6737 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6738 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6739 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6741 & write(iout,*) "ethetai",ethetai
6742 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6746 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6747 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6748 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6749 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6750 ethetai=ethetai+sinkt(m)*aux
6751 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6752 dephii=dephii+l*sinkt(m)*(
6753 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6754 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6755 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6756 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6757 dephii1=dephii1+(k-l)*sinkt(m)*(
6758 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6759 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6760 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6761 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6763 write (iout,*) "m",m," k",k," l",l," ffthet",
6764 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6765 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6766 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6767 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6768 & " ethetai",ethetai
6769 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6770 & cosph1ph2(k,l)*sinkt(m),
6771 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6780 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6781 & i,theta(i)*rad2deg,phii*rad2deg,
6782 & phii1*rad2deg,ethetai
6784 etheta=etheta+ethetai
6785 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6786 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6787 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6794 c-----------------------------------------------------------------------------
6795 subroutine esc(escloc)
6796 C Calculate the local energy of a side chain and its derivatives in the
6797 C corresponding virtual-bond valence angles THETA and the spherical angles
6799 implicit real*8 (a-h,o-z)
6800 include 'DIMENSIONS'
6801 include 'COMMON.GEO'
6802 include 'COMMON.LOCAL'
6803 include 'COMMON.VAR'
6804 include 'COMMON.INTERACT'
6805 include 'COMMON.DERIV'
6806 include 'COMMON.CHAIN'
6807 include 'COMMON.IOUNITS'
6808 include 'COMMON.NAMES'
6809 include 'COMMON.FFIELD'
6810 include 'COMMON.CONTROL'
6811 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6812 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6813 common /sccalc/ time11,time12,time112,theti,it,nlobit
6816 c write (iout,'(a)') 'ESC'
6817 do i=loc_start,loc_end
6819 if (it.eq.ntyp1) cycle
6820 if (it.eq.10) goto 1
6821 nlobit=nlob(iabs(it))
6822 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6823 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6824 theti=theta(i+1)-pipol
6829 if (x(2).gt.pi-delta) then
6833 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6835 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6836 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6838 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6839 & ddersc0(1),dersc(1))
6840 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6841 & ddersc0(3),dersc(3))
6843 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6845 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6846 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6847 & dersc0(2),esclocbi,dersc02)
6848 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6850 call splinthet(x(2),0.5d0*delta,ss,ssd)
6855 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6857 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6858 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6860 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6862 c write (iout,*) escloci
6863 else if (x(2).lt.delta) then
6867 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6869 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6870 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6872 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6873 & ddersc0(1),dersc(1))
6874 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6875 & ddersc0(3),dersc(3))
6877 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6879 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6880 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6881 & dersc0(2),esclocbi,dersc02)
6882 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6887 call splinthet(x(2),0.5d0*delta,ss,ssd)
6889 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6891 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6892 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6894 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6895 c write (iout,*) escloci
6897 call enesc(x,escloci,dersc,ddummy,.false.)
6900 escloc=escloc+escloci
6901 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6902 & 'escloc',i,escloci
6903 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6905 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6907 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6908 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6913 C---------------------------------------------------------------------------
6914 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6915 implicit real*8 (a-h,o-z)
6916 include 'DIMENSIONS'
6917 include 'COMMON.GEO'
6918 include 'COMMON.LOCAL'
6919 include 'COMMON.IOUNITS'
6920 common /sccalc/ time11,time12,time112,theti,it,nlobit
6921 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6922 double precision contr(maxlob,-1:1)
6924 c write (iout,*) 'it=',it,' nlobit=',nlobit
6928 if (mixed) ddersc(j)=0.0d0
6932 C Because of periodicity of the dependence of the SC energy in omega we have
6933 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6934 C To avoid underflows, first compute & store the exponents.
6942 z(k)=x(k)-censc(k,j,it)
6947 Axk=Axk+gaussc(l,k,j,it)*z(l)
6953 expfac=expfac+Ax(k,j,iii)*z(k)
6961 C As in the case of ebend, we want to avoid underflows in exponentiation and
6962 C subsequent NaNs and INFs in energy calculation.
6963 C Find the largest exponent
6967 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6971 cd print *,'it=',it,' emin=',emin
6973 C Compute the contribution to SC energy and derivatives
6978 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6979 if(adexp.ne.adexp) adexp=1.0
6982 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6984 cd print *,'j=',j,' expfac=',expfac
6985 escloc_i=escloc_i+expfac
6987 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6991 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6992 & +gaussc(k,2,j,it))*expfac
6999 dersc(1)=dersc(1)/cos(theti)**2
7000 ddersc(1)=ddersc(1)/cos(theti)**2
7003 escloci=-(dlog(escloc_i)-emin)
7005 dersc(j)=dersc(j)/escloc_i
7009 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7014 C------------------------------------------------------------------------------
7015 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7016 implicit real*8 (a-h,o-z)
7017 include 'DIMENSIONS'
7018 include 'COMMON.GEO'
7019 include 'COMMON.LOCAL'
7020 include 'COMMON.IOUNITS'
7021 common /sccalc/ time11,time12,time112,theti,it,nlobit
7022 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7023 double precision contr(maxlob)
7034 z(k)=x(k)-censc(k,j,it)
7040 Axk=Axk+gaussc(l,k,j,it)*z(l)
7046 expfac=expfac+Ax(k,j)*z(k)
7051 C As in the case of ebend, we want to avoid underflows in exponentiation and
7052 C subsequent NaNs and INFs in energy calculation.
7053 C Find the largest exponent
7056 if (emin.gt.contr(j)) emin=contr(j)
7060 C Compute the contribution to SC energy and derivatives
7064 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7065 escloc_i=escloc_i+expfac
7067 dersc(k)=dersc(k)+Ax(k,j)*expfac
7069 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7070 & +gaussc(1,2,j,it))*expfac
7074 dersc(1)=dersc(1)/cos(theti)**2
7075 dersc12=dersc12/cos(theti)**2
7076 escloci=-(dlog(escloc_i)-emin)
7078 dersc(j)=dersc(j)/escloc_i
7080 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7084 c----------------------------------------------------------------------------------
7085 subroutine esc(escloc)
7086 C Calculate the local energy of a side chain and its derivatives in the
7087 C corresponding virtual-bond valence angles THETA and the spherical angles
7088 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7089 C added by Urszula Kozlowska. 07/11/2007
7091 implicit real*8 (a-h,o-z)
7092 include 'DIMENSIONS'
7093 include 'COMMON.GEO'
7094 include 'COMMON.LOCAL'
7095 include 'COMMON.VAR'
7096 include 'COMMON.SCROT'
7097 include 'COMMON.INTERACT'
7098 include 'COMMON.DERIV'
7099 include 'COMMON.CHAIN'
7100 include 'COMMON.IOUNITS'
7101 include 'COMMON.NAMES'
7102 include 'COMMON.FFIELD'
7103 include 'COMMON.CONTROL'
7104 include 'COMMON.VECTORS'
7105 double precision x_prime(3),y_prime(3),z_prime(3)
7106 & , sumene,dsc_i,dp2_i,x(65),
7107 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7108 & de_dxx,de_dyy,de_dzz,de_dt
7109 double precision s1_t,s1_6_t,s2_t,s2_6_t
7111 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7112 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7113 & dt_dCi(3),dt_dCi1(3)
7114 common /sccalc/ time11,time12,time112,theti,it,nlobit
7117 do i=loc_start,loc_end
7118 if (itype(i).eq.ntyp1) cycle
7119 costtab(i+1) =dcos(theta(i+1))
7120 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7121 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7122 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7123 cosfac2=0.5d0/(1.0d0+costtab(i+1))
7124 cosfac=dsqrt(cosfac2)
7125 sinfac2=0.5d0/(1.0d0-costtab(i+1))
7126 sinfac=dsqrt(sinfac2)
7128 if (it.eq.10) goto 1
7130 C Compute the axes of tghe local cartesian coordinates system; store in
7131 c x_prime, y_prime and z_prime
7138 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7139 C & dc_norm(3,i+nres)
7141 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7142 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7145 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7148 c write (2,*) "x_prime",(x_prime(j),j=1,3)
7149 c write (2,*) "y_prime",(y_prime(j),j=1,3)
7150 c write (2,*) "z_prime",(z_prime(j),j=1,3)
7151 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7152 c & " xy",scalar(x_prime(1),y_prime(1)),
7153 c & " xz",scalar(x_prime(1),z_prime(1)),
7154 c & " yy",scalar(y_prime(1),y_prime(1)),
7155 c & " yz",scalar(y_prime(1),z_prime(1)),
7156 c & " zz",scalar(z_prime(1),z_prime(1))
7158 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7159 C to local coordinate system. Store in xx, yy, zz.
7165 xx = xx + x_prime(j)*dc_norm(j,i+nres)
7166 yy = yy + y_prime(j)*dc_norm(j,i+nres)
7167 zz = zz + z_prime(j)*dc_norm(j,i+nres)
7174 C Compute the energy of the ith side cbain
7176 c write (2,*) "xx",xx," yy",yy," zz",zz
7179 x(j) = sc_parmin(j,it)
7182 Cc diagnostics - remove later
7184 yy1 = dsin(alph(2))*dcos(omeg(2))
7185 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7186 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7187 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7189 C," --- ", xx_w,yy_w,zz_w
7192 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7193 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7195 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7196 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7198 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7199 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7200 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7201 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7202 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7204 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7205 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7206 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7207 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7208 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7210 dsc_i = 0.743d0+x(61)
7212 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7213 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7214 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7215 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7216 s1=(1+x(63))/(0.1d0 + dscp1)
7217 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7218 s2=(1+x(65))/(0.1d0 + dscp2)
7219 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7220 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7221 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7222 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7224 c & dscp1,dscp2,sumene
7225 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7226 escloc = escloc + sumene
7227 c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7232 C This section to check the numerical derivatives of the energy of ith side
7233 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7234 C #define DEBUG in the code to turn it on.
7236 write (2,*) "sumene =",sumene
7240 write (2,*) xx,yy,zz
7241 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7242 de_dxx_num=(sumenep-sumene)/aincr
7244 write (2,*) "xx+ sumene from enesc=",sumenep
7247 write (2,*) xx,yy,zz
7248 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7249 de_dyy_num=(sumenep-sumene)/aincr
7251 write (2,*) "yy+ sumene from enesc=",sumenep
7254 write (2,*) xx,yy,zz
7255 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7256 de_dzz_num=(sumenep-sumene)/aincr
7258 write (2,*) "zz+ sumene from enesc=",sumenep
7259 costsave=cost2tab(i+1)
7260 sintsave=sint2tab(i+1)
7261 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7262 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7263 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7264 de_dt_num=(sumenep-sumene)/aincr
7265 write (2,*) " t+ sumene from enesc=",sumenep
7266 cost2tab(i+1)=costsave
7267 sint2tab(i+1)=sintsave
7268 C End of diagnostics section.
7271 C Compute the gradient of esc
7273 c zz=zz*dsign(1.0,dfloat(itype(i)))
7274 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7275 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7276 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7277 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7278 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7279 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7280 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7281 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7282 pom1=(sumene3*sint2tab(i+1)+sumene1)
7283 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7284 pom2=(sumene4*cost2tab(i+1)+sumene2)
7285 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7286 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7287 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7288 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7290 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7291 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7292 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7294 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7295 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7296 & +(pom1+pom2)*pom_dx
7298 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7301 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7302 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7303 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7305 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7306 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7307 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7308 & +x(59)*zz**2 +x(60)*xx*zz
7309 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7310 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7311 & +(pom1-pom2)*pom_dy
7313 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7316 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7317 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7318 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7319 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7320 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7321 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7322 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7323 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7325 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7328 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7329 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7330 & +pom1*pom_dt1+pom2*pom_dt2
7332 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7337 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7338 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7339 cosfac2xx=cosfac2*xx
7340 sinfac2yy=sinfac2*yy
7342 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7344 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7346 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7347 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7348 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7349 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7350 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7351 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7352 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7353 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7354 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7355 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7359 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7360 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7361 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7362 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7365 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7366 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7367 dZZ_XYZ(k)=vbld_inv(i+nres)*
7368 & (z_prime(k)-zz*dC_norm(k,i+nres))
7370 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7371 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7375 dXX_Ctab(k,i)=dXX_Ci(k)
7376 dXX_C1tab(k,i)=dXX_Ci1(k)
7377 dYY_Ctab(k,i)=dYY_Ci(k)
7378 dYY_C1tab(k,i)=dYY_Ci1(k)
7379 dZZ_Ctab(k,i)=dZZ_Ci(k)
7380 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7381 dXX_XYZtab(k,i)=dXX_XYZ(k)
7382 dYY_XYZtab(k,i)=dYY_XYZ(k)
7383 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7387 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7388 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7389 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7390 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7391 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7393 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7394 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7395 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7396 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7397 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7398 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7399 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7400 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7402 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7403 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7405 C to check gradient call subroutine check_grad
7411 c------------------------------------------------------------------------------
7412 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7414 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7415 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7416 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7417 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7419 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7420 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7422 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7423 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7424 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7425 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7426 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7428 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7429 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7430 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7431 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7432 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7434 dsc_i = 0.743d0+x(61)
7436 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7437 & *(xx*cost2+yy*sint2))
7438 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7439 & *(xx*cost2-yy*sint2))
7440 s1=(1+x(63))/(0.1d0 + dscp1)
7441 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7442 s2=(1+x(65))/(0.1d0 + dscp2)
7443 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7444 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7445 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7450 c------------------------------------------------------------------------------
7451 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7453 C This procedure calculates two-body contact function g(rij) and its derivative:
7456 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7459 C where x=(rij-r0ij)/delta
7461 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7464 double precision rij,r0ij,eps0ij,fcont,fprimcont
7465 double precision x,x2,x4,delta
7469 if (x.lt.-1.0D0) then
7472 else if (x.le.1.0D0) then
7475 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7476 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7483 c------------------------------------------------------------------------------
7484 subroutine splinthet(theti,delta,ss,ssder)
7485 implicit real*8 (a-h,o-z)
7486 include 'DIMENSIONS'
7487 include 'COMMON.VAR'
7488 include 'COMMON.GEO'
7491 if (theti.gt.pipol) then
7492 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7494 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7499 c------------------------------------------------------------------------------
7500 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7502 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7503 double precision ksi,ksi2,ksi3,a1,a2,a3
7504 a1=fprim0*delta/(f1-f0)
7510 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7511 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7514 c------------------------------------------------------------------------------
7515 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7517 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7518 double precision ksi,ksi2,ksi3,a1,a2,a3
7523 a2=3*(f1x-f0x)-2*fprim0x*delta
7524 a3=fprim0x*delta-2*(f1x-f0x)
7525 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7528 C-----------------------------------------------------------------------------
7530 C-----------------------------------------------------------------------------
7531 subroutine etor(etors)
7532 implicit real*8 (a-h,o-z)
7533 include 'DIMENSIONS'
7534 include 'COMMON.VAR'
7535 include 'COMMON.GEO'
7536 include 'COMMON.LOCAL'
7537 include 'COMMON.TORSION'
7538 include 'COMMON.INTERACT'
7539 include 'COMMON.DERIV'
7540 include 'COMMON.CHAIN'
7541 include 'COMMON.NAMES'
7542 include 'COMMON.IOUNITS'
7543 include 'COMMON.FFIELD'
7544 include 'COMMON.TORCNSTR'
7545 include 'COMMON.CONTROL'
7547 C Set lprn=.true. for debugging
7551 do i=iphi_start,iphi_end
7553 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7554 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7555 itori=itortyp(itype(i-2))
7556 itori1=itortyp(itype(i-1))
7559 C Proline-Proline pair is a special case...
7560 if (itori.eq.3 .and. itori1.eq.3) then
7561 if (phii.gt.-dwapi3) then
7563 fac=1.0D0/(1.0D0-cosphi)
7564 etorsi=v1(1,3,3)*fac
7565 etorsi=etorsi+etorsi
7566 etors=etors+etorsi-v1(1,3,3)
7567 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7568 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7571 v1ij=v1(j+1,itori,itori1)
7572 v2ij=v2(j+1,itori,itori1)
7575 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7576 if (energy_dec) etors_ii=etors_ii+
7577 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7578 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7582 v1ij=v1(j,itori,itori1)
7583 v2ij=v2(j,itori,itori1)
7586 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7587 if (energy_dec) etors_ii=etors_ii+
7588 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7589 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7592 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7595 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7596 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7597 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7598 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7599 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7603 c------------------------------------------------------------------------------
7604 subroutine etor_d(etors_d)
7608 c----------------------------------------------------------------------------
7609 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7610 subroutine e_modeller(ehomology_constr)
7611 ehomology_constr=0.0d0
7612 write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7615 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7617 c------------------------------------------------------------------------------
7618 subroutine etor_d(etors_d)
7622 c----------------------------------------------------------------------------
7624 subroutine etor(etors)
7625 implicit real*8 (a-h,o-z)
7626 include 'DIMENSIONS'
7627 include 'COMMON.VAR'
7628 include 'COMMON.GEO'
7629 include 'COMMON.LOCAL'
7630 include 'COMMON.TORSION'
7631 include 'COMMON.INTERACT'
7632 include 'COMMON.DERIV'
7633 include 'COMMON.CHAIN'
7634 include 'COMMON.NAMES'
7635 include 'COMMON.IOUNITS'
7636 include 'COMMON.FFIELD'
7637 include 'COMMON.TORCNSTR'
7638 include 'COMMON.CONTROL'
7640 C Set lprn=.true. for debugging
7644 do i=iphi_start,iphi_end
7645 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7646 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7647 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7648 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7649 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7650 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7651 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7652 C For introducing the NH3+ and COO- group please check the etor_d for reference
7655 if (iabs(itype(i)).eq.20) then
7660 itori=itortyp(itype(i-2))
7661 itori1=itortyp(itype(i-1))
7664 C Regular cosine and sine terms
7665 do j=1,nterm(itori,itori1,iblock)
7666 v1ij=v1(j,itori,itori1,iblock)
7667 v2ij=v2(j,itori,itori1,iblock)
7670 etors=etors+v1ij*cosphi+v2ij*sinphi
7671 if (energy_dec) etors_ii=etors_ii+
7672 & v1ij*cosphi+v2ij*sinphi
7673 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7677 C E = SUM ----------------------------------- - v1
7678 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7680 cosphi=dcos(0.5d0*phii)
7681 sinphi=dsin(0.5d0*phii)
7682 do j=1,nlor(itori,itori1,iblock)
7683 vl1ij=vlor1(j,itori,itori1)
7684 vl2ij=vlor2(j,itori,itori1)
7685 vl3ij=vlor3(j,itori,itori1)
7686 pom=vl2ij*cosphi+vl3ij*sinphi
7687 pom1=1.0d0/(pom*pom+1.0d0)
7688 etors=etors+vl1ij*pom1
7689 if (energy_dec) etors_ii=etors_ii+
7692 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7694 C Subtract the constant term
7695 etors=etors-v0(itori,itori1,iblock)
7696 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7697 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7699 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7700 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7701 & (v1(j,itori,itori1,iblock),j=1,6),
7702 & (v2(j,itori,itori1,iblock),j=1,6)
7703 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7704 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7708 c----------------------------------------------------------------------------
7709 subroutine etor_d(etors_d)
7710 C 6/23/01 Compute double torsional energy
7711 implicit real*8 (a-h,o-z)
7712 include 'DIMENSIONS'
7713 include 'COMMON.VAR'
7714 include 'COMMON.GEO'
7715 include 'COMMON.LOCAL'
7716 include 'COMMON.TORSION'
7717 include 'COMMON.INTERACT'
7718 include 'COMMON.DERIV'
7719 include 'COMMON.CHAIN'
7720 include 'COMMON.NAMES'
7721 include 'COMMON.IOUNITS'
7722 include 'COMMON.FFIELD'
7723 include 'COMMON.TORCNSTR'
7725 C Set lprn=.true. for debugging
7729 c write(iout,*) "a tu??"
7730 do i=iphid_start,iphid_end
7731 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7732 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7733 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7734 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7735 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7736 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7737 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7738 & (itype(i+1).eq.ntyp1)) cycle
7739 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7740 itori=itortyp(itype(i-2))
7741 itori1=itortyp(itype(i-1))
7742 itori2=itortyp(itype(i))
7748 if (iabs(itype(i+1)).eq.20) iblock=2
7749 C Iblock=2 Proline type
7750 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7751 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7752 C if (itype(i+1).eq.ntyp1) iblock=3
7753 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7754 C IS or IS NOT need for this
7755 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7756 C is (itype(i-3).eq.ntyp1) ntblock=2
7757 C ntblock is N-terminal blocking group
7759 C Regular cosine and sine terms
7760 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7761 C Example of changes for NH3+ blocking group
7762 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7763 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7764 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7765 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7766 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7767 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7768 cosphi1=dcos(j*phii)
7769 sinphi1=dsin(j*phii)
7770 cosphi2=dcos(j*phii1)
7771 sinphi2=dsin(j*phii1)
7772 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7773 & v2cij*cosphi2+v2sij*sinphi2
7774 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7775 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7777 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7779 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7780 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7781 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7782 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7783 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7784 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7785 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7786 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7787 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7788 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7789 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7790 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7791 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7792 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7795 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7796 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7801 C----------------------------------------------------------------------------------
7802 C The rigorous attempt to derive energy function
7803 subroutine etor_kcc(etors)
7804 implicit real*8 (a-h,o-z)
7805 include 'DIMENSIONS'
7806 include 'COMMON.VAR'
7807 include 'COMMON.GEO'
7808 include 'COMMON.LOCAL'
7809 include 'COMMON.TORSION'
7810 include 'COMMON.INTERACT'
7811 include 'COMMON.DERIV'
7812 include 'COMMON.CHAIN'
7813 include 'COMMON.NAMES'
7814 include 'COMMON.IOUNITS'
7815 include 'COMMON.FFIELD'
7816 include 'COMMON.TORCNSTR'
7817 include 'COMMON.CONTROL'
7818 double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7820 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7821 C Set lprn=.true. for debugging
7824 C print *,"wchodze kcc"
7825 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7827 do i=iphi_start,iphi_end
7828 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7829 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7830 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7831 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7832 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7833 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7834 itori=itortyp(itype(i-2))
7835 itori1=itortyp(itype(i-1))
7840 C to avoid multiple devision by 2
7841 c theti22=0.5d0*theta(i)
7842 C theta 12 is the theta_1 /2
7843 C theta 22 is theta_2 /2
7844 c theti12=0.5d0*theta(i-1)
7845 C and appropriate sinus function
7846 sinthet1=dsin(theta(i-1))
7847 sinthet2=dsin(theta(i))
7848 costhet1=dcos(theta(i-1))
7849 costhet2=dcos(theta(i))
7850 C to speed up lets store its mutliplication
7851 sint1t2=sinthet2*sinthet1
7853 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7854 C +d_n*sin(n*gamma)) *
7855 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7856 C we have two sum 1) Non-Chebyshev which is with n and gamma
7857 nval=nterm_kcc_Tb(itori,itori1)
7863 c1(j)=c1(j-1)*costhet1
7864 c2(j)=c2(j-1)*costhet2
7867 do j=1,nterm_kcc(itori,itori1)
7871 sint1t2n=sint1t2n*sint1t2
7877 sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7878 gradvalct1=gradvalct1+
7879 & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7880 gradvalct2=gradvalct2+
7881 & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7884 gradvalct1=-gradvalct1*sinthet1
7885 gradvalct2=-gradvalct2*sinthet2
7891 sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7892 gradvalst1=gradvalst1+
7893 & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7894 gradvalst2=gradvalst2+
7895 & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7898 gradvalst1=-gradvalst1*sinthet1
7899 gradvalst2=-gradvalst2*sinthet2
7900 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7901 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7902 C glocig is the gradient local i site in gamma
7903 glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7904 C now gradient over theta_1
7905 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7906 & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7907 glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7908 & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7911 C derivative over gamma
7912 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7913 C derivative over theta1
7914 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7915 C now derivative over theta2
7916 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7918 write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7919 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7920 write (iout,*) "c1",(c1(k),k=0,nval),
7921 & " c2",(c2(k),k=0,nval)
7926 c---------------------------------------------------------------------------------------------
7927 subroutine etor_constr(edihcnstr)
7928 implicit real*8 (a-h,o-z)
7929 include 'DIMENSIONS'
7930 include 'COMMON.VAR'
7931 include 'COMMON.GEO'
7932 include 'COMMON.LOCAL'
7933 include 'COMMON.TORSION'
7934 include 'COMMON.INTERACT'
7935 include 'COMMON.DERIV'
7936 include 'COMMON.CHAIN'
7937 include 'COMMON.NAMES'
7938 include 'COMMON.IOUNITS'
7939 include 'COMMON.FFIELD'
7940 include 'COMMON.TORCNSTR'
7941 include 'COMMON.BOUNDS'
7942 include 'COMMON.CONTROL'
7943 ! 6/20/98 - dihedral angle constraints
7945 c do i=1,ndih_constr
7946 if (raw_psipred) then
7947 do i=idihconstr_start,idihconstr_end
7948 itori=idih_constr(i)
7950 gaudih_i=vpsipred(1,i)
7954 cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7955 dexpcos_i=dexp(-cos_i*cos_i)
7956 gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7957 gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7958 & *cos_i*dexpcos_i/s**2
7960 edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7961 gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7963 & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7964 & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7965 & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7966 & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7967 & -wdihc*dlog(gaudih_i)
7971 do i=idihconstr_start,idihconstr_end
7972 itori=idih_constr(i)
7974 difi=pinorm(phii-phi0(i))
7975 if (difi.gt.drange(i)) then
7977 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7978 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7979 else if (difi.lt.-drange(i)) then
7981 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7982 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7992 c----------------------------------------------------------------------------
7993 c MODELLER restraint function
7994 subroutine e_modeller(ehomology_constr)
7996 include 'DIMENSIONS'
7998 double precision ehomology_constr
7999 integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
8000 integer katy, odleglosci, test7
8001 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
8003 real*8 distance(max_template),distancek(max_template),
8004 & min_odl,godl(max_template),dih_diff(max_template)
8007 c FP - 30/10/2014 Temporary specifications for homology restraints
8009 double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
8011 double precision, dimension (maxres) :: guscdiff,usc_diff
8012 double precision, dimension (max_template) ::
8013 & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
8015 double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
8016 & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
8017 & betai,sum_sgodl,dij
8018 double precision dist,pinorm
8020 include 'COMMON.SBRIDGE'
8021 include 'COMMON.CHAIN'
8022 include 'COMMON.GEO'
8023 include 'COMMON.DERIV'
8024 include 'COMMON.LOCAL'
8025 include 'COMMON.INTERACT'
8026 include 'COMMON.VAR'
8027 include 'COMMON.IOUNITS'
8028 c include 'COMMON.MD'
8029 include 'COMMON.CONTROL'
8030 include 'COMMON.HOMOLOGY'
8031 include 'COMMON.QRESTR'
8033 c From subroutine Econstr_back
8035 include 'COMMON.NAMES'
8036 include 'COMMON.TIME1'
8041 distancek(i)=9999999.9
8047 c Pseudo-energy and gradient from homology restraints (MODELLER-like
8049 C AL 5/2/14 - Introduce list of restraints
8050 c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
8052 write(iout,*) "------- dist restrs start -------"
8054 do ii = link_start_homo,link_end_homo
8058 c write (iout,*) "dij(",i,j,") =",dij
8060 do k=1,constr_homology
8061 c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
8062 if(.not.l_homo(k,ii)) then
8066 distance(k)=odl(k,ii)-dij
8067 c write (iout,*) "distance(",k,") =",distance(k)
8069 c For Gaussian-type Urestr
8071 distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
8072 c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
8073 c write (iout,*) "distancek(",k,") =",distancek(k)
8074 c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
8076 c For Lorentzian-type Urestr
8078 if (waga_dist.lt.0.0d0) then
8079 sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
8080 distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
8081 & (distance(k)**2+sigma_odlir(k,ii)**2))
8085 c min_odl=minval(distancek)
8086 do kk=1,constr_homology
8087 if(l_homo(kk,ii)) then
8088 min_odl=distancek(kk)
8092 do kk=1,constr_homology
8093 if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
8094 & min_odl=distancek(kk)
8097 c write (iout,* )"min_odl",min_odl
8099 write (iout,*) "ij dij",i,j,dij
8100 write (iout,*) "distance",(distance(k),k=1,constr_homology)
8101 write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
8102 write (iout,* )"min_odl",min_odl
8107 if (waga_dist.ge.0.0d0) then
8113 do k=1,constr_homology
8114 c Nie wiem po co to liczycie jeszcze raz!
8115 c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
8116 c & (2*(sigma_odl(i,j,k))**2))
8117 if(.not.l_homo(k,ii)) cycle
8118 if (waga_dist.ge.0.0d0) then
8120 c For Gaussian-type Urestr
8122 godl(k)=dexp(-distancek(k)+min_odl)
8123 odleg2=odleg2+godl(k)
8125 c For Lorentzian-type Urestr
8128 odleg2=odleg2+distancek(k)
8131 ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
8132 ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
8133 ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
8134 ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
8137 c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8138 c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8140 write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
8141 write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
8143 if (waga_dist.ge.0.0d0) then
8145 c For Gaussian-type Urestr
8147 odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
8149 c For Lorentzian-type Urestr
8152 odleg=odleg+odleg2/constr_homology
8155 c write (iout,*) "odleg",odleg ! sum of -ln-s
8158 c For Gaussian-type Urestr
8160 if (waga_dist.ge.0.0d0) sum_godl=odleg2
8162 do k=1,constr_homology
8163 c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8164 c & *waga_dist)+min_odl
8165 c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
8167 if(.not.l_homo(k,ii)) cycle
8168 if (waga_dist.ge.0.0d0) then
8169 c For Gaussian-type Urestr
8171 sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
8173 c For Lorentzian-type Urestr
8176 sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
8177 & sigma_odlir(k,ii)**2)**2)
8179 sum_sgodl=sum_sgodl+sgodl
8181 c sgodl2=sgodl2+sgodl
8182 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
8183 c write(iout,*) "constr_homology=",constr_homology
8184 c write(iout,*) i, j, k, "TEST K"
8186 if (waga_dist.ge.0.0d0) then
8188 c For Gaussian-type Urestr
8190 grad_odl3=waga_homology(iset)*waga_dist
8191 & *sum_sgodl/(sum_godl*dij)
8193 c For Lorentzian-type Urestr
8196 c Original grad expr modified by analogy w Gaussian-type Urestr grad
8197 c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
8198 grad_odl3=-waga_homology(iset)*waga_dist*
8199 & sum_sgodl/(constr_homology*dij)
8202 c grad_odl3=sum_sgodl/(sum_godl*dij)
8205 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
8206 c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
8207 c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
8209 ccc write(iout,*) godl, sgodl, grad_odl3
8211 c grad_odl=grad_odl+grad_odl3
8214 ggodl=grad_odl3*(c(jik,i)-c(jik,j))
8215 ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
8216 ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
8217 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8218 ghpbc(jik,i)=ghpbc(jik,i)+ggodl
8219 ghpbc(jik,j)=ghpbc(jik,j)-ggodl
8220 ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
8221 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
8222 c if (i.eq.25.and.j.eq.27) then
8223 c write(iout,*) "jik",jik,"i",i,"j",j
8224 c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
8225 c write(iout,*) "grad_odl3",grad_odl3
8226 c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
8227 c write(iout,*) "ggodl",ggodl
8228 c write(iout,*) "ghpbc(",jik,i,")",
8229 c & ghpbc(jik,i),"ghpbc(",jik,j,")",
8233 ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
8234 ccc & dLOG(odleg2),"-odleg=", -odleg
8236 enddo ! ii-loop for dist
8238 write(iout,*) "------- dist restrs end -------"
8239 c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
8240 c & waga_d.eq.1.0d0) call sum_gradient
8242 c Pseudo-energy and gradient from dihedral-angle restraints from
8243 c homology templates
8244 c write (iout,*) "End of distance loop"
8247 c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8249 write(iout,*) "------- dih restrs start -------"
8250 do i=idihconstr_start_homo,idihconstr_end_homo
8251 write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8254 do i=idihconstr_start_homo,idihconstr_end_homo
8256 c betai=beta(i,i+1,i+2,i+3)
8258 c write (iout,*) "betai =",betai
8259 do k=1,constr_homology
8260 dih_diff(k)=pinorm(dih(k,i)-betai)
8261 cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8262 cd & ,sigma_dih(k,i)
8263 c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8264 c & -(6.28318-dih_diff(i,k))
8265 c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8266 c & 6.28318+dih_diff(i,k)
8268 kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8270 kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8272 c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8275 c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8278 c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8279 c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8281 write (iout,*) "i",i," betai",betai," kat2",kat2
8282 write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8284 if (kat2.le.1.0d-14) cycle
8285 kat=kat-dLOG(kat2/constr_homology)
8286 c write (iout,*) "kat",kat ! sum of -ln-s
8288 ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8289 ccc & dLOG(kat2), "-kat=", -kat
8291 c ----------------------------------------------------------------------
8293 c ----------------------------------------------------------------------
8297 do k=1,constr_homology
8299 sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
8301 sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd
8303 c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8304 sum_sgdih=sum_sgdih+sgdih
8306 c grad_dih3=sum_sgdih/sum_gdih
8307 grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8309 c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8310 ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8311 ccc & gloc(nphi+i-3,icg)
8312 gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8314 c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8316 ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8317 ccc & gloc(nphi+i-3,icg)
8319 enddo ! i-loop for dih
8321 write(iout,*) "------- dih restrs end -------"
8324 c Pseudo-energy and gradient for theta angle restraints from
8325 c homology templates
8326 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8330 c For constr_homology reference structures (FP)
8332 c Uconst_back_tot=0.0d0
8335 c Econstr_back legacy
8337 c do i=ithet_start,ithet_end
8340 c do i=loc_start,loc_end
8343 duscdiffx(j,i)=0.0d0
8348 c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8349 c write (iout,*) "waga_theta",waga_theta
8350 if (waga_theta.gt.0.0d0) then
8352 write (iout,*) "usampl",usampl
8353 write(iout,*) "------- theta restrs start -------"
8354 c do i=ithet_start,ithet_end
8355 c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8358 c write (iout,*) "maxres",maxres,"nres",nres
8360 do i=ithet_start,ithet_end
8363 c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8365 c Deviation of theta angles wrt constr_homology ref structures
8367 utheta_i=0.0d0 ! argument of Gaussian for single k
8368 gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8369 c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8370 c over residues in a fragment
8371 c write (iout,*) "theta(",i,")=",theta(i)
8372 do k=1,constr_homology
8374 c dtheta_i=theta(j)-thetaref(j,iref)
8375 c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8376 theta_diff(k)=thetatpl(k,i)-theta(i)
8377 cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8378 cd & ,sigma_theta(k,i)
8381 utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8382 c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8383 gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8384 gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk)
8385 c Gradient for single Gaussian restraint in subr Econstr_back
8386 c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8389 c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8390 c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8393 c Gradient for multiple Gaussian restraint
8394 sum_gtheta=gutheta_i
8396 do k=1,constr_homology
8397 c New generalized expr for multiple Gaussian from Econstr_back
8398 sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8400 c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8401 sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8403 c Final value of gradient using same var as in Econstr_back
8404 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8405 & +sum_sgtheta/sum_gtheta*waga_theta
8406 & *waga_homology(iset)
8407 c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8408 c & *waga_homology(iset)
8409 c dutheta(i)=sum_sgtheta/sum_gtheta
8411 c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8412 Eval=Eval-dLOG(gutheta_i/constr_homology)
8413 c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8414 c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8415 c Uconst_back=Uconst_back+utheta(i)
8416 enddo ! (i-loop for theta)
8418 write(iout,*) "------- theta restrs end -------"
8422 c Deviation of local SC geometry
8424 c Separation of two i-loops (instructed by AL - 11/3/2014)
8426 c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8427 c write (iout,*) "waga_d",waga_d
8430 write(iout,*) "------- SC restrs start -------"
8431 write (iout,*) "Initial duscdiff,duscdiffx"
8432 do i=loc_start,loc_end
8433 write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8434 & (duscdiffx(jik,i),jik=1,3)
8437 do i=loc_start,loc_end
8438 usc_diff_i=0.0d0 ! argument of Gaussian for single k
8439 guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8440 c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8441 c write(iout,*) "xxtab, yytab, zztab"
8442 c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8443 do k=1,constr_homology
8445 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8446 c Original sign inverted for calc of gradients (s. Econstr_back)
8447 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8448 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8449 c write(iout,*) "dxx, dyy, dzz"
8450 cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8452 usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
8453 c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8454 c uscdiffk(k)=usc_diff(i)
8455 guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8456 c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8457 c & " guscdiff2",guscdiff2(k)
8458 guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk)
8459 c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8460 c & xxref(j),yyref(j),zzref(j)
8465 c Generalized expression for multiple Gaussian acc to that for a single
8466 c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8468 c Original implementation
8469 c sum_guscdiff=guscdiff(i)
8471 c sum_sguscdiff=0.0d0
8472 c do k=1,constr_homology
8473 c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8474 c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8475 c sum_sguscdiff=sum_sguscdiff+sguscdiff
8478 c Implementation of new expressions for gradient (Jan. 2015)
8480 c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8481 do k=1,constr_homology
8483 c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8484 c before. Now the drivatives should be correct
8486 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8487 c Original sign inverted for calc of gradients (s. Econstr_back)
8488 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8489 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8491 c New implementation
8493 sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8494 & sigma_d(k,i) ! for the grad wrt r'
8495 c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8498 c New implementation
8499 sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8501 duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8502 & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8503 & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8504 duscdiff(jik,i)=duscdiff(jik,i)+
8505 & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8506 & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8507 duscdiffx(jik,i)=duscdiffx(jik,i)+
8508 & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8509 & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8512 write(iout,*) "jik",jik,"i",i
8513 write(iout,*) "dxx, dyy, dzz"
8514 write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8515 write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8516 c write(iout,*) "sum_sguscdiff",sum_sguscdiff
8517 cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8518 c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8519 c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8520 c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8521 c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8522 c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8523 c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8524 c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8525 c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8526 c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8527 c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8528 c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8534 c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
8535 c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8537 c write (iout,*) i," uscdiff",uscdiff(i)
8539 c Put together deviations from local geometry
8541 c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8542 c & wfrag_back(3,i,iset)*uscdiff(i)
8543 Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8544 c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8545 c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8546 c Uconst_back=Uconst_back+usc_diff(i)
8548 c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8550 c New implment: multiplied by sum_sguscdiff
8553 enddo ! (i-loop for dscdiff)
8558 write(iout,*) "------- SC restrs end -------"
8559 write (iout,*) "------ After SC loop in e_modeller ------"
8560 do i=loc_start,loc_end
8561 write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8562 write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8564 if (waga_theta.eq.1.0d0) then
8565 write (iout,*) "in e_modeller after SC restr end: dutheta"
8566 do i=ithet_start,ithet_end
8567 write (iout,*) i,dutheta(i)
8570 if (waga_d.eq.1.0d0) then
8571 write (iout,*) "e_modeller after SC loop: duscdiff/x"
8573 write (iout,*) i,(duscdiff(j,i),j=1,3)
8574 write (iout,*) i,(duscdiffx(j,i),j=1,3)
8579 c Total energy from homology restraints
8581 write (iout,*) "odleg",odleg," kat",kat
8584 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8586 c ehomology_constr=odleg+kat
8588 c For Lorentzian-type Urestr
8591 if (waga_dist.ge.0.0d0) then
8593 c For Gaussian-type Urestr
8595 ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8596 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8597 c write (iout,*) "ehomology_constr=",ehomology_constr
8600 c For Lorentzian-type Urestr
8602 ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8603 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8604 c write (iout,*) "ehomology_constr=",ehomology_constr
8607 write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8608 & "Eval",waga_theta,eval,
8609 & "Erot",waga_d,Erot
8610 write (iout,*) "ehomology_constr",ehomology_constr
8616 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8617 747 format(a12,i4,i4,i4,f8.3,f8.3)
8618 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8619 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8620 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8621 & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8623 c----------------------------------------------------------------------------
8624 C The rigorous attempt to derive energy function
8625 subroutine ebend_kcc(etheta)
8627 implicit real*8 (a-h,o-z)
8628 include 'DIMENSIONS'
8629 include 'COMMON.VAR'
8630 include 'COMMON.GEO'
8631 include 'COMMON.LOCAL'
8632 include 'COMMON.TORSION'
8633 include 'COMMON.INTERACT'
8634 include 'COMMON.DERIV'
8635 include 'COMMON.CHAIN'
8636 include 'COMMON.NAMES'
8637 include 'COMMON.IOUNITS'
8638 include 'COMMON.FFIELD'
8639 include 'COMMON.TORCNSTR'
8640 include 'COMMON.CONTROL'
8642 double precision thybt1(maxang_kcc)
8643 C Set lprn=.true. for debugging
8646 C print *,"wchodze kcc"
8647 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8649 do i=ithet_start,ithet_end
8650 c print *,i,itype(i-1),itype(i),itype(i-2)
8651 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8652 & .or.itype(i).eq.ntyp1) cycle
8653 iti=iabs(itortyp(itype(i-1)))
8654 sinthet=dsin(theta(i))
8655 costhet=dcos(theta(i))
8656 do j=1,nbend_kcc_Tb(iti)
8657 thybt1(j)=v1bend_chyb(j,iti)
8659 sumth1thyb=v1bend_chyb(0,iti)+
8660 & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8661 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8663 ihelp=nbend_kcc_Tb(iti)-1
8664 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8665 etheta=etheta+sumth1thyb
8666 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8667 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8671 c-------------------------------------------------------------------------------------
8672 subroutine etheta_constr(ethetacnstr)
8674 implicit real*8 (a-h,o-z)
8675 include 'DIMENSIONS'
8676 include 'COMMON.VAR'
8677 include 'COMMON.GEO'
8678 include 'COMMON.LOCAL'
8679 include 'COMMON.TORSION'
8680 include 'COMMON.INTERACT'
8681 include 'COMMON.DERIV'
8682 include 'COMMON.CHAIN'
8683 include 'COMMON.NAMES'
8684 include 'COMMON.IOUNITS'
8685 include 'COMMON.FFIELD'
8686 include 'COMMON.TORCNSTR'
8687 include 'COMMON.CONTROL'
8689 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8690 do i=ithetaconstr_start,ithetaconstr_end
8691 itheta=itheta_constr(i)
8692 thetiii=theta(itheta)
8693 difi=pinorm(thetiii-theta_constr0(i))
8694 if (difi.gt.theta_drange(i)) then
8695 difi=difi-theta_drange(i)
8696 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8697 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8698 & +for_thet_constr(i)*difi**3
8699 else if (difi.lt.-drange(i)) then
8701 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8702 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8703 & +for_thet_constr(i)*difi**3
8707 if (energy_dec) then
8708 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8709 & i,itheta,rad2deg*thetiii,
8710 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8711 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8712 & gloc(itheta+nphi-2,icg)
8717 c------------------------------------------------------------------------------
8718 subroutine eback_sc_corr(esccor)
8719 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8720 c conformational states; temporarily implemented as differences
8721 c between UNRES torsional potentials (dependent on three types of
8722 c residues) and the torsional potentials dependent on all 20 types
8723 c of residues computed from AM1 energy surfaces of terminally-blocked
8724 c amino-acid residues.
8725 implicit real*8 (a-h,o-z)
8726 include 'DIMENSIONS'
8727 include 'COMMON.VAR'
8728 include 'COMMON.GEO'
8729 include 'COMMON.LOCAL'
8730 include 'COMMON.TORSION'
8731 include 'COMMON.SCCOR'
8732 include 'COMMON.INTERACT'
8733 include 'COMMON.DERIV'
8734 include 'COMMON.CHAIN'
8735 include 'COMMON.NAMES'
8736 include 'COMMON.IOUNITS'
8737 include 'COMMON.FFIELD'
8738 include 'COMMON.CONTROL'
8740 C Set lprn=.true. for debugging
8743 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8745 do i=itau_start,itau_end
8746 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8748 isccori=isccortyp(itype(i-2))
8749 isccori1=isccortyp(itype(i-1))
8750 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8752 do intertyp=1,3 !intertyp
8753 cc Added 09 May 2012 (Adasko)
8754 cc Intertyp means interaction type of backbone mainchain correlation:
8755 c 1 = SC...Ca...Ca...Ca
8756 c 2 = Ca...Ca...Ca...SC
8757 c 3 = SC...Ca...Ca...SCi
8759 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8760 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8761 & (itype(i-1).eq.ntyp1)))
8762 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8763 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8764 & .or.(itype(i).eq.ntyp1)))
8765 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8766 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8767 & (itype(i-3).eq.ntyp1)))) cycle
8768 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8769 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8771 do j=1,nterm_sccor(isccori,isccori1)
8772 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8773 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8774 cosphi=dcos(j*tauangle(intertyp,i))
8775 sinphi=dsin(j*tauangle(intertyp,i))
8776 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8777 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8779 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8780 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8782 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8783 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8784 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8785 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8786 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8793 c----------------------------------------------------------------------------
8794 subroutine multibody(ecorr)
8795 C This subroutine calculates multi-body contributions to energy following
8796 C the idea of Skolnick et al. If side chains I and J make a contact and
8797 C at the same time side chains I+1 and J+1 make a contact, an extra
8798 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8799 implicit real*8 (a-h,o-z)
8800 include 'DIMENSIONS'
8801 include 'COMMON.IOUNITS'
8802 include 'COMMON.DERIV'
8803 include 'COMMON.INTERACT'
8804 include 'COMMON.CONTACTS'
8805 include 'COMMON.CONTMAT'
8806 include 'COMMON.CORRMAT'
8807 double precision gx(3),gx1(3)
8810 C Set lprn=.true. for debugging
8814 write (iout,'(a)') 'Contact function values:'
8816 write (iout,'(i2,20(1x,i2,f10.5))')
8817 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8832 num_conti=num_cont(i)
8833 num_conti1=num_cont(i1)
8838 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8839 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8840 cd & ' ishift=',ishift
8841 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8842 C The system gains extra energy.
8843 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8844 endif ! j1==j+-ishift
8853 c------------------------------------------------------------------------------
8854 double precision function esccorr(i,j,k,l,jj,kk)
8855 implicit real*8 (a-h,o-z)
8856 include 'DIMENSIONS'
8857 include 'COMMON.IOUNITS'
8858 include 'COMMON.DERIV'
8859 include 'COMMON.INTERACT'
8860 include 'COMMON.CONTACTS'
8861 include 'COMMON.CONTMAT'
8862 include 'COMMON.CORRMAT'
8863 include 'COMMON.SHIELD'
8864 double precision gx(3),gx1(3)
8869 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8870 C Calculate the multi-body contribution to energy.
8871 C Calculate multi-body contributions to the gradient.
8872 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8873 cd & k,l,(gacont(m,kk,k),m=1,3)
8875 gx(m) =ekl*gacont(m,jj,i)
8876 gx1(m)=eij*gacont(m,kk,k)
8877 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8878 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8879 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8880 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8884 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8889 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8895 c------------------------------------------------------------------------------
8896 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8897 C This subroutine calculates multi-body contributions to hydrogen-bonding
8898 implicit real*8 (a-h,o-z)
8899 include 'DIMENSIONS'
8900 include 'COMMON.IOUNITS'
8903 parameter (max_cont=maxconts)
8904 parameter (max_dim=26)
8905 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8906 double precision zapas(max_dim,maxconts,max_fg_procs),
8907 & zapas_recv(max_dim,maxconts,max_fg_procs)
8908 common /przechowalnia/ zapas
8909 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8910 & status_array(MPI_STATUS_SIZE,maxconts*2)
8912 include 'COMMON.SETUP'
8913 include 'COMMON.FFIELD'
8914 include 'COMMON.DERIV'
8915 include 'COMMON.INTERACT'
8916 include 'COMMON.CONTACTS'
8917 include 'COMMON.CONTMAT'
8918 include 'COMMON.CORRMAT'
8919 include 'COMMON.CONTROL'
8920 include 'COMMON.LOCAL'
8921 double precision gx(3),gx1(3),time00
8924 C Set lprn=.true. for debugging
8929 if (nfgtasks.le.1) goto 30
8931 write (iout,'(a)') 'Contact function values before RECEIVE:'
8933 write (iout,'(2i3,50(1x,i2,f5.2))')
8934 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8935 & j=1,num_cont_hb(i))
8939 do i=1,ntask_cont_from
8942 do i=1,ntask_cont_to
8945 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8947 C Make the list of contacts to send to send to other procesors
8948 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8950 do i=iturn3_start,iturn3_end
8951 c write (iout,*) "make contact list turn3",i," num_cont",
8953 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8955 do i=iturn4_start,iturn4_end
8956 c write (iout,*) "make contact list turn4",i," num_cont",
8958 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8962 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8964 do j=1,num_cont_hb(i)
8967 iproc=iint_sent_local(k,jjc,ii)
8968 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8969 if (iproc.gt.0) then
8970 ncont_sent(iproc)=ncont_sent(iproc)+1
8971 nn=ncont_sent(iproc)
8973 zapas(2,nn,iproc)=jjc
8974 zapas(3,nn,iproc)=facont_hb(j,i)
8975 zapas(4,nn,iproc)=ees0p(j,i)
8976 zapas(5,nn,iproc)=ees0m(j,i)
8977 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8978 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8979 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8980 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8981 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8982 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8983 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8984 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8985 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8986 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8987 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8988 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8989 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8990 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8991 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8992 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8993 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8994 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8995 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8996 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8997 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
9004 & "Numbers of contacts to be sent to other processors",
9005 & (ncont_sent(i),i=1,ntask_cont_to)
9006 write (iout,*) "Contacts sent"
9007 do ii=1,ntask_cont_to
9009 iproc=itask_cont_to(ii)
9010 write (iout,*) nn," contacts to processor",iproc,
9011 & " of CONT_TO_COMM group"
9013 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9021 CorrelID1=nfgtasks+fg_rank+1
9023 C Receive the numbers of needed contacts from other processors
9024 do ii=1,ntask_cont_from
9025 iproc=itask_cont_from(ii)
9027 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9028 & FG_COMM,req(ireq),IERR)
9030 c write (iout,*) "IRECV ended"
9032 C Send the number of contacts needed by other processors
9033 do ii=1,ntask_cont_to
9034 iproc=itask_cont_to(ii)
9036 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9037 & FG_COMM,req(ireq),IERR)
9039 c write (iout,*) "ISEND ended"
9040 c write (iout,*) "number of requests (nn)",ireq
9043 & call MPI_Waitall(ireq,req,status_array,ierr)
9045 c & "Numbers of contacts to be received from other processors",
9046 c & (ncont_recv(i),i=1,ntask_cont_from)
9050 do ii=1,ntask_cont_from
9051 iproc=itask_cont_from(ii)
9053 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9054 c & " of CONT_TO_COMM group"
9058 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9059 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9060 c write (iout,*) "ireq,req",ireq,req(ireq)
9063 C Send the contacts to processors that need them
9064 do ii=1,ntask_cont_to
9065 iproc=itask_cont_to(ii)
9067 c write (iout,*) nn," contacts to processor",iproc,
9068 c & " of CONT_TO_COMM group"
9071 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9072 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9073 c write (iout,*) "ireq,req",ireq,req(ireq)
9075 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9079 c write (iout,*) "number of requests (contacts)",ireq
9080 c write (iout,*) "req",(req(i),i=1,4)
9083 & call MPI_Waitall(ireq,req,status_array,ierr)
9084 do iii=1,ntask_cont_from
9085 iproc=itask_cont_from(iii)
9088 write (iout,*) "Received",nn," contacts from processor",iproc,
9089 & " of CONT_FROM_COMM group"
9092 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
9097 ii=zapas_recv(1,i,iii)
9098 c Flag the received contacts to prevent double-counting
9099 jj=-zapas_recv(2,i,iii)
9100 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9102 nnn=num_cont_hb(ii)+1
9105 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
9106 ees0p(nnn,ii)=zapas_recv(4,i,iii)
9107 ees0m(nnn,ii)=zapas_recv(5,i,iii)
9108 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
9109 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
9110 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
9111 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
9112 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
9113 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
9114 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
9115 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
9116 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
9117 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
9118 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
9119 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
9120 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
9121 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
9122 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
9123 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
9124 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
9125 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
9126 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
9127 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
9128 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
9132 write (iout,'(a)') 'Contact function values after receive:'
9134 write (iout,'(2i3,50(1x,i3,f5.2))')
9135 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9136 & j=1,num_cont_hb(i))
9143 write (iout,'(a)') 'Contact function values:'
9145 write (iout,'(2i3,50(1x,i3,f5.2))')
9146 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9147 & j=1,num_cont_hb(i))
9152 C Remove the loop below after debugging !!!
9159 C Calculate the local-electrostatic correlation terms
9160 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
9162 num_conti=num_cont_hb(i)
9163 num_conti1=num_cont_hb(i+1)
9170 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9171 c & ' jj=',jj,' kk=',kk
9173 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9174 & .or. j.lt.0 .and. j1.gt.0) .and.
9175 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9176 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9177 C The system gains extra energy.
9178 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
9179 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
9180 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
9182 else if (j1.eq.j) then
9183 C Contacts I-J and I-(J+1) occur simultaneously.
9184 C The system loses extra energy.
9185 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
9190 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9191 c & ' jj=',jj,' kk=',kk
9193 C Contacts I-J and (I+1)-J occur simultaneously.
9194 C The system loses extra energy.
9195 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
9202 c------------------------------------------------------------------------------
9203 subroutine add_hb_contact(ii,jj,itask)
9204 implicit real*8 (a-h,o-z)
9205 include "DIMENSIONS"
9206 include "COMMON.IOUNITS"
9209 parameter (max_cont=maxconts)
9210 parameter (max_dim=26)
9211 include "COMMON.CONTACTS"
9212 include 'COMMON.CONTMAT'
9213 include 'COMMON.CORRMAT'
9214 double precision zapas(max_dim,maxconts,max_fg_procs),
9215 & zapas_recv(max_dim,maxconts,max_fg_procs)
9216 common /przechowalnia/ zapas
9217 integer i,j,ii,jj,iproc,itask(4),nn
9218 c write (iout,*) "itask",itask
9221 if (iproc.gt.0) then
9222 do j=1,num_cont_hb(ii)
9224 c write (iout,*) "i",ii," j",jj," jjc",jjc
9226 ncont_sent(iproc)=ncont_sent(iproc)+1
9227 nn=ncont_sent(iproc)
9228 zapas(1,nn,iproc)=ii
9229 zapas(2,nn,iproc)=jjc
9230 zapas(3,nn,iproc)=facont_hb(j,ii)
9231 zapas(4,nn,iproc)=ees0p(j,ii)
9232 zapas(5,nn,iproc)=ees0m(j,ii)
9233 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
9234 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
9235 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
9236 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
9237 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
9238 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
9239 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
9240 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
9241 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
9242 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
9243 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
9244 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
9245 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
9246 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
9247 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
9248 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9249 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9250 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9251 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9252 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9253 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9261 c------------------------------------------------------------------------------
9262 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9264 C This subroutine calculates multi-body contributions to hydrogen-bonding
9265 implicit real*8 (a-h,o-z)
9266 include 'DIMENSIONS'
9267 include 'COMMON.IOUNITS'
9270 parameter (max_cont=maxconts)
9271 parameter (max_dim=70)
9272 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9273 double precision zapas(max_dim,maxconts,max_fg_procs),
9274 & zapas_recv(max_dim,maxconts,max_fg_procs)
9275 common /przechowalnia/ zapas
9276 integer status(MPI_STATUS_SIZE),req(maxconts*2),
9277 & status_array(MPI_STATUS_SIZE,maxconts*2)
9279 include 'COMMON.SETUP'
9280 include 'COMMON.FFIELD'
9281 include 'COMMON.DERIV'
9282 include 'COMMON.LOCAL'
9283 include 'COMMON.INTERACT'
9284 include 'COMMON.CONTACTS'
9285 include 'COMMON.CONTMAT'
9286 include 'COMMON.CORRMAT'
9287 include 'COMMON.CHAIN'
9288 include 'COMMON.CONTROL'
9289 include 'COMMON.SHIELD'
9290 double precision gx(3),gx1(3)
9291 integer num_cont_hb_old(maxres)
9293 double precision eello4,eello5,eelo6,eello_turn6
9294 external eello4,eello5,eello6,eello_turn6
9295 C Set lprn=.true. for debugging
9300 num_cont_hb_old(i)=num_cont_hb(i)
9304 if (nfgtasks.le.1) goto 30
9306 write (iout,'(a)') 'Contact function values before RECEIVE:'
9308 write (iout,'(2i3,50(1x,i2,f5.2))')
9309 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9310 & j=1,num_cont_hb(i))
9313 do i=1,ntask_cont_from
9316 do i=1,ntask_cont_to
9319 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9321 C Make the list of contacts to send to send to other procesors
9322 do i=iturn3_start,iturn3_end
9323 c write (iout,*) "make contact list turn3",i," num_cont",
9325 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9327 do i=iturn4_start,iturn4_end
9328 c write (iout,*) "make contact list turn4",i," num_cont",
9330 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9334 c write (iout,*) "make contact list longrange",i,ii," num_cont",
9336 do j=1,num_cont_hb(i)
9339 iproc=iint_sent_local(k,jjc,ii)
9340 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9341 if (iproc.ne.0) then
9342 ncont_sent(iproc)=ncont_sent(iproc)+1
9343 nn=ncont_sent(iproc)
9345 zapas(2,nn,iproc)=jjc
9346 zapas(3,nn,iproc)=d_cont(j,i)
9350 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9355 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9363 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9374 & "Numbers of contacts to be sent to other processors",
9375 & (ncont_sent(i),i=1,ntask_cont_to)
9376 write (iout,*) "Contacts sent"
9377 do ii=1,ntask_cont_to
9379 iproc=itask_cont_to(ii)
9380 write (iout,*) nn," contacts to processor",iproc,
9381 & " of CONT_TO_COMM group"
9383 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9391 CorrelID1=nfgtasks+fg_rank+1
9393 C Receive the numbers of needed contacts from other processors
9394 do ii=1,ntask_cont_from
9395 iproc=itask_cont_from(ii)
9397 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9398 & FG_COMM,req(ireq),IERR)
9400 c write (iout,*) "IRECV ended"
9402 C Send the number of contacts needed by other processors
9403 do ii=1,ntask_cont_to
9404 iproc=itask_cont_to(ii)
9406 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9407 & FG_COMM,req(ireq),IERR)
9409 c write (iout,*) "ISEND ended"
9410 c write (iout,*) "number of requests (nn)",ireq
9413 & call MPI_Waitall(ireq,req,status_array,ierr)
9415 c & "Numbers of contacts to be received from other processors",
9416 c & (ncont_recv(i),i=1,ntask_cont_from)
9420 do ii=1,ntask_cont_from
9421 iproc=itask_cont_from(ii)
9423 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9424 c & " of CONT_TO_COMM group"
9428 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9429 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9430 c write (iout,*) "ireq,req",ireq,req(ireq)
9433 C Send the contacts to processors that need them
9434 do ii=1,ntask_cont_to
9435 iproc=itask_cont_to(ii)
9437 c write (iout,*) nn," contacts to processor",iproc,
9438 c & " of CONT_TO_COMM group"
9441 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9442 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9443 c write (iout,*) "ireq,req",ireq,req(ireq)
9445 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9449 c write (iout,*) "number of requests (contacts)",ireq
9450 c write (iout,*) "req",(req(i),i=1,4)
9453 & call MPI_Waitall(ireq,req,status_array,ierr)
9454 do iii=1,ntask_cont_from
9455 iproc=itask_cont_from(iii)
9458 write (iout,*) "Received",nn," contacts from processor",iproc,
9459 & " of CONT_FROM_COMM group"
9462 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9467 ii=zapas_recv(1,i,iii)
9468 c Flag the received contacts to prevent double-counting
9469 jj=-zapas_recv(2,i,iii)
9470 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9472 nnn=num_cont_hb(ii)+1
9475 d_cont(nnn,ii)=zapas_recv(3,i,iii)
9479 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9484 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9492 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9500 write (iout,'(a)') 'Contact function values after receive:'
9502 write (iout,'(2i3,50(1x,i3,5f6.3))')
9503 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9504 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9511 write (iout,'(a)') 'Contact function values:'
9513 write (iout,'(2i3,50(1x,i2,5f6.3))')
9514 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9515 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9521 C Remove the loop below after debugging !!!
9528 C Calculate the dipole-dipole interaction energies
9529 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9530 do i=iatel_s,iatel_e+1
9531 num_conti=num_cont_hb(i)
9540 C Calculate the local-electrostatic correlation terms
9541 c write (iout,*) "gradcorr5 in eello5 before loop"
9543 c write (iout,'(i5,3f10.5)')
9544 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9546 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9547 c write (iout,*) "corr loop i",i
9549 num_conti=num_cont_hb(i)
9550 num_conti1=num_cont_hb(i+1)
9557 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9558 c & ' jj=',jj,' kk=',kk
9559 c if (j1.eq.j+1 .or. j1.eq.j-1) then
9560 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9561 & .or. j.lt.0 .and. j1.gt.0) .and.
9562 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9563 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9564 C The system gains extra energy.
9566 sqd1=dsqrt(d_cont(jj,i))
9567 sqd2=dsqrt(d_cont(kk,i1))
9568 sred_geom = sqd1*sqd2
9569 IF (sred_geom.lt.cutoff_corr) THEN
9570 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9572 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9573 cd & ' jj=',jj,' kk=',kk
9574 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9575 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9577 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9578 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9581 cd write (iout,*) 'sred_geom=',sred_geom,
9582 cd & ' ekont=',ekont,' fprim=',fprimcont,
9583 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9584 cd write (iout,*) "g_contij",g_contij
9585 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9586 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9587 call calc_eello(i,jp,i+1,jp1,jj,kk)
9588 if (wcorr4.gt.0.0d0)
9589 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9590 CC & *fac_shield(i)**2*fac_shield(j)**2
9591 if (energy_dec.and.wcorr4.gt.0.0d0)
9592 1 write (iout,'(a6,4i5,0pf7.3)')
9593 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9594 c write (iout,*) "gradcorr5 before eello5"
9596 c write (iout,'(i5,3f10.5)')
9597 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9599 if (wcorr5.gt.0.0d0)
9600 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9601 c write (iout,*) "gradcorr5 after eello5"
9603 c write (iout,'(i5,3f10.5)')
9604 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9606 if (energy_dec.and.wcorr5.gt.0.0d0)
9607 1 write (iout,'(a6,4i5,0pf7.3)')
9608 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9609 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9610 cd write(2,*)'ijkl',i,jp,i+1,jp1
9611 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9612 & .or. wturn6.eq.0.0d0))then
9613 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9614 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9615 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9616 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9617 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9618 cd & 'ecorr6=',ecorr6
9619 cd write (iout,'(4e15.5)') sred_geom,
9620 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9621 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9622 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9623 else if (wturn6.gt.0.0d0
9624 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9625 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9626 eturn6=eturn6+eello_turn6(i,jj,kk)
9627 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9628 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9629 cd write (2,*) 'multibody_eello:eturn6',eturn6
9638 num_cont_hb(i)=num_cont_hb_old(i)
9640 c write (iout,*) "gradcorr5 in eello5"
9642 c write (iout,'(i5,3f10.5)')
9643 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9647 c------------------------------------------------------------------------------
9648 subroutine add_hb_contact_eello(ii,jj,itask)
9649 implicit real*8 (a-h,o-z)
9650 include "DIMENSIONS"
9651 include "COMMON.IOUNITS"
9654 parameter (max_cont=maxconts)
9655 parameter (max_dim=70)
9656 include "COMMON.CONTACTS"
9657 include 'COMMON.CONTMAT'
9658 include 'COMMON.CORRMAT'
9659 double precision zapas(max_dim,maxconts,max_fg_procs),
9660 & zapas_recv(max_dim,maxconts,max_fg_procs)
9661 common /przechowalnia/ zapas
9662 integer i,j,ii,jj,iproc,itask(4),nn
9663 c write (iout,*) "itask",itask
9666 if (iproc.gt.0) then
9667 do j=1,num_cont_hb(ii)
9669 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9671 ncont_sent(iproc)=ncont_sent(iproc)+1
9672 nn=ncont_sent(iproc)
9673 zapas(1,nn,iproc)=ii
9674 zapas(2,nn,iproc)=jjc
9675 zapas(3,nn,iproc)=d_cont(j,ii)
9679 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9684 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9692 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9704 c------------------------------------------------------------------------------
9705 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9706 implicit real*8 (a-h,o-z)
9707 include 'DIMENSIONS'
9708 include 'COMMON.IOUNITS'
9709 include 'COMMON.DERIV'
9710 include 'COMMON.INTERACT'
9711 include 'COMMON.CONTACTS'
9712 include 'COMMON.CONTMAT'
9713 include 'COMMON.CORRMAT'
9714 include 'COMMON.SHIELD'
9715 include 'COMMON.CONTROL'
9716 double precision gx(3),gx1(3)
9719 C print *,"wchodze",fac_shield(i),shield_mode
9727 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9729 C & fac_shield(i)**2*fac_shield(j)**2
9730 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9731 C Following 4 lines for diagnostics.
9736 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9737 c & 'Contacts ',i,j,
9738 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9739 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9741 C Calculate the multi-body contribution to energy.
9742 C ecorr=ecorr+ekont*ees
9743 C Calculate multi-body contributions to the gradient.
9744 coeffpees0pij=coeffp*ees0pij
9745 coeffmees0mij=coeffm*ees0mij
9746 coeffpees0pkl=coeffp*ees0pkl
9747 coeffmees0mkl=coeffm*ees0mkl
9749 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9750 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9751 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9752 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9753 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9754 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9755 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9756 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9757 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9758 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9759 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9760 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9761 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9762 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9763 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9764 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9765 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9766 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9767 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9768 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9769 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9770 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9771 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9772 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9773 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9778 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9779 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9780 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9781 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9786 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9787 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9788 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9789 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9792 c write (iout,*) "ehbcorr",ekont*ees
9793 C print *,ekont,ees,i,k
9795 C now gradient over shielding
9797 if (shield_mode.gt.0) then
9800 C print *,i,j,fac_shield(i),fac_shield(j),
9801 C &fac_shield(k),fac_shield(l)
9802 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9803 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9804 do ilist=1,ishield_list(i)
9805 iresshield=shield_list(ilist,i)
9807 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9809 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9811 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9812 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9816 do ilist=1,ishield_list(j)
9817 iresshield=shield_list(ilist,j)
9819 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9821 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9823 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9824 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9829 do ilist=1,ishield_list(k)
9830 iresshield=shield_list(ilist,k)
9832 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9834 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9836 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9837 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9841 do ilist=1,ishield_list(l)
9842 iresshield=shield_list(ilist,l)
9844 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9846 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9848 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9849 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9853 C print *,gshieldx(m,iresshield)
9855 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9856 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9857 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9858 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9859 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9860 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9861 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9862 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9864 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9865 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9866 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9867 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9868 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9869 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9870 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9871 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9879 C---------------------------------------------------------------------------
9880 subroutine dipole(i,j,jj)
9881 implicit real*8 (a-h,o-z)
9882 include 'DIMENSIONS'
9883 include 'COMMON.IOUNITS'
9884 include 'COMMON.CHAIN'
9885 include 'COMMON.FFIELD'
9886 include 'COMMON.DERIV'
9887 include 'COMMON.INTERACT'
9888 include 'COMMON.CONTACTS'
9889 include 'COMMON.CONTMAT'
9890 include 'COMMON.CORRMAT'
9891 include 'COMMON.TORSION'
9892 include 'COMMON.VAR'
9893 include 'COMMON.GEO'
9894 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9896 iti1 = itortyp(itype(i+1))
9897 if (j.lt.nres-1) then
9898 itj1 = itype2loc(itype(j+1))
9903 dipi(iii,1)=Ub2(iii,i)
9904 dipderi(iii)=Ub2der(iii,i)
9905 dipi(iii,2)=b1(iii,i+1)
9906 dipj(iii,1)=Ub2(iii,j)
9907 dipderj(iii)=Ub2der(iii,j)
9908 dipj(iii,2)=b1(iii,j+1)
9912 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9915 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9922 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9926 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9931 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9932 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9934 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9936 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9938 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9943 C---------------------------------------------------------------------------
9944 subroutine calc_eello(i,j,k,l,jj,kk)
9946 C This subroutine computes matrices and vectors needed to calculate
9947 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9949 implicit real*8 (a-h,o-z)
9950 include 'DIMENSIONS'
9951 include 'COMMON.IOUNITS'
9952 include 'COMMON.CHAIN'
9953 include 'COMMON.DERIV'
9954 include 'COMMON.INTERACT'
9955 include 'COMMON.CONTACTS'
9956 include 'COMMON.CONTMAT'
9957 include 'COMMON.CORRMAT'
9958 include 'COMMON.TORSION'
9959 include 'COMMON.VAR'
9960 include 'COMMON.GEO'
9961 include 'COMMON.FFIELD'
9962 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9963 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9966 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9967 cd & ' jj=',jj,' kk=',kk
9968 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9969 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9970 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9973 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9974 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9977 call transpose2(aa1(1,1),aa1t(1,1))
9978 call transpose2(aa2(1,1),aa2t(1,1))
9981 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9982 & aa1tder(1,1,lll,kkk))
9983 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9984 & aa2tder(1,1,lll,kkk))
9988 C parallel orientation of the two CA-CA-CA frames.
9990 iti=itype2loc(itype(i))
9994 itk1=itype2loc(itype(k+1))
9995 itj=itype2loc(itype(j))
9996 if (l.lt.nres-1) then
9997 itl1=itype2loc(itype(l+1))
10001 C A1 kernel(j+1) A2T
10003 cd write (iout,'(3f10.5,5x,3f10.5)')
10004 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
10006 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10007 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
10008 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10009 C Following matrices are needed only for 6-th order cumulants
10010 IF (wcorr6.gt.0.0d0) THEN
10011 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10012 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
10013 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10014 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10015 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
10016 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10017 & ADtEAderx(1,1,1,1,1,1))
10019 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10020 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
10021 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10022 & ADtEA1derx(1,1,1,1,1,1))
10024 C End 6-th order cumulants
10027 cd write (2,*) 'In calc_eello6'
10029 cd write (2,*) 'iii=',iii
10031 cd write (2,*) 'kkk=',kkk
10033 cd write (2,'(3(2f10.5),5x)')
10034 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10039 call transpose2(EUgder(1,1,k),auxmat(1,1))
10040 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10041 call transpose2(EUg(1,1,k),auxmat(1,1))
10042 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10043 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10044 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
10045 c in theta; to be sriten later.
10047 c call transpose2(gtEE(1,1,k),auxmat(1,1))
10048 c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
10049 c call transpose2(EUg(1,1,k),auxmat(1,1))
10050 c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
10055 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10056 & EAEAderx(1,1,lll,kkk,iii,1))
10060 C A1T kernel(i+1) A2
10061 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10062 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
10063 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10064 C Following matrices are needed only for 6-th order cumulants
10065 IF (wcorr6.gt.0.0d0) THEN
10066 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10067 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
10068 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10069 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10070 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
10071 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10072 & ADtEAderx(1,1,1,1,1,2))
10073 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
10074 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
10075 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10076 & ADtEA1derx(1,1,1,1,1,2))
10078 C End 6-th order cumulants
10079 call transpose2(EUgder(1,1,l),auxmat(1,1))
10080 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
10081 call transpose2(EUg(1,1,l),auxmat(1,1))
10082 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10083 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10087 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10088 & EAEAderx(1,1,lll,kkk,iii,2))
10093 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10094 C They are needed only when the fifth- or the sixth-order cumulants are
10096 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
10097 call transpose2(AEA(1,1,1),auxmat(1,1))
10098 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10099 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10100 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10101 call transpose2(AEAderg(1,1,1),auxmat(1,1))
10102 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10103 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10104 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10105 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10106 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10107 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10108 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10109 call transpose2(AEA(1,1,2),auxmat(1,1))
10110 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
10111 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
10112 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
10113 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10114 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
10115 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
10116 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
10117 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
10118 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
10119 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
10120 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
10121 C Calculate the Cartesian derivatives of the vectors.
10125 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10126 call matvec2(auxmat(1,1),b1(1,i),
10127 & AEAb1derx(1,lll,kkk,iii,1,1))
10128 call matvec2(auxmat(1,1),Ub2(1,i),
10129 & AEAb2derx(1,lll,kkk,iii,1,1))
10130 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10131 & AEAb1derx(1,lll,kkk,iii,2,1))
10132 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10133 & AEAb2derx(1,lll,kkk,iii,2,1))
10134 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10135 call matvec2(auxmat(1,1),b1(1,j),
10136 & AEAb1derx(1,lll,kkk,iii,1,2))
10137 call matvec2(auxmat(1,1),Ub2(1,j),
10138 & AEAb2derx(1,lll,kkk,iii,1,2))
10139 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10140 & AEAb1derx(1,lll,kkk,iii,2,2))
10141 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
10142 & AEAb2derx(1,lll,kkk,iii,2,2))
10149 C Antiparallel orientation of the two CA-CA-CA frames.
10151 iti=itype2loc(itype(i))
10155 itk1=itype2loc(itype(k+1))
10156 itl=itype2loc(itype(l))
10157 itj=itype2loc(itype(j))
10158 if (j.lt.nres-1) then
10159 itj1=itype2loc(itype(j+1))
10163 C A2 kernel(j-1)T A1T
10164 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10165 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
10166 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
10167 C Following matrices are needed only for 6-th order cumulants
10168 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10169 & j.eq.i+4 .and. l.eq.i+3)) THEN
10170 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10171 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
10172 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
10173 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10174 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
10175 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
10176 & ADtEAderx(1,1,1,1,1,1))
10177 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
10178 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
10179 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
10180 & ADtEA1derx(1,1,1,1,1,1))
10182 C End 6-th order cumulants
10183 call transpose2(EUgder(1,1,k),auxmat(1,1))
10184 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
10185 call transpose2(EUg(1,1,k),auxmat(1,1))
10186 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
10187 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
10191 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10192 & EAEAderx(1,1,lll,kkk,iii,1))
10196 C A2T kernel(i+1)T A1
10197 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10198 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
10199 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
10200 C Following matrices are needed only for 6-th order cumulants
10201 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
10202 & j.eq.i+4 .and. l.eq.i+3)) THEN
10203 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10204 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
10205 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
10206 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10207 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
10208 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
10209 & ADtEAderx(1,1,1,1,1,2))
10210 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
10211 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
10212 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
10213 & ADtEA1derx(1,1,1,1,1,2))
10215 C End 6-th order cumulants
10216 call transpose2(EUgder(1,1,j),auxmat(1,1))
10217 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
10218 call transpose2(EUg(1,1,j),auxmat(1,1))
10219 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
10220 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
10224 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10225 & EAEAderx(1,1,lll,kkk,iii,2))
10230 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
10231 C They are needed only when the fifth- or the sixth-order cumulants are
10233 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
10234 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
10235 call transpose2(AEA(1,1,1),auxmat(1,1))
10236 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
10237 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
10238 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
10239 call transpose2(AEAderg(1,1,1),auxmat(1,1))
10240 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
10241 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
10242 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
10243 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
10244 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
10245 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
10246 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
10247 call transpose2(AEA(1,1,2),auxmat(1,1))
10248 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10249 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10250 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10251 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10252 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10253 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10254 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10255 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10256 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10257 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10258 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10259 C Calculate the Cartesian derivatives of the vectors.
10263 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10264 call matvec2(auxmat(1,1),b1(1,i),
10265 & AEAb1derx(1,lll,kkk,iii,1,1))
10266 call matvec2(auxmat(1,1),Ub2(1,i),
10267 & AEAb2derx(1,lll,kkk,iii,1,1))
10268 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10269 & AEAb1derx(1,lll,kkk,iii,2,1))
10270 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10271 & AEAb2derx(1,lll,kkk,iii,2,1))
10272 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10273 call matvec2(auxmat(1,1),b1(1,l),
10274 & AEAb1derx(1,lll,kkk,iii,1,2))
10275 call matvec2(auxmat(1,1),Ub2(1,l),
10276 & AEAb2derx(1,lll,kkk,iii,1,2))
10277 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10278 & AEAb1derx(1,lll,kkk,iii,2,2))
10279 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10280 & AEAb2derx(1,lll,kkk,iii,2,2))
10289 C---------------------------------------------------------------------------
10290 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10291 & KK,KKderg,AKA,AKAderg,AKAderx)
10295 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10296 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10297 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10298 integer iii,kkk,lll
10301 common /kutas/ lprn
10302 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10304 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10305 & AKAderg(1,1,iii))
10307 cd if (lprn) write (2,*) 'In kernel'
10309 cd if (lprn) write (2,*) 'kkk=',kkk
10311 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10312 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10314 cd write (2,*) 'lll=',lll
10315 cd write (2,*) 'iii=1'
10317 cd write (2,'(3(2f10.5),5x)')
10318 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10321 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10322 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10324 cd write (2,*) 'lll=',lll
10325 cd write (2,*) 'iii=2'
10327 cd write (2,'(3(2f10.5),5x)')
10328 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10335 C---------------------------------------------------------------------------
10336 double precision function eello4(i,j,k,l,jj,kk)
10337 implicit real*8 (a-h,o-z)
10338 include 'DIMENSIONS'
10339 include 'COMMON.IOUNITS'
10340 include 'COMMON.CHAIN'
10341 include 'COMMON.DERIV'
10342 include 'COMMON.INTERACT'
10343 include 'COMMON.CONTACTS'
10344 include 'COMMON.CONTMAT'
10345 include 'COMMON.CORRMAT'
10346 include 'COMMON.TORSION'
10347 include 'COMMON.VAR'
10348 include 'COMMON.GEO'
10349 double precision pizda(2,2),ggg1(3),ggg2(3)
10350 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10354 cd print *,'eello4:',i,j,k,l,jj,kk
10355 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
10356 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
10357 cold eij=facont_hb(jj,i)
10358 cold ekl=facont_hb(kk,k)
10360 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10361 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10362 gcorr_loc(k-1)=gcorr_loc(k-1)
10363 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10365 gcorr_loc(l-1)=gcorr_loc(l-1)
10366 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10367 C Al 4/16/16: Derivatives in theta, to be added later.
10369 c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10370 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10373 gcorr_loc(j-1)=gcorr_loc(j-1)
10374 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10376 c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10377 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10383 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10384 & -EAEAderx(2,2,lll,kkk,iii,1)
10385 cd derx(lll,kkk,iii)=0.0d0
10389 cd gcorr_loc(l-1)=0.0d0
10390 cd gcorr_loc(j-1)=0.0d0
10391 cd gcorr_loc(k-1)=0.0d0
10393 cd write (iout,*)'Contacts have occurred for peptide groups',
10394 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
10395 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10396 if (j.lt.nres-1) then
10403 if (l.lt.nres-1) then
10411 cgrad ggg1(ll)=eel4*g_contij(ll,1)
10412 cgrad ggg2(ll)=eel4*g_contij(ll,2)
10413 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10414 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10415 cgrad ghalf=0.5d0*ggg1(ll)
10416 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10417 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10418 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10419 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10420 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10421 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10422 cgrad ghalf=0.5d0*ggg2(ll)
10423 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10424 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10425 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10426 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10427 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10428 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10432 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10437 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10442 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10447 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10451 cd write (2,*) iii,gcorr_loc(iii)
10454 cd write (2,*) 'ekont',ekont
10455 cd write (iout,*) 'eello4',ekont*eel4
10458 C---------------------------------------------------------------------------
10459 double precision function eello5(i,j,k,l,jj,kk)
10460 implicit real*8 (a-h,o-z)
10461 include 'DIMENSIONS'
10462 include 'COMMON.IOUNITS'
10463 include 'COMMON.CHAIN'
10464 include 'COMMON.DERIV'
10465 include 'COMMON.INTERACT'
10466 include 'COMMON.CONTACTS'
10467 include 'COMMON.CONTMAT'
10468 include 'COMMON.CORRMAT'
10469 include 'COMMON.TORSION'
10470 include 'COMMON.VAR'
10471 include 'COMMON.GEO'
10472 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10473 double precision ggg1(3),ggg2(3)
10474 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10476 C Parallel chains C
10479 C /l\ / \ \ / \ / \ / C
10480 C / \ / \ \ / \ / \ / C
10481 C j| o |l1 | o | o| o | | o |o C
10482 C \ |/k\| |/ \| / |/ \| |/ \| C
10483 C \i/ \ / \ / / \ / \ C
10485 C (I) (II) (III) (IV) C
10487 C eello5_1 eello5_2 eello5_3 eello5_4 C
10489 C Antiparallel chains C
10492 C /j\ / \ \ / \ / \ / C
10493 C / \ / \ \ / \ / \ / C
10494 C j1| o |l | o | o| o | | o |o C
10495 C \ |/k\| |/ \| / |/ \| |/ \| C
10496 C \i/ \ / \ / / \ / \ C
10498 C (I) (II) (III) (IV) C
10500 C eello5_1 eello5_2 eello5_3 eello5_4 C
10502 C o denotes a local interaction, vertical lines an electrostatic interaction. C
10504 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10505 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10510 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
10512 itk=itype2loc(itype(k))
10513 itl=itype2loc(itype(l))
10514 itj=itype2loc(itype(j))
10519 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10520 cd & eel5_3_num,eel5_4_num)
10524 derx(lll,kkk,iii)=0.0d0
10528 cd eij=facont_hb(jj,i)
10529 cd ekl=facont_hb(kk,k)
10531 cd write (iout,*)'Contacts have occurred for peptide groups',
10532 cd & i,j,' fcont:',eij,' eij',' and ',k,l
10534 C Contribution from the graph I.
10535 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10536 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10537 call transpose2(EUg(1,1,k),auxmat(1,1))
10538 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10539 vv(1)=pizda(1,1)-pizda(2,2)
10540 vv(2)=pizda(1,2)+pizda(2,1)
10541 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10542 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10543 C Explicit gradient in virtual-dihedral angles.
10544 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10545 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10546 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10547 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10548 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10549 vv(1)=pizda(1,1)-pizda(2,2)
10550 vv(2)=pizda(1,2)+pizda(2,1)
10551 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10552 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10553 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10554 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10555 vv(1)=pizda(1,1)-pizda(2,2)
10556 vv(2)=pizda(1,2)+pizda(2,1)
10558 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10559 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10560 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10562 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10563 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10564 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10566 C Cartesian gradient
10570 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10572 vv(1)=pizda(1,1)-pizda(2,2)
10573 vv(2)=pizda(1,2)+pizda(2,1)
10574 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10575 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10576 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10582 C Contribution from graph II
10583 call transpose2(EE(1,1,k),auxmat(1,1))
10584 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10585 vv(1)=pizda(1,1)+pizda(2,2)
10586 vv(2)=pizda(2,1)-pizda(1,2)
10587 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10588 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10589 C Explicit gradient in virtual-dihedral angles.
10590 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10591 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10592 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10593 vv(1)=pizda(1,1)+pizda(2,2)
10594 vv(2)=pizda(2,1)-pizda(1,2)
10596 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10597 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10598 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10600 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10601 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10602 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10604 C Cartesian gradient
10608 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10610 vv(1)=pizda(1,1)+pizda(2,2)
10611 vv(2)=pizda(2,1)-pizda(1,2)
10612 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10613 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10614 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10622 C Parallel orientation
10623 C Contribution from graph III
10624 call transpose2(EUg(1,1,l),auxmat(1,1))
10625 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10626 vv(1)=pizda(1,1)-pizda(2,2)
10627 vv(2)=pizda(1,2)+pizda(2,1)
10628 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10629 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10630 C Explicit gradient in virtual-dihedral angles.
10631 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10632 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10633 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10634 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10635 vv(1)=pizda(1,1)-pizda(2,2)
10636 vv(2)=pizda(1,2)+pizda(2,1)
10637 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10638 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10639 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10640 call transpose2(EUgder(1,1,l),auxmat1(1,1))
10641 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10642 vv(1)=pizda(1,1)-pizda(2,2)
10643 vv(2)=pizda(1,2)+pizda(2,1)
10644 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10645 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10646 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10647 C Cartesian gradient
10651 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10653 vv(1)=pizda(1,1)-pizda(2,2)
10654 vv(2)=pizda(1,2)+pizda(2,1)
10655 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10656 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10657 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10662 C Contribution from graph IV
10664 call transpose2(EE(1,1,l),auxmat(1,1))
10665 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10666 vv(1)=pizda(1,1)+pizda(2,2)
10667 vv(2)=pizda(2,1)-pizda(1,2)
10668 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10669 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10670 C Explicit gradient in virtual-dihedral angles.
10671 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10672 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10673 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10674 vv(1)=pizda(1,1)+pizda(2,2)
10675 vv(2)=pizda(2,1)-pizda(1,2)
10676 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10677 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10678 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10679 C Cartesian gradient
10683 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10685 vv(1)=pizda(1,1)+pizda(2,2)
10686 vv(2)=pizda(2,1)-pizda(1,2)
10687 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10688 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10689 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10694 C Antiparallel orientation
10695 C Contribution from graph III
10697 call transpose2(EUg(1,1,j),auxmat(1,1))
10698 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10699 vv(1)=pizda(1,1)-pizda(2,2)
10700 vv(2)=pizda(1,2)+pizda(2,1)
10701 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10702 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10703 C Explicit gradient in virtual-dihedral angles.
10704 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10705 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10706 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10707 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10708 vv(1)=pizda(1,1)-pizda(2,2)
10709 vv(2)=pizda(1,2)+pizda(2,1)
10710 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10711 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10712 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10713 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10714 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10715 vv(1)=pizda(1,1)-pizda(2,2)
10716 vv(2)=pizda(1,2)+pizda(2,1)
10717 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10718 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10719 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10720 C Cartesian gradient
10724 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10726 vv(1)=pizda(1,1)-pizda(2,2)
10727 vv(2)=pizda(1,2)+pizda(2,1)
10728 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10729 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10730 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10735 C Contribution from graph IV
10737 call transpose2(EE(1,1,j),auxmat(1,1))
10738 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10739 vv(1)=pizda(1,1)+pizda(2,2)
10740 vv(2)=pizda(2,1)-pizda(1,2)
10741 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10742 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10743 C Explicit gradient in virtual-dihedral angles.
10744 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10745 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10746 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10747 vv(1)=pizda(1,1)+pizda(2,2)
10748 vv(2)=pizda(2,1)-pizda(1,2)
10749 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10750 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10751 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10752 C Cartesian gradient
10756 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10758 vv(1)=pizda(1,1)+pizda(2,2)
10759 vv(2)=pizda(2,1)-pizda(1,2)
10760 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10761 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10762 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10768 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10769 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10770 cd write (2,*) 'ijkl',i,j,k,l
10771 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10772 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10774 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10775 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10776 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10777 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10778 if (j.lt.nres-1) then
10785 if (l.lt.nres-1) then
10795 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10796 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10797 C summed up outside the subrouine as for the other subroutines
10798 C handling long-range interactions. The old code is commented out
10799 C with "cgrad" to keep track of changes.
10801 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10802 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10803 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10804 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10805 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10806 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10807 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10808 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10809 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10810 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10812 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10813 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10814 cgrad ghalf=0.5d0*ggg1(ll)
10816 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10817 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10818 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10819 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10820 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10821 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10822 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10823 cgrad ghalf=0.5d0*ggg2(ll)
10825 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10826 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10827 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10828 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10829 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10830 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10835 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10836 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10841 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10842 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10848 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10853 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10857 cd write (2,*) iii,g_corr5_loc(iii)
10860 cd write (2,*) 'ekont',ekont
10861 cd write (iout,*) 'eello5',ekont*eel5
10864 c--------------------------------------------------------------------------
10865 double precision function eello6(i,j,k,l,jj,kk)
10866 implicit real*8 (a-h,o-z)
10867 include 'DIMENSIONS'
10868 include 'COMMON.IOUNITS'
10869 include 'COMMON.CHAIN'
10870 include 'COMMON.DERIV'
10871 include 'COMMON.INTERACT'
10872 include 'COMMON.CONTACTS'
10873 include 'COMMON.CONTMAT'
10874 include 'COMMON.CORRMAT'
10875 include 'COMMON.TORSION'
10876 include 'COMMON.VAR'
10877 include 'COMMON.GEO'
10878 include 'COMMON.FFIELD'
10879 double precision ggg1(3),ggg2(3)
10880 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10885 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10893 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10894 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10898 derx(lll,kkk,iii)=0.0d0
10902 cd eij=facont_hb(jj,i)
10903 cd ekl=facont_hb(kk,k)
10909 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10910 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10911 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10912 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10913 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10914 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10916 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10917 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10918 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10919 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10920 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10921 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10925 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10927 C If turn contributions are considered, they will be handled separately.
10928 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10929 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10930 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10931 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10932 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10933 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10934 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10936 if (j.lt.nres-1) then
10943 if (l.lt.nres-1) then
10951 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10952 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10953 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10954 cgrad ghalf=0.5d0*ggg1(ll)
10956 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10957 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10958 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10959 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10960 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10961 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10962 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10963 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10964 cgrad ghalf=0.5d0*ggg2(ll)
10965 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10967 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10968 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10969 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10970 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10971 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10972 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10977 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10978 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10983 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10984 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10990 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10995 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10999 cd write (2,*) iii,g_corr6_loc(iii)
11002 cd write (2,*) 'ekont',ekont
11003 cd write (iout,*) 'eello6',ekont*eel6
11006 c--------------------------------------------------------------------------
11007 double precision function eello6_graph1(i,j,k,l,imat,swap)
11008 implicit real*8 (a-h,o-z)
11009 include 'DIMENSIONS'
11010 include 'COMMON.IOUNITS'
11011 include 'COMMON.CHAIN'
11012 include 'COMMON.DERIV'
11013 include 'COMMON.INTERACT'
11014 include 'COMMON.CONTACTS'
11015 include 'COMMON.CONTMAT'
11016 include 'COMMON.CORRMAT'
11017 include 'COMMON.TORSION'
11018 include 'COMMON.VAR'
11019 include 'COMMON.GEO'
11020 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
11023 common /kutas/ lprn
11024 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11026 C Parallel Antiparallel C
11032 C \ j|/k\| / \ |/k\|l / C
11033 C \ / \ / \ / \ / C
11037 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11038 itk=itype2loc(itype(k))
11039 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
11040 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
11041 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
11042 call transpose2(EUgC(1,1,k),auxmat(1,1))
11043 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11044 vv1(1)=pizda1(1,1)-pizda1(2,2)
11045 vv1(2)=pizda1(1,2)+pizda1(2,1)
11046 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11047 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
11048 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
11049 s5=scalar2(vv(1),Dtobr2(1,i))
11050 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
11051 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
11052 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
11053 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
11054 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
11055 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
11056 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
11057 & +scalar2(vv(1),Dtobr2der(1,i)))
11058 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
11059 vv1(1)=pizda1(1,1)-pizda1(2,2)
11060 vv1(2)=pizda1(1,2)+pizda1(2,1)
11061 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
11062 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
11064 g_corr6_loc(l-1)=g_corr6_loc(l-1)
11065 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11066 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11067 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11068 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11070 g_corr6_loc(j-1)=g_corr6_loc(j-1)
11071 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
11072 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
11073 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
11074 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
11076 call transpose2(EUgCder(1,1,k),auxmat(1,1))
11077 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
11078 vv1(1)=pizda1(1,1)-pizda1(2,2)
11079 vv1(2)=pizda1(1,2)+pizda1(2,1)
11080 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
11081 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
11082 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
11083 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
11092 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
11093 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
11094 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
11095 call transpose2(EUgC(1,1,k),auxmat(1,1))
11096 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11098 vv1(1)=pizda1(1,1)-pizda1(2,2)
11099 vv1(2)=pizda1(1,2)+pizda1(2,1)
11100 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
11101 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
11102 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
11103 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
11104 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
11105 s5=scalar2(vv(1),Dtobr2(1,i))
11106 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
11112 c----------------------------------------------------------------------------
11113 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
11114 implicit real*8 (a-h,o-z)
11115 include 'DIMENSIONS'
11116 include 'COMMON.IOUNITS'
11117 include 'COMMON.CHAIN'
11118 include 'COMMON.DERIV'
11119 include 'COMMON.INTERACT'
11120 include 'COMMON.CONTACTS'
11121 include 'COMMON.CONTMAT'
11122 include 'COMMON.CORRMAT'
11123 include 'COMMON.TORSION'
11124 include 'COMMON.VAR'
11125 include 'COMMON.GEO'
11127 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11128 & auxvec1(2),auxvec2(2),auxmat1(2,2)
11130 common /kutas/ lprn
11131 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11133 C Parallel Antiparallel C
11139 C \ j|/k\| \ |/k\|l C
11144 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11145 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
11146 C AL 7/4/01 s1 would occur in the sixth-order moment,
11147 C but not in a cluster cumulant
11149 s1=dip(1,jj,i)*dip(1,kk,k)
11151 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
11152 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11153 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
11154 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
11155 call transpose2(EUg(1,1,k),auxmat(1,1))
11156 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
11157 vv(1)=pizda(1,1)-pizda(2,2)
11158 vv(2)=pizda(1,2)+pizda(2,1)
11159 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11160 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11162 eello6_graph2=-(s1+s2+s3+s4)
11164 eello6_graph2=-(s2+s3+s4)
11166 c eello6_graph2=-s3
11167 C Derivatives in gamma(i-1)
11170 s1=dipderg(1,jj,i)*dip(1,kk,k)
11172 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11173 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
11174 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11175 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11177 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11179 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11181 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
11183 C Derivatives in gamma(k-1)
11185 s1=dip(1,jj,i)*dipderg(1,kk,k)
11187 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
11188 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11189 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
11190 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11191 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11192 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
11193 vv(1)=pizda(1,1)-pizda(2,2)
11194 vv(2)=pizda(1,2)+pizda(2,1)
11195 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11197 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11199 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11201 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
11202 C Derivatives in gamma(j-1) or gamma(l-1)
11205 s1=dipderg(3,jj,i)*dip(1,kk,k)
11207 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
11208 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11209 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
11210 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
11211 vv(1)=pizda(1,1)-pizda(2,2)
11212 vv(2)=pizda(1,2)+pizda(2,1)
11213 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11216 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11218 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11221 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
11222 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
11224 C Derivatives in gamma(l-1) or gamma(j-1)
11227 s1=dip(1,jj,i)*dipderg(3,kk,k)
11229 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
11230 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
11231 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
11232 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
11233 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
11234 vv(1)=pizda(1,1)-pizda(2,2)
11235 vv(2)=pizda(1,2)+pizda(2,1)
11236 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11239 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
11241 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
11244 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
11245 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
11247 C Cartesian derivatives.
11249 write (2,*) 'In eello6_graph2'
11251 write (2,*) 'iii=',iii
11253 write (2,*) 'kkk=',kkk
11255 write (2,'(3(2f10.5),5x)')
11256 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11266 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11268 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11271 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11273 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11274 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11276 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11277 call transpose2(EUg(1,1,k),auxmat(1,1))
11278 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11280 vv(1)=pizda(1,1)-pizda(2,2)
11281 vv(2)=pizda(1,2)+pizda(2,1)
11282 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11283 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11285 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11287 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11290 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11292 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11299 c----------------------------------------------------------------------------
11300 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11301 implicit real*8 (a-h,o-z)
11302 include 'DIMENSIONS'
11303 include 'COMMON.IOUNITS'
11304 include 'COMMON.CHAIN'
11305 include 'COMMON.DERIV'
11306 include 'COMMON.INTERACT'
11307 include 'COMMON.CONTACTS'
11308 include 'COMMON.CONTMAT'
11309 include 'COMMON.CORRMAT'
11310 include 'COMMON.TORSION'
11311 include 'COMMON.VAR'
11312 include 'COMMON.GEO'
11313 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11315 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11317 C Parallel Antiparallel C
11322 C /| o |o o| o |\ C
11323 C j|/k\| / |/k\|l / C
11328 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11330 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11331 C energy moment and not to the cluster cumulant.
11332 iti=itortyp(itype(i))
11333 if (j.lt.nres-1) then
11334 itj1=itype2loc(itype(j+1))
11338 itk=itype2loc(itype(k))
11339 itk1=itype2loc(itype(k+1))
11340 if (l.lt.nres-1) then
11341 itl1=itype2loc(itype(l+1))
11346 s1=dip(4,jj,i)*dip(4,kk,k)
11348 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11349 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11350 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11351 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11352 call transpose2(EE(1,1,k),auxmat(1,1))
11353 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11354 vv(1)=pizda(1,1)+pizda(2,2)
11355 vv(2)=pizda(2,1)-pizda(1,2)
11356 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11357 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11358 cd & "sum",-(s2+s3+s4)
11360 eello6_graph3=-(s1+s2+s3+s4)
11362 eello6_graph3=-(s2+s3+s4)
11364 c eello6_graph3=-s4
11365 C Derivatives in gamma(k-1)
11366 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11367 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11368 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11369 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11370 C Derivatives in gamma(l-1)
11371 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11372 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11373 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11374 vv(1)=pizda(1,1)+pizda(2,2)
11375 vv(2)=pizda(2,1)-pizda(1,2)
11376 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11377 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11378 C Cartesian derivatives.
11384 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11386 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11389 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11391 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11392 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11394 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11395 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11397 vv(1)=pizda(1,1)+pizda(2,2)
11398 vv(2)=pizda(2,1)-pizda(1,2)
11399 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11401 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11403 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11406 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11408 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11410 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11416 c----------------------------------------------------------------------------
11417 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11418 implicit real*8 (a-h,o-z)
11419 include 'DIMENSIONS'
11420 include 'COMMON.IOUNITS'
11421 include 'COMMON.CHAIN'
11422 include 'COMMON.DERIV'
11423 include 'COMMON.INTERACT'
11424 include 'COMMON.CONTACTS'
11425 include 'COMMON.CONTMAT'
11426 include 'COMMON.CORRMAT'
11427 include 'COMMON.TORSION'
11428 include 'COMMON.VAR'
11429 include 'COMMON.GEO'
11430 include 'COMMON.FFIELD'
11431 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11432 & auxvec1(2),auxmat1(2,2)
11434 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11436 C Parallel Antiparallel C
11441 C /| o |o o| o |\ C
11442 C \ j|/k\| \ |/k\|l C
11447 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11449 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11450 C energy moment and not to the cluster cumulant.
11451 cd write (2,*) 'eello_graph4: wturn6',wturn6
11452 iti=itype2loc(itype(i))
11453 itj=itype2loc(itype(j))
11454 if (j.lt.nres-1) then
11455 itj1=itype2loc(itype(j+1))
11459 itk=itype2loc(itype(k))
11460 if (k.lt.nres-1) then
11461 itk1=itype2loc(itype(k+1))
11465 itl=itype2loc(itype(l))
11466 if (l.lt.nres-1) then
11467 itl1=itype2loc(itype(l+1))
11471 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11472 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11473 cd & ' itl',itl,' itl1',itl1
11475 if (imat.eq.1) then
11476 s1=dip(3,jj,i)*dip(3,kk,k)
11478 s1=dip(2,jj,j)*dip(2,kk,l)
11481 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11482 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11484 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11485 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11487 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11488 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11490 call transpose2(EUg(1,1,k),auxmat(1,1))
11491 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11492 vv(1)=pizda(1,1)-pizda(2,2)
11493 vv(2)=pizda(2,1)+pizda(1,2)
11494 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11495 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11497 eello6_graph4=-(s1+s2+s3+s4)
11499 eello6_graph4=-(s2+s3+s4)
11501 C Derivatives in gamma(i-1)
11504 if (imat.eq.1) then
11505 s1=dipderg(2,jj,i)*dip(3,kk,k)
11507 s1=dipderg(4,jj,j)*dip(2,kk,l)
11510 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11512 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11513 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11515 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11516 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11518 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11519 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11520 cd write (2,*) 'turn6 derivatives'
11522 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11524 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11528 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11530 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11534 C Derivatives in gamma(k-1)
11536 if (imat.eq.1) then
11537 s1=dip(3,jj,i)*dipderg(2,kk,k)
11539 s1=dip(2,jj,j)*dipderg(4,kk,l)
11542 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11543 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11545 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11546 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11548 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11549 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11551 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11552 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11553 vv(1)=pizda(1,1)-pizda(2,2)
11554 vv(2)=pizda(2,1)+pizda(1,2)
11555 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11556 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11558 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11560 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11564 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11566 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11569 C Derivatives in gamma(j-1) or gamma(l-1)
11570 if (l.eq.j+1 .and. l.gt.1) then
11571 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11572 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11573 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11574 vv(1)=pizda(1,1)-pizda(2,2)
11575 vv(2)=pizda(2,1)+pizda(1,2)
11576 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11577 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11578 else if (j.gt.1) then
11579 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11580 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11581 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11582 vv(1)=pizda(1,1)-pizda(2,2)
11583 vv(2)=pizda(2,1)+pizda(1,2)
11584 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11585 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11586 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11588 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11591 C Cartesian derivatives.
11597 if (imat.eq.1) then
11598 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11600 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11603 if (imat.eq.1) then
11604 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11606 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11610 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11612 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11614 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11615 & b1(1,j+1),auxvec(1))
11616 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11618 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11619 & b1(1,l+1),auxvec(1))
11620 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11622 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11624 vv(1)=pizda(1,1)-pizda(2,2)
11625 vv(2)=pizda(2,1)+pizda(1,2)
11626 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11628 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11630 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11633 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11636 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11639 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11641 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11643 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11647 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11649 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11652 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11654 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11662 c----------------------------------------------------------------------------
11663 double precision function eello_turn6(i,jj,kk)
11664 implicit real*8 (a-h,o-z)
11665 include 'DIMENSIONS'
11666 include 'COMMON.IOUNITS'
11667 include 'COMMON.CHAIN'
11668 include 'COMMON.DERIV'
11669 include 'COMMON.INTERACT'
11670 include 'COMMON.CONTACTS'
11671 include 'COMMON.CONTMAT'
11672 include 'COMMON.CORRMAT'
11673 include 'COMMON.TORSION'
11674 include 'COMMON.VAR'
11675 include 'COMMON.GEO'
11676 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11677 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11679 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11680 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11681 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11682 C the respective energy moment and not to the cluster cumulant.
11691 iti=itype2loc(itype(i))
11692 itk=itype2loc(itype(k))
11693 itk1=itype2loc(itype(k+1))
11694 itl=itype2loc(itype(l))
11695 itj=itype2loc(itype(j))
11696 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11697 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11698 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11703 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11705 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11709 derx_turn(lll,kkk,iii)=0.0d0
11716 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11718 cd write (2,*) 'eello6_5',eello6_5
11720 call transpose2(AEA(1,1,1),auxmat(1,1))
11721 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11722 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11723 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11725 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11726 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11727 s2 = scalar2(b1(1,k),vtemp1(1))
11729 call transpose2(AEA(1,1,2),atemp(1,1))
11730 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11731 call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11732 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11734 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11735 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11736 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11738 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11739 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11740 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11741 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11742 ss13 = scalar2(b1(1,k),vtemp4(1))
11743 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11745 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11751 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11752 C Derivatives in gamma(i+2)
11756 call transpose2(AEA(1,1,1),auxmatd(1,1))
11757 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11758 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11759 call transpose2(AEAderg(1,1,2),atempd(1,1))
11760 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11761 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11763 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11764 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11765 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11771 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11772 C Derivatives in gamma(i+3)
11774 call transpose2(AEA(1,1,1),auxmatd(1,1))
11775 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11776 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11777 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11779 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11780 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11781 s2d = scalar2(b1(1,k),vtemp1d(1))
11783 call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11784 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11786 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11788 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11789 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11790 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11798 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11799 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11801 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11802 & -0.5d0*ekont*(s2d+s12d)
11804 C Derivatives in gamma(i+4)
11805 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11806 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11807 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11809 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11810 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11811 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11819 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11821 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11823 C Derivatives in gamma(i+5)
11825 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11826 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11827 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11829 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11830 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11831 s2d = scalar2(b1(1,k),vtemp1d(1))
11833 call transpose2(AEA(1,1,2),atempd(1,1))
11834 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11835 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11837 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11838 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11840 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11841 ss13d = scalar2(b1(1,k),vtemp4d(1))
11842 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11850 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11851 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11853 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11854 & -0.5d0*ekont*(s2d+s12d)
11856 C Cartesian derivatives
11861 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11862 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11863 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11865 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11866 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11868 s2d = scalar2(b1(1,k),vtemp1d(1))
11870 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11871 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11872 s8d = -(atempd(1,1)+atempd(2,2))*
11873 & scalar2(cc(1,1,l),vtemp2(1))
11875 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11877 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11878 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11885 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11886 & - 0.5d0*(s1d+s2d)
11888 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11892 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11893 & - 0.5d0*(s8d+s12d)
11895 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11904 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11905 & achuj_tempd(1,1))
11906 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11907 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11908 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11909 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11910 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11912 ss13d = scalar2(b1(1,k),vtemp4d(1))
11913 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11914 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11918 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11919 cd & 16*eel_turn6_num
11921 if (j.lt.nres-1) then
11928 if (l.lt.nres-1) then
11936 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11937 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11938 cgrad ghalf=0.5d0*ggg1(ll)
11940 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11941 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11942 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11943 & +ekont*derx_turn(ll,2,1)
11944 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11945 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11946 & +ekont*derx_turn(ll,4,1)
11947 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11948 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11949 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11950 cgrad ghalf=0.5d0*ggg2(ll)
11952 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11953 & +ekont*derx_turn(ll,2,2)
11954 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11955 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11956 & +ekont*derx_turn(ll,4,2)
11957 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11958 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11959 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11964 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11969 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11975 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11980 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11984 cd write (2,*) iii,g_corr6_loc(iii)
11986 eello_turn6=ekont*eel_turn6
11987 cd write (2,*) 'ekont',ekont
11988 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11991 C-----------------------------------------------------------------------------
11993 double precision function scalar(u,v)
11994 !DIR$ INLINEALWAYS scalar
11996 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11999 double precision u(3),v(3)
12000 cd double precision sc
12008 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
12011 crc-------------------------------------------------
12012 SUBROUTINE MATVEC2(A1,V1,V2)
12013 !DIR$ INLINEALWAYS MATVEC2
12015 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
12017 implicit real*8 (a-h,o-z)
12018 include 'DIMENSIONS'
12019 DIMENSION A1(2,2),V1(2),V2(2)
12023 c 3 VI=VI+A1(I,K)*V1(K)
12027 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
12028 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
12033 C---------------------------------------
12034 SUBROUTINE MATMAT2(A1,A2,A3)
12036 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
12038 implicit real*8 (a-h,o-z)
12039 include 'DIMENSIONS'
12040 DIMENSION A1(2,2),A2(2,2),A3(2,2)
12041 c DIMENSION AI3(2,2)
12045 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
12051 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
12052 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
12053 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
12054 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
12062 c-------------------------------------------------------------------------
12063 double precision function scalar2(u,v)
12064 !DIR$ INLINEALWAYS scalar2
12066 double precision u(2),v(2)
12067 double precision sc
12069 scalar2=u(1)*v(1)+u(2)*v(2)
12073 C-----------------------------------------------------------------------------
12075 subroutine transpose2(a,at)
12076 !DIR$ INLINEALWAYS transpose2
12078 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
12081 double precision a(2,2),at(2,2)
12088 c--------------------------------------------------------------------------
12089 subroutine transpose(n,a,at)
12092 double precision a(n,n),at(n,n)
12100 C---------------------------------------------------------------------------
12101 subroutine prodmat3(a1,a2,kk,transp,prod)
12102 !DIR$ INLINEALWAYS prodmat3
12104 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
12108 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
12110 crc double precision auxmat(2,2),prod_(2,2)
12113 crc call transpose2(kk(1,1),auxmat(1,1))
12114 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
12115 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12117 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
12118 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
12119 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
12120 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
12121 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
12122 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
12123 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
12124 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
12127 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
12128 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
12130 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
12131 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
12132 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
12133 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
12134 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
12135 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
12136 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
12137 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
12140 c call transpose2(a2(1,1),a2t(1,1))
12143 crc print *,((prod_(i,j),i=1,2),j=1,2)
12144 crc print *,((prod(i,j),i=1,2),j=1,2)
12148 CCC----------------------------------------------
12149 subroutine Eliptransfer(eliptran)
12150 implicit real*8 (a-h,o-z)
12151 include 'DIMENSIONS'
12152 include 'COMMON.GEO'
12153 include 'COMMON.VAR'
12154 include 'COMMON.LOCAL'
12155 include 'COMMON.CHAIN'
12156 include 'COMMON.DERIV'
12157 include 'COMMON.NAMES'
12158 include 'COMMON.INTERACT'
12159 include 'COMMON.IOUNITS'
12160 include 'COMMON.CALC'
12161 include 'COMMON.CONTROL'
12162 include 'COMMON.SPLITELE'
12163 include 'COMMON.SBRIDGE'
12164 C this is done by Adasko
12165 C print *,"wchodze"
12166 C structure of box:
12168 C--bordliptop-- buffore starts
12169 C--bufliptop--- here true lipid starts
12171 C--buflipbot--- lipid ends buffore starts
12172 C--bordlipbot--buffore ends
12174 do i=ilip_start,ilip_end
12176 if (itype(i).eq.ntyp1) cycle
12178 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
12179 if (positi.le.0.0) positi=positi+boxzsize
12181 C first for peptide groups
12182 c for each residue check if it is in lipid or lipid water border area
12183 if ((positi.gt.bordlipbot)
12184 &.and.(positi.lt.bordliptop)) then
12185 C the energy transfer exist
12186 if (positi.lt.buflipbot) then
12187 C what fraction I am in
12189 & ((positi-bordlipbot)/lipbufthick)
12190 C lipbufthick is thickenes of lipid buffore
12191 sslip=sscalelip(fracinbuf)
12192 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12193 eliptran=eliptran+sslip*pepliptran
12194 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12195 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12196 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12198 C print *,"doing sccale for lower part"
12199 C print *,i,sslip,fracinbuf,ssgradlip
12200 elseif (positi.gt.bufliptop) then
12201 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
12202 sslip=sscalelip(fracinbuf)
12203 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12204 eliptran=eliptran+sslip*pepliptran
12205 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
12206 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
12207 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
12208 C print *, "doing sscalefor top part"
12209 C print *,i,sslip,fracinbuf,ssgradlip
12211 eliptran=eliptran+pepliptran
12212 C print *,"I am in true lipid"
12215 C eliptran=elpitran+0.0 ! I am in water
12218 C print *, "nic nie bylo w lipidzie?"
12219 C now multiply all by the peptide group transfer factor
12220 C eliptran=eliptran*pepliptran
12221 C now the same for side chains
12223 do i=ilip_start,ilip_end
12224 if (itype(i).eq.ntyp1) cycle
12225 positi=(mod(c(3,i+nres),boxzsize))
12226 if (positi.le.0) positi=positi+boxzsize
12227 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12228 c for each residue check if it is in lipid or lipid water border area
12229 C respos=mod(c(3,i+nres),boxzsize)
12230 C print *,positi,bordlipbot,buflipbot
12231 if ((positi.gt.bordlipbot)
12232 & .and.(positi.lt.bordliptop)) then
12233 C the energy transfer exist
12234 if (positi.lt.buflipbot) then
12236 & ((positi-bordlipbot)/lipbufthick)
12237 C lipbufthick is thickenes of lipid buffore
12238 sslip=sscalelip(fracinbuf)
12239 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
12240 eliptran=eliptran+sslip*liptranene(itype(i))
12241 gliptranx(3,i)=gliptranx(3,i)
12242 &+ssgradlip*liptranene(itype(i))
12243 gliptranc(3,i-1)= gliptranc(3,i-1)
12244 &+ssgradlip*liptranene(itype(i))
12245 C print *,"doing sccale for lower part"
12246 elseif (positi.gt.bufliptop) then
12248 &((bordliptop-positi)/lipbufthick)
12249 sslip=sscalelip(fracinbuf)
12250 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12251 eliptran=eliptran+sslip*liptranene(itype(i))
12252 gliptranx(3,i)=gliptranx(3,i)
12253 &+ssgradlip*liptranene(itype(i))
12254 gliptranc(3,i-1)= gliptranc(3,i-1)
12255 &+ssgradlip*liptranene(itype(i))
12256 C print *, "doing sscalefor top part",sslip,fracinbuf
12258 eliptran=eliptran+liptranene(itype(i))
12259 C print *,"I am in true lipid"
12261 endif ! if in lipid or buffor
12263 C eliptran=elpitran+0.0 ! I am in water
12267 C---------------------------------------------------------
12268 C AFM soubroutine for constant force
12269 subroutine AFMforce(Eafmforce)
12270 implicit real*8 (a-h,o-z)
12271 include 'DIMENSIONS'
12272 include 'COMMON.GEO'
12273 include 'COMMON.VAR'
12274 include 'COMMON.LOCAL'
12275 include 'COMMON.CHAIN'
12276 include 'COMMON.DERIV'
12277 include 'COMMON.NAMES'
12278 include 'COMMON.INTERACT'
12279 include 'COMMON.IOUNITS'
12280 include 'COMMON.CALC'
12281 include 'COMMON.CONTROL'
12282 include 'COMMON.SPLITELE'
12283 include 'COMMON.SBRIDGE'
12288 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12289 dist=dist+diffafm(i)**2
12292 Eafmforce=-forceAFMconst*(dist-distafminit)
12294 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12295 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12297 C print *,'AFM',Eafmforce
12300 C---------------------------------------------------------
12301 C AFM subroutine with pseudoconstant velocity
12302 subroutine AFMvel(Eafmforce)
12303 implicit real*8 (a-h,o-z)
12304 include 'DIMENSIONS'
12305 include 'COMMON.GEO'
12306 include 'COMMON.VAR'
12307 include 'COMMON.LOCAL'
12308 include 'COMMON.CHAIN'
12309 include 'COMMON.DERIV'
12310 include 'COMMON.NAMES'
12311 include 'COMMON.INTERACT'
12312 include 'COMMON.IOUNITS'
12313 include 'COMMON.CALC'
12314 include 'COMMON.CONTROL'
12315 include 'COMMON.SPLITELE'
12316 include 'COMMON.SBRIDGE'
12318 C Only for check grad COMMENT if not used for checkgrad
12320 C--------------------------------------------------------
12321 C print *,"wchodze"
12325 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12326 dist=dist+diffafm(i)**2
12329 Eafmforce=0.5d0*forceAFMconst
12330 & *(distafminit+totTafm*velAFMconst-dist)**2
12331 C Eafmforce=-forceAFMconst*(dist-distafminit)
12333 gradafm(i,afmend-1)=-forceAFMconst*
12334 &(distafminit+totTafm*velAFMconst-dist)
12336 gradafm(i,afmbeg-1)=forceAFMconst*
12337 &(distafminit+totTafm*velAFMconst-dist)
12340 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12343 C-----------------------------------------------------------
12344 C first for shielding is setting of function of side-chains
12345 subroutine set_shield_fac
12346 implicit real*8 (a-h,o-z)
12347 include 'DIMENSIONS'
12348 include 'COMMON.CHAIN'
12349 include 'COMMON.DERIV'
12350 include 'COMMON.IOUNITS'
12351 include 'COMMON.SHIELD'
12352 include 'COMMON.INTERACT'
12353 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12354 double precision div77_81/0.974996043d0/,
12355 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12357 C the vector between center of side_chain and peptide group
12358 double precision pep_side(3),long,side_calf(3),
12359 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12360 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12361 C the line belowe needs to be changed for FGPROC>1
12363 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12365 Cif there two consequtive dummy atoms there is no peptide group between them
12366 C the line below has to be changed for FGPROC>1
12369 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12373 C first lets set vector conecting the ithe side-chain with kth side-chain
12374 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12375 C pep_side(j)=2.0d0
12376 C and vector conecting the side-chain with its proper calfa
12377 side_calf(j)=c(j,k+nres)-c(j,k)
12378 C side_calf(j)=2.0d0
12379 pept_group(j)=c(j,i)-c(j,i+1)
12380 C lets have their lenght
12381 dist_pep_side=pep_side(j)**2+dist_pep_side
12382 dist_side_calf=dist_side_calf+side_calf(j)**2
12383 dist_pept_group=dist_pept_group+pept_group(j)**2
12385 dist_pep_side=dsqrt(dist_pep_side)
12386 dist_pept_group=dsqrt(dist_pept_group)
12387 dist_side_calf=dsqrt(dist_side_calf)
12389 pep_side_norm(j)=pep_side(j)/dist_pep_side
12390 side_calf_norm(j)=dist_side_calf
12392 C now sscale fraction
12393 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12394 C print *,buff_shield,"buff"
12396 if (sh_frac_dist.le.0.0) cycle
12397 C If we reach here it means that this side chain reaches the shielding sphere
12398 C Lets add him to the list for gradient
12399 ishield_list(i)=ishield_list(i)+1
12400 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12401 C this list is essential otherwise problem would be O3
12402 shield_list(ishield_list(i),i)=k
12403 C Lets have the sscale value
12404 if (sh_frac_dist.gt.1.0) then
12405 scale_fac_dist=1.0d0
12407 sh_frac_dist_grad(j)=0.0d0
12410 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12411 & *(2.0*sh_frac_dist-3.0d0)
12412 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12413 & /dist_pep_side/buff_shield*0.5
12414 C remember for the final gradient multiply sh_frac_dist_grad(j)
12415 C for side_chain by factor -2 !
12417 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12418 C print *,"jestem",scale_fac_dist,fac_help_scale,
12419 C & sh_frac_dist_grad(j)
12422 C if ((i.eq.3).and.(k.eq.2)) then
12423 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12427 C this is what is now we have the distance scaling now volume...
12428 short=short_r_sidechain(itype(k))
12429 long=long_r_sidechain(itype(k))
12430 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12433 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12434 C costhet_fac=0.0d0
12436 costhet_grad(j)=costhet_fac*pep_side(j)
12438 C remember for the final gradient multiply costhet_grad(j)
12439 C for side_chain by factor -2 !
12440 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12441 C pep_side0pept_group is vector multiplication
12442 pep_side0pept_group=0.0
12444 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12446 cosalfa=(pep_side0pept_group/
12447 & (dist_pep_side*dist_side_calf))
12448 fac_alfa_sin=1.0-cosalfa**2
12449 fac_alfa_sin=dsqrt(fac_alfa_sin)
12450 rkprim=fac_alfa_sin*(long-short)+short
12452 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12453 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12456 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12457 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12458 &*(long-short)/fac_alfa_sin*cosalfa/
12459 &((dist_pep_side*dist_side_calf))*
12460 &((side_calf(j))-cosalfa*
12461 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12463 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12464 &*(long-short)/fac_alfa_sin*cosalfa
12465 &/((dist_pep_side*dist_side_calf))*
12467 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12470 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12473 C now the gradient...
12474 C grad_shield is gradient of Calfa for peptide groups
12475 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12477 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12478 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12480 grad_shield(j,i)=grad_shield(j,i)
12481 C gradient po skalowaniu
12482 & +(sh_frac_dist_grad(j)
12483 C gradient po costhet
12484 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12485 &-scale_fac_dist*(cosphi_grad_long(j))
12486 &/(1.0-cosphi) )*div77_81
12488 C grad_shield_side is Cbeta sidechain gradient
12489 grad_shield_side(j,ishield_list(i),i)=
12490 & (sh_frac_dist_grad(j)*(-2.0d0)
12491 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12492 & +scale_fac_dist*(cosphi_grad_long(j))
12493 & *2.0d0/(1.0-cosphi))
12494 & *div77_81*VofOverlap
12496 grad_shield_loc(j,ishield_list(i),i)=
12497 & scale_fac_dist*cosphi_grad_loc(j)
12498 & *2.0d0/(1.0-cosphi)
12499 & *div77_81*VofOverlap
12501 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12503 fac_shield(i)=VolumeTotal*div77_81+div4_81
12504 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12508 C--------------------------------------------------------------------------
12509 double precision function tschebyshev(m,n,x,y)
12511 include "DIMENSIONS"
12513 double precision x(n),y,yy(0:maxvar),aux
12514 c Tschebyshev polynomial. Note that the first term is omitted
12515 c m=0: the constant term is included
12516 c m=1: the constant term is not included
12520 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12529 C--------------------------------------------------------------------------
12530 double precision function gradtschebyshev(m,n,x,y)
12532 include "DIMENSIONS"
12534 double precision x(n+1),y,yy(0:maxvar),aux
12535 c Tschebyshev polynomial. Note that the first term is omitted
12536 c m=0: the constant term is included
12537 c m=1: the constant term is not included
12541 yy(i)=2*y*yy(i-1)-yy(i-2)
12545 aux=aux+x(i+1)*yy(i)*(i+1)
12546 C print *, x(i+1),yy(i),i
12548 gradtschebyshev=aux
12551 C------------------------------------------------------------------------
12552 C first for shielding is setting of function of side-chains
12553 subroutine set_shield_fac2
12554 implicit real*8 (a-h,o-z)
12555 include 'DIMENSIONS'
12556 include 'COMMON.CHAIN'
12557 include 'COMMON.DERIV'
12558 include 'COMMON.IOUNITS'
12559 include 'COMMON.SHIELD'
12560 include 'COMMON.INTERACT'
12561 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12562 double precision div77_81/0.974996043d0/,
12563 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12565 C the vector between center of side_chain and peptide group
12566 double precision pep_side(3),long,side_calf(3),
12567 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12568 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12569 C the line belowe needs to be changed for FGPROC>1
12571 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12573 Cif there two consequtive dummy atoms there is no peptide group between them
12574 C the line below has to be changed for FGPROC>1
12577 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12581 C first lets set vector conecting the ithe side-chain with kth side-chain
12582 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12583 C pep_side(j)=2.0d0
12584 C and vector conecting the side-chain with its proper calfa
12585 side_calf(j)=c(j,k+nres)-c(j,k)
12586 C side_calf(j)=2.0d0
12587 pept_group(j)=c(j,i)-c(j,i+1)
12588 C lets have their lenght
12589 dist_pep_side=pep_side(j)**2+dist_pep_side
12590 dist_side_calf=dist_side_calf+side_calf(j)**2
12591 dist_pept_group=dist_pept_group+pept_group(j)**2
12593 dist_pep_side=dsqrt(dist_pep_side)
12594 dist_pept_group=dsqrt(dist_pept_group)
12595 dist_side_calf=dsqrt(dist_side_calf)
12597 pep_side_norm(j)=pep_side(j)/dist_pep_side
12598 side_calf_norm(j)=dist_side_calf
12600 C now sscale fraction
12601 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12602 C print *,buff_shield,"buff"
12604 if (sh_frac_dist.le.0.0) cycle
12605 C If we reach here it means that this side chain reaches the shielding sphere
12606 C Lets add him to the list for gradient
12607 ishield_list(i)=ishield_list(i)+1
12608 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12609 C this list is essential otherwise problem would be O3
12610 shield_list(ishield_list(i),i)=k
12611 C Lets have the sscale value
12612 if (sh_frac_dist.gt.1.0) then
12613 scale_fac_dist=1.0d0
12615 sh_frac_dist_grad(j)=0.0d0
12618 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12619 & *(2.0d0*sh_frac_dist-3.0d0)
12620 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12621 & /dist_pep_side/buff_shield*0.5d0
12622 C remember for the final gradient multiply sh_frac_dist_grad(j)
12623 C for side_chain by factor -2 !
12625 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12626 C sh_frac_dist_grad(j)=0.0d0
12627 C scale_fac_dist=1.0d0
12628 C print *,"jestem",scale_fac_dist,fac_help_scale,
12629 C & sh_frac_dist_grad(j)
12632 C this is what is now we have the distance scaling now volume...
12633 short=short_r_sidechain(itype(k))
12634 long=long_r_sidechain(itype(k))
12635 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12636 sinthet=short/dist_pep_side*costhet
12640 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12641 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12642 C & -short/dist_pep_side**2/costhet)
12643 C costhet_fac=0.0d0
12645 costhet_grad(j)=costhet_fac*pep_side(j)
12647 C remember for the final gradient multiply costhet_grad(j)
12648 C for side_chain by factor -2 !
12649 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12650 C pep_side0pept_group is vector multiplication
12651 pep_side0pept_group=0.0d0
12653 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12655 cosalfa=(pep_side0pept_group/
12656 & (dist_pep_side*dist_side_calf))
12657 fac_alfa_sin=1.0d0-cosalfa**2
12658 fac_alfa_sin=dsqrt(fac_alfa_sin)
12659 rkprim=fac_alfa_sin*(long-short)+short
12663 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12665 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12666 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12667 & dist_pep_side**2)
12670 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12671 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12672 &*(long-short)/fac_alfa_sin*cosalfa/
12673 &((dist_pep_side*dist_side_calf))*
12674 &((side_calf(j))-cosalfa*
12675 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12676 C cosphi_grad_long(j)=0.0d0
12677 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12678 &*(long-short)/fac_alfa_sin*cosalfa
12679 &/((dist_pep_side*dist_side_calf))*
12681 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12682 C cosphi_grad_loc(j)=0.0d0
12684 C print *,sinphi,sinthet
12685 c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12686 c & VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12687 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12690 C now the gradient...
12692 grad_shield(j,i)=grad_shield(j,i)
12693 C gradient po skalowaniu
12694 & +(sh_frac_dist_grad(j)*VofOverlap
12695 C gradient po costhet
12696 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12697 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12698 & sinphi/sinthet*costhet*costhet_grad(j)
12699 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12701 C grad_shield_side is Cbeta sidechain gradient
12702 grad_shield_side(j,ishield_list(i),i)=
12703 & (sh_frac_dist_grad(j)*(-2.0d0)
12705 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12706 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12707 & sinphi/sinthet*costhet*costhet_grad(j)
12708 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12711 grad_shield_loc(j,ishield_list(i),i)=
12712 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12713 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12714 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12718 c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12720 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12722 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12723 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12724 c & " wshield",wshield
12725 c write(2,*) "TU",rpp(1,1),short,long,buff_shield
12729 C-----------------------------------------------------------------------
12730 C-----------------------------------------------------------
12731 C This subroutine is to mimic the histone like structure but as well can be
12732 C utilizet to nanostructures (infinit) small modification has to be used to
12733 C make it finite (z gradient at the ends has to be changes as well as the x,y
12734 C gradient has to be modified at the ends
12735 C The energy function is Kihara potential
12736 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12737 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12738 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12739 C simple Kihara potential
12740 subroutine calctube(Etube)
12741 implicit real*8 (a-h,o-z)
12742 include 'DIMENSIONS'
12743 include 'COMMON.GEO'
12744 include 'COMMON.VAR'
12745 include 'COMMON.LOCAL'
12746 include 'COMMON.CHAIN'
12747 include 'COMMON.DERIV'
12748 include 'COMMON.NAMES'
12749 include 'COMMON.INTERACT'
12750 include 'COMMON.IOUNITS'
12751 include 'COMMON.CALC'
12752 include 'COMMON.CONTROL'
12753 include 'COMMON.SPLITELE'
12754 include 'COMMON.SBRIDGE'
12755 double precision tub_r,vectube(3),enetube(maxres*2)
12760 C first we calculate the distance from tube center
12761 C first sugare-phosphate group for NARES this would be peptide group
12764 C lets ommit dummy atoms for now
12765 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12766 C now calculate distance from center of tube and direction vectors
12767 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12768 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12769 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12770 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12771 vectube(1)=vectube(1)-tubecenter(1)
12772 vectube(2)=vectube(2)-tubecenter(2)
12774 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12775 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12777 C as the tube is infinity we do not calculate the Z-vector use of Z
12780 C now calculte the distance
12781 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12782 C now normalize vector
12783 vectube(1)=vectube(1)/tub_r
12784 vectube(2)=vectube(2)/tub_r
12785 C calculte rdiffrence between r and r0
12788 rdiff6=rdiff**6.0d0
12789 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12790 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12791 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12792 C print *,rdiff,rdiff6,pep_aa_tube
12793 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12794 C now we calculate gradient
12795 fac=(-12.0d0*pep_aa_tube/rdiff6+
12796 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12797 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12800 C now direction of gg_tube vector
12802 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12803 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12806 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12808 C Lets not jump over memory as we use many times iti
12810 C lets ommit dummy atoms for now
12812 C in UNRES uncomment the line below as GLY has no side-chain...
12815 vectube(1)=c(1,i+nres)
12816 vectube(1)=mod(vectube(1),boxxsize)
12817 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12818 vectube(2)=c(2,i+nres)
12819 vectube(2)=mod(vectube(2),boxxsize)
12820 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12822 vectube(1)=vectube(1)-tubecenter(1)
12823 vectube(2)=vectube(2)-tubecenter(2)
12825 C as the tube is infinity we do not calculate the Z-vector use of Z
12828 C now calculte the distance
12829 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12830 C now normalize vector
12831 vectube(1)=vectube(1)/tub_r
12832 vectube(2)=vectube(2)/tub_r
12833 C calculte rdiffrence between r and r0
12836 rdiff6=rdiff**6.0d0
12837 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12838 sc_aa_tube=sc_aa_tube_par(iti)
12839 sc_bb_tube=sc_bb_tube_par(iti)
12840 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12841 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12842 C now we calculate gradient
12843 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12844 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12845 C now direction of gg_tube vector
12847 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12848 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12852 Etube=Etube+enetube(i)
12854 C print *,"ETUBE", etube
12857 C TO DO 1) add to total energy
12858 C 2) add to gradient summation
12859 C 3) add reading parameters (AND of course oppening of PARAM file)
12860 C 4) add reading the center of tube
12862 C 6) add to zerograd
12864 C-----------------------------------------------------------------------
12865 C-----------------------------------------------------------
12866 C This subroutine is to mimic the histone like structure but as well can be
12867 C utilizet to nanostructures (infinit) small modification has to be used to
12868 C make it finite (z gradient at the ends has to be changes as well as the x,y
12869 C gradient has to be modified at the ends
12870 C The energy function is Kihara potential
12871 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12872 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12873 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12874 C simple Kihara potential
12875 subroutine calctube2(Etube)
12876 implicit real*8 (a-h,o-z)
12877 include 'DIMENSIONS'
12878 include 'COMMON.GEO'
12879 include 'COMMON.VAR'
12880 include 'COMMON.LOCAL'
12881 include 'COMMON.CHAIN'
12882 include 'COMMON.DERIV'
12883 include 'COMMON.NAMES'
12884 include 'COMMON.INTERACT'
12885 include 'COMMON.IOUNITS'
12886 include 'COMMON.CALC'
12887 include 'COMMON.CONTROL'
12888 include 'COMMON.SPLITELE'
12889 include 'COMMON.SBRIDGE'
12890 double precision tub_r,vectube(3),enetube(maxres*2)
12895 C first we calculate the distance from tube center
12896 C first sugare-phosphate group for NARES this would be peptide group
12899 C lets ommit dummy atoms for now
12900 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12901 C now calculate distance from center of tube and direction vectors
12902 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12903 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12904 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12905 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12906 vectube(1)=vectube(1)-tubecenter(1)
12907 vectube(2)=vectube(2)-tubecenter(2)
12909 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12910 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12912 C as the tube is infinity we do not calculate the Z-vector use of Z
12915 C now calculte the distance
12916 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12917 C now normalize vector
12918 vectube(1)=vectube(1)/tub_r
12919 vectube(2)=vectube(2)/tub_r
12920 C calculte rdiffrence between r and r0
12923 rdiff6=rdiff**6.0d0
12924 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12925 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12926 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12927 C print *,rdiff,rdiff6,pep_aa_tube
12928 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12929 C now we calculate gradient
12930 fac=(-12.0d0*pep_aa_tube/rdiff6+
12931 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12932 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12935 C now direction of gg_tube vector
12937 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12938 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12941 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12943 C Lets not jump over memory as we use many times iti
12945 C lets ommit dummy atoms for now
12947 C in UNRES uncomment the line below as GLY has no side-chain...
12950 vectube(1)=c(1,i+nres)
12951 vectube(1)=mod(vectube(1),boxxsize)
12952 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12953 vectube(2)=c(2,i+nres)
12954 vectube(2)=mod(vectube(2),boxxsize)
12955 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12957 vectube(1)=vectube(1)-tubecenter(1)
12958 vectube(2)=vectube(2)-tubecenter(2)
12959 C THIS FRAGMENT MAKES TUBE FINITE
12960 positi=(mod(c(3,i+nres),boxzsize))
12961 if (positi.le.0) positi=positi+boxzsize
12962 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12963 c for each residue check if it is in lipid or lipid water border area
12964 C respos=mod(c(3,i+nres),boxzsize)
12965 print *,positi,bordtubebot,buftubebot,bordtubetop
12966 if ((positi.gt.bordtubebot)
12967 & .and.(positi.lt.bordtubetop)) then
12968 C the energy transfer exist
12969 if (positi.lt.buftubebot) then
12971 & ((positi-bordtubebot)/tubebufthick)
12972 C lipbufthick is thickenes of lipid buffore
12973 sstube=sscalelip(fracinbuf)
12974 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12975 print *,ssgradtube, sstube,tubetranene(itype(i))
12976 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12977 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12978 &+ssgradtube*tubetranene(itype(i))
12979 gg_tube(3,i-1)= gg_tube(3,i-1)
12980 &+ssgradtube*tubetranene(itype(i))
12981 C print *,"doing sccale for lower part"
12982 elseif (positi.gt.buftubetop) then
12984 &((bordtubetop-positi)/tubebufthick)
12985 sstube=sscalelip(fracinbuf)
12986 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12987 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12988 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12989 C &+ssgradtube*tubetranene(itype(i))
12990 C gg_tube(3,i-1)= gg_tube(3,i-1)
12991 C &+ssgradtube*tubetranene(itype(i))
12992 C print *, "doing sscalefor top part",sslip,fracinbuf
12996 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12997 C print *,"I am in true lipid"
13003 endif ! if in lipid or buffor
13004 CEND OF FINITE FRAGMENT
13005 C as the tube is infinity we do not calculate the Z-vector use of Z
13008 C now calculte the distance
13009 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
13010 C now normalize vector
13011 vectube(1)=vectube(1)/tub_r
13012 vectube(2)=vectube(2)/tub_r
13013 C calculte rdiffrence between r and r0
13016 rdiff6=rdiff**6.0d0
13017 C for vectorization reasons we will sumup at the end to avoid depenence of previous
13018 sc_aa_tube=sc_aa_tube_par(iti)
13019 sc_bb_tube=sc_bb_tube_par(iti)
13020 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
13021 & *sstube+enetube(i+nres)
13022 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
13023 C now we calculate gradient
13024 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
13025 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
13026 C now direction of gg_tube vector
13028 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
13029 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
13031 gg_tube_SC(3,i)=gg_tube_SC(3,i)
13032 &+ssgradtube*enetube(i+nres)/sstube
13033 gg_tube(3,i-1)= gg_tube(3,i-1)
13034 &+ssgradtube*enetube(i+nres)/sstube
13038 Etube=Etube+enetube(i)
13040 C print *,"ETUBE", etube
13043 C TO DO 1) add to total energy
13044 C 2) add to gradient summation
13045 C 3) add reading parameters (AND of course oppening of PARAM file)
13046 C 4) add reading the center of tube
13048 C 6) add to zerograd
13049 c----------------------------------------------------------------------------
13050 subroutine e_saxs(Esaxs_constr)
13052 include 'DIMENSIONS'
13055 include "COMMON.SETUP"
13058 include 'COMMON.SBRIDGE'
13059 include 'COMMON.CHAIN'
13060 include 'COMMON.GEO'
13061 include 'COMMON.DERIV'
13062 include 'COMMON.LOCAL'
13063 include 'COMMON.INTERACT'
13064 include 'COMMON.VAR'
13065 include 'COMMON.IOUNITS'
13066 c include 'COMMON.MD'
13069 include 'COMMON.LANGEVIN.lang0.5diag'
13071 include 'COMMON.LANGEVIN.lang0'
13074 include 'COMMON.LANGEVIN'
13076 include 'COMMON.CONTROL'
13077 include 'COMMON.SAXS'
13078 include 'COMMON.NAMES'
13079 include 'COMMON.TIME1'
13080 include 'COMMON.FFIELD'
13082 double precision Esaxs_constr
13083 integer i,iint,j,k,l
13084 double precision PgradC(maxSAXS,3,maxres),
13085 & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
13087 double precision PgradC_(maxSAXS,3,maxres),
13088 & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
13090 double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
13091 & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
13092 & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
13093 & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
13094 double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
13095 double precision dist,mygauss,mygaussder
13097 integer llicz,lllicz
13098 double precision time01
13099 c SAXS restraint penalty function
13101 write(iout,*) "------- SAXS penalty function start -------"
13102 write (iout,*) "nsaxs",nsaxs
13103 write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
13104 write (iout,*) "Psaxs"
13106 write (iout,'(i5,e15.5)') i, Psaxs(i)
13112 Esaxs_constr = 0.0d0
13117 PgradC(k,l,j)=0.0d0
13118 PgradX(k,l,j)=0.0d0
13123 do i=iatsc_s,iatsc_e
13124 if (itype(i).eq.ntyp1) cycle
13125 do iint=1,nint_gr(i)
13126 do j=istart(i,iint),iend(i,iint)
13127 if (itype(j).eq.ntyp1) cycle
13130 dijCASC=dist(i,j+nres)
13131 dijSCCA=dist(i+nres,j)
13132 dijSCSC=dist(i+nres,j+nres)
13133 sigma2CACA=2.0d0/(pstok**2)
13134 sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
13135 sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
13136 sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
13139 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13140 if (itype(j).ne.10) then
13141 expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
13145 if (itype(i).ne.10) then
13146 expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
13150 if (itype(i).ne.10 .and. itype(j).ne.10) then
13151 expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
13155 Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
13157 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13159 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13160 CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
13161 SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
13162 SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
13165 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13166 PgradC(k,l,i) = PgradC(k,l,i)-aux
13167 PgradC(k,l,j) = PgradC(k,l,j)+aux
13169 if (itype(j).ne.10) then
13170 aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
13171 PgradC(k,l,i) = PgradC(k,l,i)-aux
13172 PgradC(k,l,j) = PgradC(k,l,j)+aux
13173 PgradX(k,l,j) = PgradX(k,l,j)+aux
13176 if (itype(i).ne.10) then
13177 aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
13178 PgradX(k,l,i) = PgradX(k,l,i)-aux
13179 PgradC(k,l,i) = PgradC(k,l,i)-aux
13180 PgradC(k,l,j) = PgradC(k,l,j)+aux
13183 if (itype(i).ne.10 .and. itype(j).ne.10) then
13184 aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
13185 PgradC(k,l,i) = PgradC(k,l,i)-aux
13186 PgradC(k,l,j) = PgradC(k,l,j)+aux
13187 PgradX(k,l,i) = PgradX(k,l,i)-aux
13188 PgradX(k,l,j) = PgradX(k,l,j)+aux
13194 sigma2CACA=scal_rad**2*0.25d0/
13195 & (restok(itype(j))**2+restok(itype(i))**2)
13196 c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
13197 c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
13199 sigmaCACA=dsqrt(sigma2CACA)
13200 threesig=3.0d0/sigmaCACA
13204 if (dabs(dijCACA-dk).ge.threesig) cycle
13207 aux = sigmaCACA*(dijCACA-dk)
13208 expCACA = mygauss(aux)
13209 c if (expcaca.eq.0.0d0) cycle
13210 Pcalc(k) = Pcalc(k)+expCACA
13211 CACAgrad = -sigmaCACA*mygaussder(aux)
13212 c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
13214 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13215 PgradC(k,l,i) = PgradC(k,l,i)-aux
13216 PgradC(k,l,j) = PgradC(k,l,j)+aux
13219 c write (iout,*) "i",i," j",j," llicz",llicz
13221 IF (saxs_cutoff.eq.0) THEN
13224 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
13225 Pcalc(k) = Pcalc(k)+expCACA
13226 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
13228 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13229 PgradC(k,l,i) = PgradC(k,l,i)-aux
13230 PgradC(k,l,j) = PgradC(k,l,j)+aux
13234 rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
13237 c write (2,*) "ijk",i,j,k
13238 sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
13239 if (sss2.eq.0.0d0) cycle
13240 ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
13241 if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
13242 & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
13243 & 1.0d0/dsqrt(sigma2CACA),rrr,dk,
13245 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13246 Pcalc(k) = Pcalc(k)+expCACA
13248 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13250 CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13251 & ssgrad2*expCACA/sss2
13254 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13255 PgradC(k,l,i) = PgradC(k,l,i)+aux
13256 PgradC(k,l,j) = PgradC(k,l,j)-aux
13266 c time_SAXS=time_SAXS+MPI_Wtime()-time01
13268 c write (iout,*) "lllicz",lllicz
13270 c time01=MPI_Wtime()
13273 if (nfgtasks.gt.1) then
13274 call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13275 & MPI_SUM,FG_COMM,IERR)
13276 c if (fg_rank.eq.king) then
13278 Pcalc(k) = Pcalc_(k)
13281 c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13282 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13283 c if (fg_rank.eq.king) then
13287 c PgradC(k,l,i) = PgradC_(k,l,i)
13293 c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13294 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13295 c if (fg_rank.eq.king) then
13299 c PgradX(k,l,i) = PgradX_(k,l,i)
13309 Cnorm = Cnorm + Pcalc(k)
13312 if (fg_rank.eq.king) then
13314 Esaxs_constr = dlog(Cnorm)-wsaxs0
13316 if (Pcalc(k).gt.0.0d0)
13317 & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13319 write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13323 write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13338 & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13339 auxC1 = auxC1+PgradC(k,l,i)
13341 auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13342 auxX1 = auxX1+PgradX(k,l,i)
13345 gsaxsC(l,i) = auxC - auxC1/Cnorm
13347 gsaxsX(l,i) = auxX - auxX1/Cnorm
13349 c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13350 c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
13351 c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13352 c * " gradX",wsaxs*gsaxsX(l,i)
13356 time_SAXS=time_SAXS+MPI_Wtime()-time01
13359 write (iout,*) "gsaxsc"
13361 write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13369 c----------------------------------------------------------------------------
13370 subroutine e_saxsC(Esaxs_constr)
13372 include 'DIMENSIONS'
13375 include "COMMON.SETUP"
13378 include 'COMMON.SBRIDGE'
13379 include 'COMMON.CHAIN'
13380 include 'COMMON.GEO'
13381 include 'COMMON.DERIV'
13382 include 'COMMON.LOCAL'
13383 include 'COMMON.INTERACT'
13384 include 'COMMON.VAR'
13385 include 'COMMON.IOUNITS'
13386 c include 'COMMON.MD'
13389 include 'COMMON.LANGEVIN.lang0.5diag'
13391 include 'COMMON.LANGEVIN.lang0'
13394 include 'COMMON.LANGEVIN'
13396 include 'COMMON.CONTROL'
13397 include 'COMMON.SAXS'
13398 include 'COMMON.NAMES'
13399 include 'COMMON.TIME1'
13400 include 'COMMON.FFIELD'
13402 double precision Esaxs_constr
13403 integer i,iint,j,k,l
13404 double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13406 double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13408 double precision dk,dijCASPH,dijSCSPH,
13409 & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13410 & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13412 c SAXS restraint penalty function
13414 write(iout,*) "------- SAXS penalty function start -------"
13415 write (iout,*) "nsaxs",nsaxs
13418 print *,MyRank,"C",i,(C(j,i),j=1,3)
13421 print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13424 Esaxs_constr = 0.0d0
13426 do j=isaxs_start,isaxs_end
13435 if (itype(i).eq.ntyp1) cycle
13439 dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13441 if (itype(i).ne.10) then
13443 dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13446 sigma2CA=2.0d0/pstok**2
13447 sigma2SC=4.0d0/restok(itype(i))**2
13448 expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13449 expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13450 Pcalc = Pcalc+expCASPH+expSCSPH
13452 write(*,*) "processor i j Pcalc",
13453 & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13455 CASPHgrad = sigma2CA*expCASPH
13456 SCSPHgrad = sigma2SC*expSCSPH
13458 aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13459 PgradX(l,i) = PgradX(l,i) + aux
13460 PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13465 gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13466 gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13469 logPtot = logPtot - dlog(Pcalc)
13470 c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13471 c & " logPtot",logPtot
13474 if (nfgtasks.gt.1) then
13475 c write (iout,*) "logPtot before reduction",logPtot
13476 call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13477 & MPI_SUM,king,FG_COMM,IERR)
13479 c write (iout,*) "logPtot after reduction",logPtot
13480 call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13481 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13482 if (fg_rank.eq.king) then
13485 gsaxsC(l,i) = gsaxsC_(l,i)
13489 call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13490 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13491 if (fg_rank.eq.king) then
13494 gsaxsX(l,i) = gsaxsX_(l,i)
13500 Esaxs_constr = logPtot
13503 c----------------------------------------------------------------------------
13504 double precision function sscale2(r,r_cut,r0,rlamb)
13506 double precision r,gamm,r_cut,r0,rlamb,rr
13508 c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13509 c write (2,*) "rr",rr
13510 if(rr.lt.r_cut-rlamb) then
13512 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13513 gamm=(rr-(r_cut-rlamb))/rlamb
13514 sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13520 C-----------------------------------------------------------------------
13521 double precision function sscalgrad2(r,r_cut,r0,rlamb)
13523 double precision r,gamm,r_cut,r0,rlamb,rr
13525 if(rr.lt.r_cut-rlamb) then
13527 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13528 gamm=(rr-(r_cut-rlamb))/rlamb
13530 sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13532 sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb