1 subroutine etotal(energia)
2 implicit real*8 (a-h,o-z)
7 cMS$ATTRIBUTES C :: proc_proc
12 double precision weights_(n_ene)
14 include 'COMMON.SETUP'
15 include 'COMMON.IOUNITS'
16 double precision energia(0:n_ene)
17 include 'COMMON.LOCAL'
18 include 'COMMON.FFIELD'
19 include 'COMMON.DERIV'
20 include 'COMMON.INTERACT'
21 include 'COMMON.SBRIDGE'
22 include 'COMMON.CHAIN'
25 include 'COMMON.CONTROL'
26 include 'COMMON.TIME1'
27 include 'COMMON.SPLITELE'
28 include 'COMMON.TORCNSTR'
30 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
31 c & " nfgtasks",nfgtasks
32 if (nfgtasks.gt.1) then
34 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
35 if (fg_rank.eq.0) then
36 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
37 c print *,"Processor",myrank," BROADCAST iorder"
38 C FG master sets up the WEIGHTS_ array which will be broadcast to the
39 C FG slaves as WEIGHTS array.
61 C FG Master broadcasts the WEIGHTS_ array
62 call MPI_Bcast(weights_(1),n_ene,
63 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
65 C FG slaves receive the WEIGHTS array
66 call MPI_Bcast(weights(1),n_ene,
67 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
90 time_Bcast=time_Bcast+MPI_Wtime()-time00
91 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
92 c call chainbuild_cart
94 c print *,'Processor',myrank,' calling etotal ipot=',ipot
95 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
97 c if (modecalc.eq.12.or.modecalc.eq.14) then
98 c call int_from_cart1(.false.)
105 C Compute the side-chain and electrostatic interaction energy
108 goto (101,102,103,104,105,106) ipot
109 C Lennard-Jones potential.
111 cd print '(a)','Exit ELJ'
113 C Lennard-Jones-Kihara potential (shifted).
116 C Berne-Pechukas potential (dilated LJ, angular dependence).
119 C Gay-Berne potential (shifted LJ, angular dependence).
121 C print *,"bylem w egb"
123 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
126 C Soft-sphere potential
127 106 call e_softsphere(evdw)
129 C Calculate electrostatic (H-bonding) energy of the main chain.
133 cmc Sep-06: egb takes care of dynamic ss bonds too
135 c if (dyn_ss) call dyn_set_nss
137 c print *,"Processor",myrank," computed USCSC"
143 time_vec=time_vec+MPI_Wtime()-time01
145 C Introduction of shielding effect first for each peptide group
146 C the shielding factor is set this factor is describing how each
147 C peptide group is shielded by side-chains
148 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
149 C write (iout,*) "shield_mode",shield_mode
150 if (shield_mode.eq.1) then
152 else if (shield_mode.eq.2) then
155 c print *,"Processor",myrank," left VEC_AND_DERIV"
158 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
159 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
160 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
161 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
163 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
164 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
165 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
166 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
168 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
177 write (iout,*) "Soft-spheer ELEC potential"
178 c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
182 c time_enecalc=time_enecalc+MPI_Wtime()-time00
184 c print *,"Processor",myrank," computed UELEC"
186 C Calculate excluded-volume interaction energy between peptide groups
191 call escp(evdw2,evdw2_14)
197 c write (iout,*) "Soft-sphere SCP potential"
198 call escp_soft_sphere(evdw2,evdw2_14)
201 c Calculate the bond-stretching energy
205 C Calculate the disulfide-bridge and other energy and the contributions
206 C from other distance constraints.
207 cd write (iout,*) 'Calling EHPB'
209 cd print *,'EHPB exitted succesfully.'
211 C Calculate the virtual-bond-angle energy.
213 if (wang.gt.0d0) then
214 if (tor_mode.eq.0) then
217 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
225 if (with_theta_constr) call etheta_constr(ethetacnstr)
226 c print *,"Processor",myrank," computed UB"
228 C Calculate the SC local energy.
230 C print *,"TU DOCHODZE?"
232 c print *,"Processor",myrank," computed USC"
234 C Calculate the virtual-bond torsional energy.
236 cd print *,'nterm=',nterm
237 C print *,"tor",tor_mode
238 if (wtor.gt.0.0d0) then
239 if (tor_mode.eq.0) then
242 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
250 if (ndih_constr.gt.0) call etor_constr(edihcnstr)
251 c print *,"Processor",myrank," computed Utor"
253 C 6/23/01 Calculate double-torsional energy
255 if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
260 c print *,"Processor",myrank," computed Utord"
262 C 21/5/07 Calculate local sicdechain correlation energy
264 if (wsccor.gt.0.0d0) then
265 call eback_sc_corr(esccor)
269 C print *,"PRZED MULIt"
270 c print *,"Processor",myrank," computed Usccorr"
272 C 12/1/95 Multi-body terms
276 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
277 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
278 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
279 c write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
280 c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
288 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
289 c write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
292 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
293 c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
297 c print *,"Processor",myrank," computed Ucorr"
298 c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
299 if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
300 call e_saxs(Esaxs_constr)
301 c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
302 else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
303 call e_saxsC(Esaxs_constr)
304 c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
309 C If performing constraint dynamics, call the constraint energy
310 C after the equilibration time
311 c if(usampl.and.totT.gt.eq_time) then
312 c write (iout,*) "usampl",usampl
316 call Econstr_back_qlike
324 C 01/27/2015 added by adasko
325 C the energy component below is energy transfer into lipid environment
326 C based on partition function
327 C print *,"przed lipidami"
328 if (wliptran.gt.0) then
329 call Eliptransfer(eliptran)
331 C print *,"za lipidami"
332 if (AFMlog.gt.0) then
333 call AFMforce(Eafmforce)
334 else if (selfguide.gt.0) then
335 call AFMvel(Eafmforce)
337 if (TUBElog.eq.1) then
338 C print *,"just before call"
340 elseif (TUBElog.eq.2) then
341 call calctube2(Etube)
347 time_enecalc=time_enecalc+MPI_Wtime()-time00
349 c print *,"Processor",myrank," computed Uconstr"
358 energia(2)=evdw2-evdw2_14
375 energia(8)=eello_turn3
376 energia(9)=eello_turn4
383 energia(19)=edihcnstr
385 energia(20)=Uconst+Uconst_back
388 energia(23)=Eafmforce
389 energia(24)=ethetacnstr
391 energia(26)=Esaxs_constr
392 c write (iout,*) "esaxs_constr",energia(26)
393 c Here are the energies showed per procesor if the are more processors
394 c per molecule then we sum it up in sum_energy subroutine
395 c print *," Processor",myrank," calls SUM_ENERGY"
396 call sum_energy(energia,.true.)
397 c write (iout,*) "After sum_energy: esaxs_constr",energia(26)
398 if (dyn_ss) call dyn_set_nss
399 c print *," Processor",myrank," left SUM_ENERGY"
401 time_sumene=time_sumene+MPI_Wtime()-time00
405 c-------------------------------------------------------------------------------
406 subroutine sum_energy(energia,reduce)
407 implicit real*8 (a-h,o-z)
412 cMS$ATTRIBUTES C :: proc_proc
418 include 'COMMON.SETUP'
419 include 'COMMON.IOUNITS'
420 double precision energia(0:n_ene),enebuff(0:n_ene+1)
421 include 'COMMON.FFIELD'
422 include 'COMMON.DERIV'
423 include 'COMMON.INTERACT'
424 include 'COMMON.SBRIDGE'
425 include 'COMMON.CHAIN'
427 include 'COMMON.CONTROL'
428 include 'COMMON.TIME1'
431 if (nfgtasks.gt.1 .and. reduce) then
433 write (iout,*) "energies before REDUCE"
434 call enerprint(energia)
438 enebuff(i)=energia(i)
441 call MPI_Barrier(FG_COMM,IERR)
442 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
444 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
445 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
447 write (iout,*) "energies after REDUCE"
448 call enerprint(energia)
451 time_Reduce=time_Reduce+MPI_Wtime()-time00
453 if (fg_rank.eq.0) then
457 evdw2=energia(2)+energia(18)
473 eello_turn3=energia(8)
474 eello_turn4=energia(9)
481 edihcnstr=energia(19)
486 Eafmforce=energia(23)
487 ethetacnstr=energia(24)
489 esaxs_constr=energia(26)
491 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
492 & +wang*ebe+wtor*etors+wscloc*escloc
493 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
494 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
495 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
496 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
497 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr
499 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
500 & +wang*ebe+wtor*etors+wscloc*escloc
501 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
502 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
503 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
504 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
506 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr
512 if (isnan(etot).ne.0) energia(0)=1.0d+99
514 if (isnan(etot)) energia(0)=1.0d+99
519 idumm=proc_proc(etot,i)
521 call proc_proc(etot,i)
523 if(i.eq.1)energia(0)=1.0d+99
530 c-------------------------------------------------------------------------------
531 subroutine sum_gradient
532 implicit real*8 (a-h,o-z)
537 cMS$ATTRIBUTES C :: proc_proc
543 double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
544 & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
545 & ,gloc_scbuf(3,-1:maxres)
546 include 'COMMON.SETUP'
547 include 'COMMON.IOUNITS'
548 include 'COMMON.FFIELD'
549 include 'COMMON.DERIV'
550 include 'COMMON.INTERACT'
551 include 'COMMON.SBRIDGE'
552 include 'COMMON.CHAIN'
554 include 'COMMON.CONTROL'
555 include 'COMMON.TIME1'
556 include 'COMMON.MAXGRAD'
557 include 'COMMON.SCCOR'
562 write (iout,*) "sum_gradient gvdwc, gvdwx"
564 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
565 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
570 write (iout,*) "sum_gradient gsaxsc, gsaxsx"
572 write (iout,'(i3,3e15.5,5x,3e15.5)')
573 & i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
578 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
579 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
580 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
583 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
584 C in virtual-bond-vector coordinates
587 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
589 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
590 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
592 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
594 c write (iout,'(i5,3f10.5,2x,f10.5)')
595 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
597 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
599 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
600 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
606 write (iout,*) "gsaxsc"
608 write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
615 gradbufc(j,i)=wsc*gvdwc(j,i)+
616 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
617 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
618 & wel_loc*gel_loc_long(j,i)+
619 & wcorr*gradcorr_long(j,i)+
620 & wcorr5*gradcorr5_long(j,i)+
621 & wcorr6*gradcorr6_long(j,i)+
622 & wturn6*gcorr6_turn_long(j,i)+
624 & +wliptran*gliptranc(j,i)
626 & +welec*gshieldc(j,i)
627 & +wcorr*gshieldc_ec(j,i)
628 & +wturn3*gshieldc_t3(j,i)
629 & +wturn4*gshieldc_t4(j,i)
630 & +wel_loc*gshieldc_ll(j,i)
631 & +wtube*gg_tube(j,i)
641 gradbufc(j,i)=wsc*gvdwc(j,i)+
642 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
643 & welec*gelc_long(j,i)+
645 & wel_loc*gel_loc_long(j,i)+
646 & wcorr*gradcorr_long(j,i)+
647 & wcorr5*gradcorr5_long(j,i)+
648 & wcorr6*gradcorr6_long(j,i)+
649 & wturn6*gcorr6_turn_long(j,i)+
651 & +wliptran*gliptranc(j,i)
653 & +welec*gshieldc(j,i)
654 & +wcorr*gshieldc_ec(j,i)
655 & +wturn4*gshieldc_t4(j,i)
656 & +wel_loc*gshieldc_ll(j,i)
657 & +wtube*gg_tube(j,i)
666 write (iout,*) "gradc from gradbufc"
668 write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
673 if (nfgtasks.gt.1) then
676 write (iout,*) "gradbufc before allreduce"
678 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
684 gradbufc_sum(j,i)=gradbufc(j,i)
687 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
688 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
689 c time_reduce=time_reduce+MPI_Wtime()-time00
691 c write (iout,*) "gradbufc_sum after allreduce"
693 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
698 c time_allreduce=time_allreduce+MPI_Wtime()-time00
706 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
707 write (iout,*) (i," jgrad_start",jgrad_start(i),
708 & " jgrad_end ",jgrad_end(i),
709 & i=igrad_start,igrad_end)
712 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
713 c do not parallelize this part.
715 c do i=igrad_start,igrad_end
716 c do j=jgrad_start(i),jgrad_end(i)
718 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
723 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
727 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
731 write (iout,*) "gradbufc after summing"
733 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
740 write (iout,*) "gradbufc"
742 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
748 gradbufc_sum(j,i)=gradbufc(j,i)
753 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
757 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
762 c gradbufc(k,i)=0.0d0
766 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
771 write (iout,*) "gradbufc after summing"
773 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
781 gradbufc(k,nres)=0.0d0
786 C print *,gradbufc(1,13)
787 C print *,welec*gelc(1,13)
788 C print *,wel_loc*gel_loc(1,13)
789 C print *,0.5d0*(wscp*gvdwc_scpp(1,13))
790 C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
791 C print *,wel_loc*gel_loc_long(1,13)
792 C print *,gradafm(1,13),"AFM"
793 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
794 & wel_loc*gel_loc(j,i)+
795 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
796 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
797 & wel_loc*gel_loc_long(j,i)+
798 & wcorr*gradcorr_long(j,i)+
799 & wcorr5*gradcorr5_long(j,i)+
800 & wcorr6*gradcorr6_long(j,i)+
801 & wturn6*gcorr6_turn_long(j,i))+
803 & wcorr*gradcorr(j,i)+
804 & wturn3*gcorr3_turn(j,i)+
805 & wturn4*gcorr4_turn(j,i)+
806 & wcorr5*gradcorr5(j,i)+
807 & wcorr6*gradcorr6(j,i)+
808 & wturn6*gcorr6_turn(j,i)+
809 & wsccor*gsccorc(j,i)
810 & +wscloc*gscloc(j,i)
811 & +wliptran*gliptranc(j,i)
813 & +welec*gshieldc(j,i)
814 & +welec*gshieldc_loc(j,i)
815 & +wcorr*gshieldc_ec(j,i)
816 & +wcorr*gshieldc_loc_ec(j,i)
817 & +wturn3*gshieldc_t3(j,i)
818 & +wturn3*gshieldc_loc_t3(j,i)
819 & +wturn4*gshieldc_t4(j,i)
820 & +wturn4*gshieldc_loc_t4(j,i)
821 & +wel_loc*gshieldc_ll(j,i)
822 & +wel_loc*gshieldc_loc_ll(j,i)
823 & +wtube*gg_tube(j,i)
826 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
827 & wel_loc*gel_loc(j,i)+
828 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
829 & welec*gelc_long(j,i)+
830 & wel_loc*gel_loc_long(j,i)+
831 & wcorr*gcorr_long(j,i)+
832 & wcorr5*gradcorr5_long(j,i)+
833 & wcorr6*gradcorr6_long(j,i)+
834 & wturn6*gcorr6_turn_long(j,i))+
836 & wcorr*gradcorr(j,i)+
837 & wturn3*gcorr3_turn(j,i)+
838 & wturn4*gcorr4_turn(j,i)+
839 & wcorr5*gradcorr5(j,i)+
840 & wcorr6*gradcorr6(j,i)+
841 & wturn6*gcorr6_turn(j,i)+
842 & wsccor*gsccorc(j,i)
843 & +wscloc*gscloc(j,i)
844 & +wliptran*gliptranc(j,i)
846 & +welec*gshieldc(j,i)
847 & +welec*gshieldc_loc(j,i)
848 & +wcorr*gshieldc_ec(j,i)
849 & +wcorr*gshieldc_loc_ec(j,i)
850 & +wturn3*gshieldc_t3(j,i)
851 & +wturn3*gshieldc_loc_t3(j,i)
852 & +wturn4*gshieldc_t4(j,i)
853 & +wturn4*gshieldc_loc_t4(j,i)
854 & +wel_loc*gshieldc_ll(j,i)
855 & +wel_loc*gshieldc_loc_ll(j,i)
856 & +wtube*gg_tube(j,i)
860 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
862 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
863 & wsccor*gsccorx(j,i)
864 & +wscloc*gsclocx(j,i)
865 & +wliptran*gliptranx(j,i)
866 & +welec*gshieldx(j,i)
867 & +wcorr*gshieldx_ec(j,i)
868 & +wturn3*gshieldx_t3(j,i)
869 & +wturn4*gshieldx_t4(j,i)
870 & +wel_loc*gshieldx_ll(j,i)
871 & +wtube*gg_tube_sc(j,i)
879 write (iout,*) "gradc gradx gloc after adding"
881 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
882 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
886 write (iout,*) "gloc before adding corr"
888 write (iout,*) i,gloc(i,icg)
892 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
893 & +wcorr5*g_corr5_loc(i)
894 & +wcorr6*g_corr6_loc(i)
895 & +wturn4*gel_loc_turn4(i)
896 & +wturn3*gel_loc_turn3(i)
897 & +wturn6*gel_loc_turn6(i)
898 & +wel_loc*gel_loc_loc(i)
901 write (iout,*) "gloc after adding corr"
903 write (iout,*) i,gloc(i,icg)
907 if (nfgtasks.gt.1) then
910 gradbufc(j,i)=gradc(j,i,icg)
911 gradbufx(j,i)=gradx(j,i,icg)
915 glocbuf(i)=gloc(i,icg)
919 write (iout,*) "gloc_sc before reduce"
922 write (iout,*) i,j,gloc_sc(j,i,icg)
929 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
933 call MPI_Barrier(FG_COMM,IERR)
934 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
936 call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
937 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
938 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
939 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
940 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
941 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
942 time_reduce=time_reduce+MPI_Wtime()-time00
943 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
944 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
945 time_reduce=time_reduce+MPI_Wtime()-time00
947 write (iout,*) "gradc after reduce"
950 write (iout,*) i,j,gradc(j,i,icg)
955 write (iout,*) "gloc_sc after reduce"
958 write (iout,*) i,j,gloc_sc(j,i,icg)
963 write (iout,*) "gloc after reduce"
965 write (iout,*) i,gloc(i,icg)
970 if (gnorm_check) then
972 c Compute the maximum elements of the gradient
982 gcorr3_turn_max=0.0d0
983 gcorr4_turn_max=0.0d0
986 gcorr6_turn_max=0.0d0
996 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
997 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
998 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
999 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1000 & gvdwc_scp_max=gvdwc_scp_norm
1001 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1002 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1003 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1004 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1005 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1006 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1007 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1008 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1009 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1010 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1011 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1012 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1013 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1014 & gcorr3_turn(1,i)))
1015 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1016 & gcorr3_turn_max=gcorr3_turn_norm
1017 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1018 & gcorr4_turn(1,i)))
1019 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1020 & gcorr4_turn_max=gcorr4_turn_norm
1021 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1022 if (gradcorr5_norm.gt.gradcorr5_max)
1023 & gradcorr5_max=gradcorr5_norm
1024 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1025 if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1026 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1027 & gcorr6_turn(1,i)))
1028 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1029 & gcorr6_turn_max=gcorr6_turn_norm
1030 gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1031 if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1032 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1033 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1034 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1035 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1036 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1037 if (gradx_scp_norm.gt.gradx_scp_max)
1038 & gradx_scp_max=gradx_scp_norm
1039 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1040 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1041 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1042 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1043 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1044 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1045 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1046 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1049 #if (defined AIX || defined CRAY)
1050 open(istat,file=statname,position="append")
1052 open(istat,file=statname,access="append")
1054 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1055 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1056 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1057 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1058 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1059 & gsccorx_max,gsclocx_max
1061 if (gvdwc_max.gt.1.0d4) then
1062 write (iout,*) "gvdwc gvdwx gradb gradbx"
1064 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1065 & gradb(j,i),gradbx(j,i),j=1,3)
1067 call pdbout(0.0d0,'cipiszcze',iout)
1073 write (iout,*) "gradc gradx gloc"
1075 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1076 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1080 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1084 c-------------------------------------------------------------------------------
1085 subroutine rescale_weights(t_bath)
1086 implicit real*8 (a-h,o-z)
1087 include 'DIMENSIONS'
1088 include 'COMMON.IOUNITS'
1089 include 'COMMON.FFIELD'
1090 include 'COMMON.SBRIDGE'
1091 include 'COMMON.CONTROL'
1092 double precision kfac /2.4d0/
1093 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1095 c facT=2*temp0/(t_bath+temp0)
1096 if (rescale_mode.eq.0) then
1102 else if (rescale_mode.eq.1) then
1103 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1104 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1105 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1106 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1107 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1108 else if (rescale_mode.eq.2) then
1114 facT=licznik/dlog(dexp(x)+dexp(-x))
1115 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1116 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1117 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1118 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1120 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1121 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1123 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1127 if (shield_mode.gt.0) then
1128 wscp=weights(2)*fact
1130 wvdwpp=weights(16)*fact
1132 welec=weights(3)*fact
1133 wcorr=weights(4)*fact3
1134 wcorr5=weights(5)*fact4
1135 wcorr6=weights(6)*fact5
1136 wel_loc=weights(7)*fact2
1137 wturn3=weights(8)*fact2
1138 wturn4=weights(9)*fact3
1139 wturn6=weights(10)*fact5
1140 wtor=weights(13)*fact
1141 wtor_d=weights(14)*fact2
1142 wsccor=weights(21)*fact
1143 if (scale_umb) wumb=t_bath/temp0
1144 c write (iout,*) "scale_umb",scale_umb
1145 c write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1149 C------------------------------------------------------------------------
1150 subroutine enerprint(energia)
1151 implicit real*8 (a-h,o-z)
1152 include 'DIMENSIONS'
1153 include 'COMMON.IOUNITS'
1154 include 'COMMON.FFIELD'
1155 include 'COMMON.SBRIDGE'
1157 double precision energia(0:n_ene)
1162 evdw2=energia(2)+energia(18)
1174 eello_turn3=energia(8)
1175 eello_turn4=energia(9)
1176 eello_turn6=energia(10)
1182 edihcnstr=energia(19)
1186 eliptran=energia(22)
1187 Eafmforce=energia(23)
1188 ethetacnstr=energia(24)
1192 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1193 & estr,wbond,ebe,wang,
1194 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1196 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1197 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1198 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1199 & etube,wtube,esaxs,wsaxs,
1201 10 format (/'Virtual-chain energies:'//
1202 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1203 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1204 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1205 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1206 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1207 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1208 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1209 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1210 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1211 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
1212 & ' (SS bridges & dist. cnstr.)'/
1213 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1214 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1215 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1216 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1217 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1218 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1219 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1220 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1221 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1222 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1223 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1224 & 'UCONST=',1pE16.6,' WEIGHT=',1pD16.6' (umbrella restraints)'/
1225 & 'ELT= ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/
1226 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1227 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (tube confinment)'/
1228 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/
1229 & 'ETOT= ',1pE16.6,' (total)')
1232 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1233 & estr,wbond,ebe,wang,
1234 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1236 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1237 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1238 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1239 & etube,wtube,esaxs,wsaxs,
1241 10 format (/'Virtual-chain energies:'//
1242 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1243 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1244 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1245 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1246 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1247 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1248 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1249 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1250 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
1251 & ' (SS bridges & dist. restr.)'/
1252 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1253 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1254 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1255 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1256 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1257 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1258 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1259 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1260 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1261 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1262 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1263 & 'UCONST=',1pE16.6,' WEIGHT=',1pD16.6' (umbrella restraints)'/
1264 & 'ELT= ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/
1265 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1266 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (tube confinment)'/
1267 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/
1268 & 'ETOT= ',1pE16.6,' (total)')
1272 C-----------------------------------------------------------------------
1273 subroutine elj(evdw)
1275 C This subroutine calculates the interaction energy of nonbonded side chains
1276 C assuming the LJ potential of interaction.
1278 implicit real*8 (a-h,o-z)
1279 include 'DIMENSIONS'
1280 parameter (accur=1.0d-10)
1281 include 'COMMON.GEO'
1282 include 'COMMON.VAR'
1283 include 'COMMON.LOCAL'
1284 include 'COMMON.CHAIN'
1285 include 'COMMON.DERIV'
1286 include 'COMMON.INTERACT'
1287 include 'COMMON.TORSION'
1288 include 'COMMON.SBRIDGE'
1289 include 'COMMON.NAMES'
1290 include 'COMMON.IOUNITS'
1291 include 'COMMON.CONTACTS'
1293 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1295 do i=iatsc_s,iatsc_e
1296 itypi=iabs(itype(i))
1297 if (itypi.eq.ntyp1) cycle
1298 itypi1=iabs(itype(i+1))
1305 C Calculate SC interaction energy.
1307 do iint=1,nint_gr(i)
1308 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1309 cd & 'iend=',iend(i,iint)
1310 do j=istart(i,iint),iend(i,iint)
1311 itypj=iabs(itype(j))
1312 if (itypj.eq.ntyp1) cycle
1316 C Change 12/1/95 to calculate four-body interactions
1317 rij=xj*xj+yj*yj+zj*zj
1319 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1320 eps0ij=eps(itypi,itypj)
1322 C have you changed here?
1326 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1327 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1328 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1329 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1330 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1331 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1334 C Calculate the components of the gradient in DC and X
1336 fac=-rrij*(e1+evdwij)
1341 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1342 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1343 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1344 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1348 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1352 C 12/1/95, revised on 5/20/97
1354 C Calculate the contact function. The ith column of the array JCONT will
1355 C contain the numbers of atoms that make contacts with the atom I (of numbers
1356 C greater than I). The arrays FACONT and GACONT will contain the values of
1357 C the contact function and its derivative.
1359 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1360 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1361 C Uncomment next line, if the correlation interactions are contact function only
1362 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1364 sigij=sigma(itypi,itypj)
1365 r0ij=rs0(itypi,itypj)
1367 C Check whether the SC's are not too far to make a contact.
1370 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1371 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1373 if (fcont.gt.0.0D0) then
1374 C If the SC-SC distance if close to sigma, apply spline.
1375 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1376 cAdam & fcont1,fprimcont1)
1377 cAdam fcont1=1.0d0-fcont1
1378 cAdam if (fcont1.gt.0.0d0) then
1379 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1380 cAdam fcont=fcont*fcont1
1382 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1383 cga eps0ij=1.0d0/dsqrt(eps0ij)
1385 cga gg(k)=gg(k)*eps0ij
1387 cga eps0ij=-evdwij*eps0ij
1388 C Uncomment for AL's type of SC correlation interactions.
1389 cadam eps0ij=-evdwij
1390 num_conti=num_conti+1
1391 jcont(num_conti,i)=j
1392 facont(num_conti,i)=fcont*eps0ij
1393 fprimcont=eps0ij*fprimcont/rij
1395 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1396 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1397 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1398 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1399 gacont(1,num_conti,i)=-fprimcont*xj
1400 gacont(2,num_conti,i)=-fprimcont*yj
1401 gacont(3,num_conti,i)=-fprimcont*zj
1402 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1403 cd write (iout,'(2i3,3f10.5)')
1404 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1410 num_cont(i)=num_conti
1414 gvdwc(j,i)=expon*gvdwc(j,i)
1415 gvdwx(j,i)=expon*gvdwx(j,i)
1418 C******************************************************************************
1422 C To save time, the factor of EXPON has been extracted from ALL components
1423 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1426 C******************************************************************************
1429 C-----------------------------------------------------------------------------
1430 subroutine eljk(evdw)
1432 C This subroutine calculates the interaction energy of nonbonded side chains
1433 C assuming the LJK potential of interaction.
1435 implicit real*8 (a-h,o-z)
1436 include 'DIMENSIONS'
1437 include 'COMMON.GEO'
1438 include 'COMMON.VAR'
1439 include 'COMMON.LOCAL'
1440 include 'COMMON.CHAIN'
1441 include 'COMMON.DERIV'
1442 include 'COMMON.INTERACT'
1443 include 'COMMON.IOUNITS'
1444 include 'COMMON.NAMES'
1447 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1449 do i=iatsc_s,iatsc_e
1450 itypi=iabs(itype(i))
1451 if (itypi.eq.ntyp1) cycle
1452 itypi1=iabs(itype(i+1))
1457 C Calculate SC interaction energy.
1459 do iint=1,nint_gr(i)
1460 do j=istart(i,iint),iend(i,iint)
1461 itypj=iabs(itype(j))
1462 if (itypj.eq.ntyp1) cycle
1466 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1467 fac_augm=rrij**expon
1468 e_augm=augm(itypi,itypj)*fac_augm
1469 r_inv_ij=dsqrt(rrij)
1471 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1472 fac=r_shift_inv**expon
1473 C have you changed here?
1477 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1478 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1479 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1480 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1481 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1482 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1483 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1486 C Calculate the components of the gradient in DC and X
1488 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1493 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1494 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1495 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1496 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1500 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1508 gvdwc(j,i)=expon*gvdwc(j,i)
1509 gvdwx(j,i)=expon*gvdwx(j,i)
1514 C-----------------------------------------------------------------------------
1515 subroutine ebp(evdw)
1517 C This subroutine calculates the interaction energy of nonbonded side chains
1518 C assuming the Berne-Pechukas potential of interaction.
1520 implicit real*8 (a-h,o-z)
1521 include 'DIMENSIONS'
1522 include 'COMMON.GEO'
1523 include 'COMMON.VAR'
1524 include 'COMMON.LOCAL'
1525 include 'COMMON.CHAIN'
1526 include 'COMMON.DERIV'
1527 include 'COMMON.NAMES'
1528 include 'COMMON.INTERACT'
1529 include 'COMMON.IOUNITS'
1530 include 'COMMON.CALC'
1531 common /srutu/ icall
1532 c double precision rrsave(maxdim)
1535 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1537 c if (icall.eq.0) then
1543 do i=iatsc_s,iatsc_e
1544 itypi=iabs(itype(i))
1545 if (itypi.eq.ntyp1) cycle
1546 itypi1=iabs(itype(i+1))
1550 dxi=dc_norm(1,nres+i)
1551 dyi=dc_norm(2,nres+i)
1552 dzi=dc_norm(3,nres+i)
1553 c dsci_inv=dsc_inv(itypi)
1554 dsci_inv=vbld_inv(i+nres)
1556 C Calculate SC interaction energy.
1558 do iint=1,nint_gr(i)
1559 do j=istart(i,iint),iend(i,iint)
1561 itypj=iabs(itype(j))
1562 if (itypj.eq.ntyp1) cycle
1563 c dscj_inv=dsc_inv(itypj)
1564 dscj_inv=vbld_inv(j+nres)
1565 chi1=chi(itypi,itypj)
1566 chi2=chi(itypj,itypi)
1573 alf12=0.5D0*(alf1+alf2)
1574 C For diagnostics only!!!
1587 dxj=dc_norm(1,nres+j)
1588 dyj=dc_norm(2,nres+j)
1589 dzj=dc_norm(3,nres+j)
1590 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1591 cd if (icall.eq.0) then
1597 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1599 C Calculate whole angle-dependent part of epsilon and contributions
1600 C to its derivatives
1601 C have you changed here?
1602 fac=(rrij*sigsq)**expon2
1605 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1606 eps2der=evdwij*eps3rt
1607 eps3der=evdwij*eps2rt
1608 evdwij=evdwij*eps2rt*eps3rt
1611 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1613 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1614 cd & restyp(itypi),i,restyp(itypj),j,
1615 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1616 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1617 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1620 C Calculate gradient components.
1621 e1=e1*eps1*eps2rt**2*eps3rt**2
1622 fac=-expon*(e1+evdwij)
1625 C Calculate radial part of the gradient
1629 C Calculate the angular part of the gradient and sum add the contributions
1630 C to the appropriate components of the Cartesian gradient.
1638 C-----------------------------------------------------------------------------
1639 subroutine egb(evdw)
1641 C This subroutine calculates the interaction energy of nonbonded side chains
1642 C assuming the Gay-Berne potential of interaction.
1644 implicit real*8 (a-h,o-z)
1645 include 'DIMENSIONS'
1646 include 'COMMON.GEO'
1647 include 'COMMON.VAR'
1648 include 'COMMON.LOCAL'
1649 include 'COMMON.CHAIN'
1650 include 'COMMON.DERIV'
1651 include 'COMMON.NAMES'
1652 include 'COMMON.INTERACT'
1653 include 'COMMON.IOUNITS'
1654 include 'COMMON.CALC'
1655 include 'COMMON.CONTROL'
1656 include 'COMMON.SPLITELE'
1657 include 'COMMON.SBRIDGE'
1659 integer xshift,yshift,zshift
1662 ccccc energy_dec=.false.
1663 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1666 c if (icall.eq.0) lprn=.false.
1668 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1669 C we have the original box)
1673 do i=iatsc_s,iatsc_e
1674 itypi=iabs(itype(i))
1675 if (itypi.eq.ntyp1) cycle
1676 itypi1=iabs(itype(i+1))
1680 C Return atom into box, boxxsize is size of box in x dimension
1682 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1683 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1684 C Condition for being inside the proper box
1685 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1686 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
1690 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1691 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1692 C Condition for being inside the proper box
1693 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1694 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
1698 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1699 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1700 C Condition for being inside the proper box
1701 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1702 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
1706 if (xi.lt.0) xi=xi+boxxsize
1708 if (yi.lt.0) yi=yi+boxysize
1710 if (zi.lt.0) zi=zi+boxzsize
1711 C define scaling factor for lipids
1713 C if (positi.le.0) positi=positi+boxzsize
1715 C first for peptide groups
1716 c for each residue check if it is in lipid or lipid water border area
1717 if ((zi.gt.bordlipbot)
1718 &.and.(zi.lt.bordliptop)) then
1719 C the energy transfer exist
1720 if (zi.lt.buflipbot) then
1721 C what fraction I am in
1723 & ((zi-bordlipbot)/lipbufthick)
1724 C lipbufthick is thickenes of lipid buffore
1725 sslipi=sscalelip(fracinbuf)
1726 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1727 elseif (zi.gt.bufliptop) then
1728 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1729 sslipi=sscalelip(fracinbuf)
1730 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1740 C xi=xi+xshift*boxxsize
1741 C yi=yi+yshift*boxysize
1742 C zi=zi+zshift*boxzsize
1744 dxi=dc_norm(1,nres+i)
1745 dyi=dc_norm(2,nres+i)
1746 dzi=dc_norm(3,nres+i)
1747 c dsci_inv=dsc_inv(itypi)
1748 dsci_inv=vbld_inv(i+nres)
1749 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1750 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1752 C Calculate SC interaction energy.
1754 do iint=1,nint_gr(i)
1755 do j=istart(i,iint),iend(i,iint)
1756 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1758 c write(iout,*) "PRZED ZWYKLE", evdwij
1759 call dyn_ssbond_ene(i,j,evdwij)
1760 c write(iout,*) "PO ZWYKLE", evdwij
1763 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1764 & 'evdw',i,j,evdwij,' ss'
1765 C triple bond artifac removal
1766 do k=j+1,iend(i,iint)
1767 C search over all next residues
1768 if (dyn_ss_mask(k)) then
1769 C check if they are cysteins
1770 C write(iout,*) 'k=',k
1772 c write(iout,*) "PRZED TRI", evdwij
1773 evdwij_przed_tri=evdwij
1774 call triple_ssbond_ene(i,j,k,evdwij)
1775 c if(evdwij_przed_tri.ne.evdwij) then
1776 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1779 c write(iout,*) "PO TRI", evdwij
1780 C call the energy function that removes the artifical triple disulfide
1781 C bond the soubroutine is located in ssMD.F
1783 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1784 & 'evdw',i,j,evdwij,'tss'
1785 endif!dyn_ss_mask(k)
1789 itypj=iabs(itype(j))
1790 if (itypj.eq.ntyp1) cycle
1791 c dscj_inv=dsc_inv(itypj)
1792 dscj_inv=vbld_inv(j+nres)
1793 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1794 c & 1.0d0/vbld(j+nres)
1795 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1796 sig0ij=sigma(itypi,itypj)
1797 chi1=chi(itypi,itypj)
1798 chi2=chi(itypj,itypi)
1805 alf12=0.5D0*(alf1+alf2)
1806 C For diagnostics only!!!
1819 C Return atom J into box the original box
1821 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1822 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1823 C Condition for being inside the proper box
1824 c if ((xj.gt.((0.5d0)*boxxsize)).or.
1825 c & (xj.lt.((-0.5d0)*boxxsize))) then
1829 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1830 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1831 C Condition for being inside the proper box
1832 c if ((yj.gt.((0.5d0)*boxysize)).or.
1833 c & (yj.lt.((-0.5d0)*boxysize))) then
1837 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1838 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1839 C Condition for being inside the proper box
1840 c if ((zj.gt.((0.5d0)*boxzsize)).or.
1841 c & (zj.lt.((-0.5d0)*boxzsize))) then
1845 if (xj.lt.0) xj=xj+boxxsize
1847 if (yj.lt.0) yj=yj+boxysize
1849 if (zj.lt.0) zj=zj+boxzsize
1850 if ((zj.gt.bordlipbot)
1851 &.and.(zj.lt.bordliptop)) then
1852 C the energy transfer exist
1853 if (zj.lt.buflipbot) then
1854 C what fraction I am in
1856 & ((zj-bordlipbot)/lipbufthick)
1857 C lipbufthick is thickenes of lipid buffore
1858 sslipj=sscalelip(fracinbuf)
1859 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1860 elseif (zj.gt.bufliptop) then
1861 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1862 sslipj=sscalelip(fracinbuf)
1863 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1872 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1873 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1874 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1875 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1876 C write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1877 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1878 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1879 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1880 C print *,sslipi,sslipj,bordlipbot,zi,zj
1881 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1889 xj=xj_safe+xshift*boxxsize
1890 yj=yj_safe+yshift*boxysize
1891 zj=zj_safe+zshift*boxzsize
1892 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1893 if(dist_temp.lt.dist_init) then
1903 if (subchap.eq.1) then
1912 dxj=dc_norm(1,nres+j)
1913 dyj=dc_norm(2,nres+j)
1914 dzj=dc_norm(3,nres+j)
1918 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1919 c write (iout,*) "j",j," dc_norm",
1920 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1921 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1923 sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1924 sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1926 c write (iout,'(a7,4f8.3)')
1927 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1928 if (sss.gt.0.0d0) then
1929 C Calculate angle-dependent terms of energy and contributions to their
1933 sig=sig0ij*dsqrt(sigsq)
1934 rij_shift=1.0D0/rij-sig+sig0ij
1935 c for diagnostics; uncomment
1936 c rij_shift=1.2*sig0ij
1937 C I hate to put IF's in the loops, but here don't have another choice!!!!
1938 if (rij_shift.le.0.0D0) then
1940 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1941 cd & restyp(itypi),i,restyp(itypj),j,
1942 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1946 c---------------------------------------------------------------
1947 rij_shift=1.0D0/rij_shift
1948 fac=rij_shift**expon
1949 C here to start with
1954 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1955 eps2der=evdwij*eps3rt
1956 eps3der=evdwij*eps2rt
1957 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1958 C &((sslipi+sslipj)/2.0d0+
1959 C &(2.0d0-sslipi-sslipj)/2.0d0)
1960 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1961 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1962 evdwij=evdwij*eps2rt*eps3rt
1963 evdw=evdw+evdwij*sss
1965 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1967 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1968 & restyp(itypi),i,restyp(itypj),j,
1969 & epsi,sigm,chi1,chi2,chip1,chip2,
1970 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1971 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1975 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1978 C Calculate gradient components.
1979 e1=e1*eps1*eps2rt**2*eps3rt**2
1980 fac=-expon*(e1+evdwij)*rij_shift
1983 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
1984 c & evdwij,fac,sigma(itypi,itypj),expon
1985 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1987 C Calculate the radial part of the gradient
1988 gg_lipi(3)=eps1*(eps2rt*eps2rt)
1989 &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1990 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1991 &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1992 gg_lipj(3)=ssgradlipj*gg_lipi(3)
1993 gg_lipi(3)=gg_lipi(3)*ssgradlipi
1999 C Calculate angular part of the gradient.
2009 c write (iout,*) "Number of loop steps in EGB:",ind
2010 cccc energy_dec=.false.
2013 C-----------------------------------------------------------------------------
2014 subroutine egbv(evdw)
2016 C This subroutine calculates the interaction energy of nonbonded side chains
2017 C assuming the Gay-Berne-Vorobjev potential of interaction.
2019 implicit real*8 (a-h,o-z)
2020 include 'DIMENSIONS'
2021 include 'COMMON.GEO'
2022 include 'COMMON.VAR'
2023 include 'COMMON.LOCAL'
2024 include 'COMMON.CHAIN'
2025 include 'COMMON.DERIV'
2026 include 'COMMON.NAMES'
2027 include 'COMMON.INTERACT'
2028 include 'COMMON.IOUNITS'
2029 include 'COMMON.CALC'
2030 integer xshift,yshift,zshift
2031 common /srutu/ icall
2034 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2037 c if (icall.eq.0) lprn=.true.
2039 do i=iatsc_s,iatsc_e
2040 itypi=iabs(itype(i))
2041 if (itypi.eq.ntyp1) cycle
2042 itypi1=iabs(itype(i+1))
2047 if (xi.lt.0) xi=xi+boxxsize
2049 if (yi.lt.0) yi=yi+boxysize
2051 if (zi.lt.0) zi=zi+boxzsize
2052 C define scaling factor for lipids
2054 C if (positi.le.0) positi=positi+boxzsize
2056 C first for peptide groups
2057 c for each residue check if it is in lipid or lipid water border area
2058 if ((zi.gt.bordlipbot)
2059 &.and.(zi.lt.bordliptop)) then
2060 C the energy transfer exist
2061 if (zi.lt.buflipbot) then
2062 C what fraction I am in
2064 & ((zi-bordlipbot)/lipbufthick)
2065 C lipbufthick is thickenes of lipid buffore
2066 sslipi=sscalelip(fracinbuf)
2067 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2068 elseif (zi.gt.bufliptop) then
2069 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2070 sslipi=sscalelip(fracinbuf)
2071 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2081 dxi=dc_norm(1,nres+i)
2082 dyi=dc_norm(2,nres+i)
2083 dzi=dc_norm(3,nres+i)
2084 c dsci_inv=dsc_inv(itypi)
2085 dsci_inv=vbld_inv(i+nres)
2087 C Calculate SC interaction energy.
2089 do iint=1,nint_gr(i)
2090 do j=istart(i,iint),iend(i,iint)
2092 itypj=iabs(itype(j))
2093 if (itypj.eq.ntyp1) cycle
2094 c dscj_inv=dsc_inv(itypj)
2095 dscj_inv=vbld_inv(j+nres)
2096 sig0ij=sigma(itypi,itypj)
2097 r0ij=r0(itypi,itypj)
2098 chi1=chi(itypi,itypj)
2099 chi2=chi(itypj,itypi)
2106 alf12=0.5D0*(alf1+alf2)
2107 C For diagnostics only!!!
2121 if (xj.lt.0) xj=xj+boxxsize
2123 if (yj.lt.0) yj=yj+boxysize
2125 if (zj.lt.0) zj=zj+boxzsize
2126 if ((zj.gt.bordlipbot)
2127 &.and.(zj.lt.bordliptop)) then
2128 C the energy transfer exist
2129 if (zj.lt.buflipbot) then
2130 C what fraction I am in
2132 & ((zj-bordlipbot)/lipbufthick)
2133 C lipbufthick is thickenes of lipid buffore
2134 sslipj=sscalelip(fracinbuf)
2135 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2136 elseif (zj.gt.bufliptop) then
2137 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2138 sslipj=sscalelip(fracinbuf)
2139 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2148 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2149 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2150 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2151 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2152 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2153 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2154 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2155 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2163 xj=xj_safe+xshift*boxxsize
2164 yj=yj_safe+yshift*boxysize
2165 zj=zj_safe+zshift*boxzsize
2166 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2167 if(dist_temp.lt.dist_init) then
2177 if (subchap.eq.1) then
2186 dxj=dc_norm(1,nres+j)
2187 dyj=dc_norm(2,nres+j)
2188 dzj=dc_norm(3,nres+j)
2189 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2191 C Calculate angle-dependent terms of energy and contributions to their
2195 sig=sig0ij*dsqrt(sigsq)
2196 rij_shift=1.0D0/rij-sig+r0ij
2197 C I hate to put IF's in the loops, but here don't have another choice!!!!
2198 if (rij_shift.le.0.0D0) then
2203 c---------------------------------------------------------------
2204 rij_shift=1.0D0/rij_shift
2205 fac=rij_shift**expon
2208 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2209 eps2der=evdwij*eps3rt
2210 eps3der=evdwij*eps2rt
2211 fac_augm=rrij**expon
2212 e_augm=augm(itypi,itypj)*fac_augm
2213 evdwij=evdwij*eps2rt*eps3rt
2214 evdw=evdw+evdwij+e_augm
2216 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2218 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2219 & restyp(itypi),i,restyp(itypj),j,
2220 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2221 & chi1,chi2,chip1,chip2,
2222 & eps1,eps2rt**2,eps3rt**2,
2223 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2226 C Calculate gradient components.
2227 e1=e1*eps1*eps2rt**2*eps3rt**2
2228 fac=-expon*(e1+evdwij)*rij_shift
2230 fac=rij*fac-2*expon*rrij*e_augm
2231 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2232 C Calculate the radial part of the gradient
2236 C Calculate angular part of the gradient.
2242 C-----------------------------------------------------------------------------
2243 subroutine sc_angular
2244 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2245 C om12. Called by ebp, egb, and egbv.
2247 include 'COMMON.CALC'
2248 include 'COMMON.IOUNITS'
2252 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2253 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2254 om12=dxi*dxj+dyi*dyj+dzi*dzj
2256 C Calculate eps1(om12) and its derivative in om12
2257 faceps1=1.0D0-om12*chiom12
2258 faceps1_inv=1.0D0/faceps1
2259 eps1=dsqrt(faceps1_inv)
2260 C Following variable is eps1*deps1/dom12
2261 eps1_om12=faceps1_inv*chiom12
2266 c write (iout,*) "om12",om12," eps1",eps1
2267 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2272 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2273 sigsq=1.0D0-facsig*faceps1_inv
2274 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2275 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2276 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2282 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2283 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2285 C Calculate eps2 and its derivatives in om1, om2, and om12.
2288 chipom12=chip12*om12
2289 facp=1.0D0-om12*chipom12
2291 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2292 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2293 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2294 C Following variable is the square root of eps2
2295 eps2rt=1.0D0-facp1*facp_inv
2296 C Following three variables are the derivatives of the square root of eps
2297 C in om1, om2, and om12.
2298 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2299 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2300 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2301 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2302 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2303 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2304 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2305 c & " eps2rt_om12",eps2rt_om12
2306 C Calculate whole angle-dependent part of epsilon and contributions
2307 C to its derivatives
2310 C----------------------------------------------------------------------------
2312 implicit real*8 (a-h,o-z)
2313 include 'DIMENSIONS'
2314 include 'COMMON.CHAIN'
2315 include 'COMMON.DERIV'
2316 include 'COMMON.CALC'
2317 include 'COMMON.IOUNITS'
2318 double precision dcosom1(3),dcosom2(3)
2319 cc print *,'sss=',sss
2320 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2321 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2322 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2323 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2327 c eom12=evdwij*eps1_om12
2329 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2330 c & " sigder",sigder
2331 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2332 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2334 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2335 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2338 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2340 c write (iout,*) "gg",(gg(k),k=1,3)
2342 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2343 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2344 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2345 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2346 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2347 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2348 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2349 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2350 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2351 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2354 C Calculate the components of the gradient in DC and X
2358 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2362 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2363 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2367 C-----------------------------------------------------------------------
2368 subroutine e_softsphere(evdw)
2370 C This subroutine calculates the interaction energy of nonbonded side chains
2371 C assuming the LJ potential of interaction.
2373 implicit real*8 (a-h,o-z)
2374 include 'DIMENSIONS'
2375 parameter (accur=1.0d-10)
2376 include 'COMMON.GEO'
2377 include 'COMMON.VAR'
2378 include 'COMMON.LOCAL'
2379 include 'COMMON.CHAIN'
2380 include 'COMMON.DERIV'
2381 include 'COMMON.INTERACT'
2382 include 'COMMON.TORSION'
2383 include 'COMMON.SBRIDGE'
2384 include 'COMMON.NAMES'
2385 include 'COMMON.IOUNITS'
2386 include 'COMMON.CONTACTS'
2388 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2390 do i=iatsc_s,iatsc_e
2391 itypi=iabs(itype(i))
2392 if (itypi.eq.ntyp1) cycle
2393 itypi1=iabs(itype(i+1))
2398 C Calculate SC interaction energy.
2400 do iint=1,nint_gr(i)
2401 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2402 cd & 'iend=',iend(i,iint)
2403 do j=istart(i,iint),iend(i,iint)
2404 itypj=iabs(itype(j))
2405 if (itypj.eq.ntyp1) cycle
2409 rij=xj*xj+yj*yj+zj*zj
2410 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2411 r0ij=r0(itypi,itypj)
2413 c print *,i,j,r0ij,dsqrt(rij)
2414 if (rij.lt.r0ijsq) then
2415 evdwij=0.25d0*(rij-r0ijsq)**2
2423 C Calculate the components of the gradient in DC and X
2429 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2430 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2431 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2432 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2436 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2444 C--------------------------------------------------------------------------
2445 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2448 C Soft-sphere potential of p-p interaction
2450 implicit real*8 (a-h,o-z)
2451 include 'DIMENSIONS'
2452 include 'COMMON.CONTROL'
2453 include 'COMMON.IOUNITS'
2454 include 'COMMON.GEO'
2455 include 'COMMON.VAR'
2456 include 'COMMON.LOCAL'
2457 include 'COMMON.CHAIN'
2458 include 'COMMON.DERIV'
2459 include 'COMMON.INTERACT'
2460 include 'COMMON.CONTACTS'
2461 include 'COMMON.TORSION'
2462 include 'COMMON.VECTORS'
2463 include 'COMMON.FFIELD'
2465 integer xshift,yshift,zshift
2466 C write(iout,*) 'In EELEC_soft_sphere'
2473 do i=iatel_s,iatel_e
2474 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2478 xmedi=c(1,i)+0.5d0*dxi
2479 ymedi=c(2,i)+0.5d0*dyi
2480 zmedi=c(3,i)+0.5d0*dzi
2481 xmedi=mod(xmedi,boxxsize)
2482 if (xmedi.lt.0) xmedi=xmedi+boxxsize
2483 ymedi=mod(ymedi,boxysize)
2484 if (ymedi.lt.0) ymedi=ymedi+boxysize
2485 zmedi=mod(zmedi,boxzsize)
2486 if (zmedi.lt.0) zmedi=zmedi+boxzsize
2488 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2489 do j=ielstart(i),ielend(i)
2490 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2494 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2495 r0ij=rpp(iteli,itelj)
2504 if (xj.lt.0) xj=xj+boxxsize
2506 if (yj.lt.0) yj=yj+boxysize
2508 if (zj.lt.0) zj=zj+boxzsize
2509 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2517 xj=xj_safe+xshift*boxxsize
2518 yj=yj_safe+yshift*boxysize
2519 zj=zj_safe+zshift*boxzsize
2520 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2521 if(dist_temp.lt.dist_init) then
2531 if (isubchap.eq.1) then
2540 rij=xj*xj+yj*yj+zj*zj
2541 sss=sscale(sqrt(rij))
2542 sssgrad=sscagrad(sqrt(rij))
2543 if (rij.lt.r0ijsq) then
2544 evdw1ij=0.25d0*(rij-r0ijsq)**2
2550 evdw1=evdw1+evdw1ij*sss
2552 C Calculate contributions to the Cartesian gradient.
2554 ggg(1)=fac*xj*sssgrad
2555 ggg(2)=fac*yj*sssgrad
2556 ggg(3)=fac*zj*sssgrad
2558 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2559 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2562 * Loop over residues i+1 thru j-1.
2566 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2571 cgrad do i=nnt,nct-1
2573 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2575 cgrad do j=i+1,nct-1
2577 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2583 c------------------------------------------------------------------------------
2584 subroutine vec_and_deriv
2585 implicit real*8 (a-h,o-z)
2586 include 'DIMENSIONS'
2590 include 'COMMON.IOUNITS'
2591 include 'COMMON.GEO'
2592 include 'COMMON.VAR'
2593 include 'COMMON.LOCAL'
2594 include 'COMMON.CHAIN'
2595 include 'COMMON.VECTORS'
2596 include 'COMMON.SETUP'
2597 include 'COMMON.TIME1'
2598 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2599 C Compute the local reference systems. For reference system (i), the
2600 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2601 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2603 do i=ivec_start,ivec_end
2607 if (i.eq.nres-1) then
2608 C Case of the last full residue
2609 C Compute the Z-axis
2610 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2611 costh=dcos(pi-theta(nres))
2612 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2616 C Compute the derivatives of uz
2618 uzder(2,1,1)=-dc_norm(3,i-1)
2619 uzder(3,1,1)= dc_norm(2,i-1)
2620 uzder(1,2,1)= dc_norm(3,i-1)
2622 uzder(3,2,1)=-dc_norm(1,i-1)
2623 uzder(1,3,1)=-dc_norm(2,i-1)
2624 uzder(2,3,1)= dc_norm(1,i-1)
2627 uzder(2,1,2)= dc_norm(3,i)
2628 uzder(3,1,2)=-dc_norm(2,i)
2629 uzder(1,2,2)=-dc_norm(3,i)
2631 uzder(3,2,2)= dc_norm(1,i)
2632 uzder(1,3,2)= dc_norm(2,i)
2633 uzder(2,3,2)=-dc_norm(1,i)
2635 C Compute the Y-axis
2638 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2640 C Compute the derivatives of uy
2643 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2644 & -dc_norm(k,i)*dc_norm(j,i-1)
2645 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2647 uyder(j,j,1)=uyder(j,j,1)-costh
2648 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2653 uygrad(l,k,j,i)=uyder(l,k,j)
2654 uzgrad(l,k,j,i)=uzder(l,k,j)
2658 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2659 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2660 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2661 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2664 C Compute the Z-axis
2665 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2666 costh=dcos(pi-theta(i+2))
2667 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2671 C Compute the derivatives of uz
2673 uzder(2,1,1)=-dc_norm(3,i+1)
2674 uzder(3,1,1)= dc_norm(2,i+1)
2675 uzder(1,2,1)= dc_norm(3,i+1)
2677 uzder(3,2,1)=-dc_norm(1,i+1)
2678 uzder(1,3,1)=-dc_norm(2,i+1)
2679 uzder(2,3,1)= dc_norm(1,i+1)
2682 uzder(2,1,2)= dc_norm(3,i)
2683 uzder(3,1,2)=-dc_norm(2,i)
2684 uzder(1,2,2)=-dc_norm(3,i)
2686 uzder(3,2,2)= dc_norm(1,i)
2687 uzder(1,3,2)= dc_norm(2,i)
2688 uzder(2,3,2)=-dc_norm(1,i)
2690 C Compute the Y-axis
2693 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2695 C Compute the derivatives of uy
2698 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2699 & -dc_norm(k,i)*dc_norm(j,i+1)
2700 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2702 uyder(j,j,1)=uyder(j,j,1)-costh
2703 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2708 uygrad(l,k,j,i)=uyder(l,k,j)
2709 uzgrad(l,k,j,i)=uzder(l,k,j)
2713 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2714 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2715 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2716 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2720 vbld_inv_temp(1)=vbld_inv(i+1)
2721 if (i.lt.nres-1) then
2722 vbld_inv_temp(2)=vbld_inv(i+2)
2724 vbld_inv_temp(2)=vbld_inv(i)
2729 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2730 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2735 #if defined(PARVEC) && defined(MPI)
2736 if (nfgtasks1.gt.1) then
2738 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2739 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2740 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2741 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2742 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2744 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2745 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2747 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2748 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2749 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2750 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2751 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2752 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2753 time_gather=time_gather+MPI_Wtime()-time00
2757 if (fg_rank.eq.0) then
2758 write (iout,*) "Arrays UY and UZ"
2760 write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2767 C-----------------------------------------------------------------------------
2768 subroutine check_vecgrad
2769 implicit real*8 (a-h,o-z)
2770 include 'DIMENSIONS'
2771 include 'COMMON.IOUNITS'
2772 include 'COMMON.GEO'
2773 include 'COMMON.VAR'
2774 include 'COMMON.LOCAL'
2775 include 'COMMON.CHAIN'
2776 include 'COMMON.VECTORS'
2777 dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2778 dimension uyt(3,maxres),uzt(3,maxres)
2779 dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2780 double precision delta /1.0d-7/
2783 crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2784 crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2785 crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2786 cd write(iout,'(2i5,2(3f10.5,5x))') i,1,
2787 cd & (dc_norm(if90,i),if90=1,3)
2788 cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2789 cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2790 cd write(iout,'(a)')
2796 uygradt(l,k,j,i)=uygrad(l,k,j,i)
2797 uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2810 cd write (iout,*) 'i=',i
2812 erij(k)=dc_norm(k,i)
2816 dc_norm(k,i)=erij(k)
2818 dc_norm(j,i)=dc_norm(j,i)+delta
2819 c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2821 c dc_norm(k,i)=dc_norm(k,i)/fac
2823 c write (iout,*) (dc_norm(k,i),k=1,3)
2824 c write (iout,*) (erij(k),k=1,3)
2827 uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2828 uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2829 uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2830 uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2832 c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2833 c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2834 c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2837 dc_norm(k,i)=erij(k)
2840 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2841 cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2842 cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2843 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2844 cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2845 cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2846 cd write (iout,'(a)')
2851 C--------------------------------------------------------------------------
2852 subroutine set_matrices
2853 implicit real*8 (a-h,o-z)
2854 include 'DIMENSIONS'
2857 include "COMMON.SETUP"
2859 integer status(MPI_STATUS_SIZE)
2861 include 'COMMON.IOUNITS'
2862 include 'COMMON.GEO'
2863 include 'COMMON.VAR'
2864 include 'COMMON.LOCAL'
2865 include 'COMMON.CHAIN'
2866 include 'COMMON.DERIV'
2867 include 'COMMON.INTERACT'
2868 include 'COMMON.CONTACTS'
2869 include 'COMMON.TORSION'
2870 include 'COMMON.VECTORS'
2871 include 'COMMON.FFIELD'
2872 double precision auxvec(2),auxmat(2,2)
2874 C Compute the virtual-bond-torsional-angle dependent quantities needed
2875 C to calculate the el-loc multibody terms of various order.
2877 c write(iout,*) 'nphi=',nphi,nres
2878 c write(iout,*) "itype2loc",itype2loc
2880 do i=ivec_start+2,ivec_end+2
2884 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2885 iti = itype2loc(itype(i-2))
2889 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2890 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2891 iti1 = itype2loc(itype(i-1))
2897 cost1=dcos(theta(i-1))
2898 sint1=dsin(theta(i-1))
2900 sint1cub=sint1sq*sint1
2901 sint1cost1=2*sint1*cost1
2902 c write (iout,*) "bnew1",i,iti
2903 c write (iout,*) (bnew1(k,1,iti),k=1,3)
2904 c write (iout,*) (bnew1(k,2,iti),k=1,3)
2905 c write (iout,*) "bnew2",i,iti
2906 c write (iout,*) (bnew2(k,1,iti),k=1,3)
2907 c write (iout,*) (bnew2(k,2,iti),k=1,3)
2909 b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2911 gtb1(k,i-2)=cost1*b1k-sint1sq*
2912 & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2913 b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2915 gtb2(k,i-2)=cost1*b2k-sint1sq*
2916 & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2919 aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2920 cc(1,k,i-2)=sint1sq*aux
2921 gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2922 & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2923 aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2924 dd(1,k,i-2)=sint1sq*aux
2925 gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2926 & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2928 cc(2,1,i-2)=cc(1,2,i-2)
2929 cc(2,2,i-2)=-cc(1,1,i-2)
2930 gtcc(2,1,i-2)=gtcc(1,2,i-2)
2931 gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2932 dd(2,1,i-2)=dd(1,2,i-2)
2933 dd(2,2,i-2)=-dd(1,1,i-2)
2934 gtdd(2,1,i-2)=gtdd(1,2,i-2)
2935 gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2938 aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2939 EE(l,k,i-2)=sint1sq*aux
2940 gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2943 EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2944 EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2945 EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2946 EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2947 gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2948 gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2949 gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2950 c b1tilde(1,i-2)=b1(1,i-2)
2951 c b1tilde(2,i-2)=-b1(2,i-2)
2952 c b2tilde(1,i-2)=b2(1,i-2)
2953 c b2tilde(2,i-2)=-b2(2,i-2)
2955 write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2956 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
2957 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
2958 write (iout,*) 'theta=', theta(i-1)
2961 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2962 iti = itype2loc(itype(i-2))
2966 c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2967 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2968 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2969 iti1 = itype2loc(itype(i-1))
2979 CC(k,l,i-2)=ccold(k,l,iti)
2980 DD(k,l,i-2)=ddold(k,l,iti)
2981 EE(k,l,i-2)=eeold(k,l,iti)
2986 b1tilde(1,i-2)= b1(1,i-2)
2987 b1tilde(2,i-2)=-b1(2,i-2)
2988 b2tilde(1,i-2)= b2(1,i-2)
2989 b2tilde(2,i-2)=-b2(2,i-2)
2991 Ctilde(1,1,i-2)= CC(1,1,i-2)
2992 Ctilde(1,2,i-2)= CC(1,2,i-2)
2993 Ctilde(2,1,i-2)=-CC(2,1,i-2)
2994 Ctilde(2,2,i-2)=-CC(2,2,i-2)
2996 Dtilde(1,1,i-2)= DD(1,1,i-2)
2997 Dtilde(1,2,i-2)= DD(1,2,i-2)
2998 Dtilde(2,1,i-2)=-DD(2,1,i-2)
2999 Dtilde(2,2,i-2)=-DD(2,2,i-2)
3001 write(iout,*) "i",i," iti",iti
3002 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3003 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3007 do i=ivec_start+2,ivec_end+2
3011 if (i .lt. nres+1) then
3048 if (i .gt. 3 .and. i .lt. nres+1) then
3049 obrot_der(1,i-2)=-sin1
3050 obrot_der(2,i-2)= cos1
3051 Ugder(1,1,i-2)= sin1
3052 Ugder(1,2,i-2)=-cos1
3053 Ugder(2,1,i-2)=-cos1
3054 Ugder(2,2,i-2)=-sin1
3057 obrot2_der(1,i-2)=-dwasin2
3058 obrot2_der(2,i-2)= dwacos2
3059 Ug2der(1,1,i-2)= dwasin2
3060 Ug2der(1,2,i-2)=-dwacos2
3061 Ug2der(2,1,i-2)=-dwacos2
3062 Ug2der(2,2,i-2)=-dwasin2
3064 obrot_der(1,i-2)=0.0d0
3065 obrot_der(2,i-2)=0.0d0
3066 Ugder(1,1,i-2)=0.0d0
3067 Ugder(1,2,i-2)=0.0d0
3068 Ugder(2,1,i-2)=0.0d0
3069 Ugder(2,2,i-2)=0.0d0
3070 obrot2_der(1,i-2)=0.0d0
3071 obrot2_der(2,i-2)=0.0d0
3072 Ug2der(1,1,i-2)=0.0d0
3073 Ug2der(1,2,i-2)=0.0d0
3074 Ug2der(2,1,i-2)=0.0d0
3075 Ug2der(2,2,i-2)=0.0d0
3077 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3078 if (i.gt. nnt+2 .and. i.lt.nct+2) then
3079 iti = itype2loc(itype(i-2))
3083 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3084 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3085 iti1 = itype2loc(itype(i-1))
3089 cd write (iout,*) '*******i',i,' iti1',iti
3090 cd write (iout,*) 'b1',b1(:,iti)
3091 cd write (iout,*) 'b2',b2(:,iti)
3092 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3093 c if (i .gt. iatel_s+2) then
3094 if (i .gt. nnt+2) then
3095 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3097 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3098 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3100 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3101 c & EE(1,2,iti),EE(2,2,i)
3102 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3103 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3104 c write(iout,*) "Macierz EUG",
3105 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3107 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3109 call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3110 call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3111 call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3112 call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3113 call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3124 DtUg2(l,k,i-2)=0.0d0
3128 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3129 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3131 muder(k,i-2)=Ub2der(k,i-2)
3133 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3134 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3135 if (itype(i-1).le.ntyp) then
3136 iti1 = itype2loc(itype(i-1))
3144 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3145 c mu(k,i-2)=b1(k,i-1)
3146 c mu(k,i-2)=Ub2(k,i-2)
3149 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3150 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3151 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3152 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3153 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3154 & ((ee(l,k,i-2),l=1,2),k=1,2)
3156 cd write (iout,*) 'mu1',mu1(:,i-2)
3157 cd write (iout,*) 'mu2',mu2(:,i-2)
3158 cd write (iout,*) 'mu',i-2,mu(:,i-2)
3159 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3161 call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3162 call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3163 call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3164 call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3165 call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3166 C Vectors and matrices dependent on a single virtual-bond dihedral.
3167 call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3168 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3169 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3170 call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3171 call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3172 call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3173 call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3174 call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3175 call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3178 C Matrices dependent on two consecutive virtual-bond dihedrals.
3179 C The order of matrices is from left to right.
3180 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3182 c do i=max0(ivec_start,2),ivec_end
3184 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3185 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3186 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3187 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3188 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3189 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3190 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3191 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3194 #if defined(MPI) && defined(PARMAT)
3196 c if (fg_rank.eq.0) then
3197 write (iout,*) "Arrays UG and UGDER before GATHER"
3199 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3200 & ((ug(l,k,i),l=1,2),k=1,2),
3201 & ((ugder(l,k,i),l=1,2),k=1,2)
3203 write (iout,*) "Arrays UG2 and UG2DER"
3205 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3206 & ((ug2(l,k,i),l=1,2),k=1,2),
3207 & ((ug2der(l,k,i),l=1,2),k=1,2)
3209 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3211 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3212 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3213 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3215 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3217 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3218 & costab(i),sintab(i),costab2(i),sintab2(i)
3220 write (iout,*) "Array MUDER"
3222 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3226 if (nfgtasks.gt.1) then
3228 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3229 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3230 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3232 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3233 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3235 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3236 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3238 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3239 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3241 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3242 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3244 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3245 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3247 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3248 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3250 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3251 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3252 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3253 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3254 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3255 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3256 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3257 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3258 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3259 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3260 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3261 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3262 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3264 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3265 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3267 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3268 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3270 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3271 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3273 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3274 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3276 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3277 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3279 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3280 & ivec_count(fg_rank1),
3281 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3283 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3284 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3286 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3287 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3289 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3290 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3292 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3293 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3295 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3296 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3298 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3299 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3301 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3302 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3304 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3305 & ivec_count(fg_rank1),
3306 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3308 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3309 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3311 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3312 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3314 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3315 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3317 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3318 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3320 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3321 & ivec_count(fg_rank1),
3322 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3324 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3325 & ivec_count(fg_rank1),
3326 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3328 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3329 & ivec_count(fg_rank1),
3330 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3331 & MPI_MAT2,FG_COMM1,IERR)
3332 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3333 & ivec_count(fg_rank1),
3334 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3335 & MPI_MAT2,FG_COMM1,IERR)
3338 c Passes matrix info through the ring
3341 if (irecv.lt.0) irecv=nfgtasks1-1
3344 if (inext.ge.nfgtasks1) inext=0
3346 c write (iout,*) "isend",isend," irecv",irecv
3348 lensend=lentyp(isend)
3349 lenrecv=lentyp(irecv)
3350 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3351 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3352 c & MPI_ROTAT1(lensend),inext,2200+isend,
3353 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3354 c & iprev,2200+irecv,FG_COMM,status,IERR)
3355 c write (iout,*) "Gather ROTAT1"
3357 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3358 c & MPI_ROTAT2(lensend),inext,3300+isend,
3359 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3360 c & iprev,3300+irecv,FG_COMM,status,IERR)
3361 c write (iout,*) "Gather ROTAT2"
3363 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3364 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3365 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3366 & iprev,4400+irecv,FG_COMM,status,IERR)
3367 c write (iout,*) "Gather ROTAT_OLD"
3369 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3370 & MPI_PRECOMP11(lensend),inext,5500+isend,
3371 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3372 & iprev,5500+irecv,FG_COMM,status,IERR)
3373 c write (iout,*) "Gather PRECOMP11"
3375 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3376 & MPI_PRECOMP12(lensend),inext,6600+isend,
3377 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3378 & iprev,6600+irecv,FG_COMM,status,IERR)
3379 c write (iout,*) "Gather PRECOMP12"
3381 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3383 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3384 & MPI_ROTAT2(lensend),inext,7700+isend,
3385 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3386 & iprev,7700+irecv,FG_COMM,status,IERR)
3387 c write (iout,*) "Gather PRECOMP21"
3389 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3390 & MPI_PRECOMP22(lensend),inext,8800+isend,
3391 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3392 & iprev,8800+irecv,FG_COMM,status,IERR)
3393 c write (iout,*) "Gather PRECOMP22"
3395 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3396 & MPI_PRECOMP23(lensend),inext,9900+isend,
3397 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3398 & MPI_PRECOMP23(lenrecv),
3399 & iprev,9900+irecv,FG_COMM,status,IERR)
3400 c write (iout,*) "Gather PRECOMP23"
3405 if (irecv.lt.0) irecv=nfgtasks1-1
3408 time_gather=time_gather+MPI_Wtime()-time00
3411 c if (fg_rank.eq.0) then
3412 write (iout,*) "Arrays UG and UGDER"
3414 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3415 & ((ug(l,k,i),l=1,2),k=1,2),
3416 & ((ugder(l,k,i),l=1,2),k=1,2)
3418 write (iout,*) "Arrays UG2 and UG2DER"
3420 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3421 & ((ug2(l,k,i),l=1,2),k=1,2),
3422 & ((ug2der(l,k,i),l=1,2),k=1,2)
3424 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3426 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3427 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3428 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3430 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3432 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3433 & costab(i),sintab(i),costab2(i),sintab2(i)
3435 write (iout,*) "Array MUDER"
3437 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3443 cd iti = itype2loc(itype(i))
3446 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3447 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3452 C--------------------------------------------------------------------------
3453 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3455 C This subroutine calculates the average interaction energy and its gradient
3456 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3457 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3458 C The potential depends both on the distance of peptide-group centers and on
3459 C the orientation of the CA-CA virtual bonds.
3461 implicit real*8 (a-h,o-z)
3465 include 'DIMENSIONS'
3466 include 'COMMON.CONTROL'
3467 include 'COMMON.SETUP'
3468 include 'COMMON.IOUNITS'
3469 include 'COMMON.GEO'
3470 include 'COMMON.VAR'
3471 include 'COMMON.LOCAL'
3472 include 'COMMON.CHAIN'
3473 include 'COMMON.DERIV'
3474 include 'COMMON.INTERACT'
3475 include 'COMMON.CONTACTS'
3476 include 'COMMON.TORSION'
3477 include 'COMMON.VECTORS'
3478 include 'COMMON.FFIELD'
3479 include 'COMMON.TIME1'
3480 include 'COMMON.SPLITELE'
3481 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3482 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3483 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3484 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3485 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3486 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3488 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3490 double precision scal_el /1.0d0/
3492 double precision scal_el /0.5d0/
3495 C 13-go grudnia roku pamietnego...
3496 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3497 & 0.0d0,1.0d0,0.0d0,
3498 & 0.0d0,0.0d0,1.0d0/
3499 cd write(iout,*) 'In EELEC'
3501 cd write(iout,*) 'Type',i
3502 cd write(iout,*) 'B1',B1(:,i)
3503 cd write(iout,*) 'B2',B2(:,i)
3504 cd write(iout,*) 'CC',CC(:,:,i)
3505 cd write(iout,*) 'DD',DD(:,:,i)
3506 cd write(iout,*) 'EE',EE(:,:,i)
3508 cd call check_vecgrad
3510 if (icheckgrad.eq.1) then
3512 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3514 dc_norm(k,i)=dc(k,i)*fac
3516 c write (iout,*) 'i',i,' fac',fac
3519 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3520 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3521 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3522 c call vec_and_deriv
3528 time_mat=time_mat+MPI_Wtime()-time01
3532 cd write (iout,*) 'i=',i
3534 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3537 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3538 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3551 cd print '(a)','Enter EELEC'
3552 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3554 gel_loc_loc(i)=0.0d0
3559 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3561 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3563 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3564 do i=iturn3_start,iturn3_end
3566 C write(iout,*) "tu jest i",i
3567 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3568 C changes suggested by Ana to avoid out of bounds
3569 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3570 c & .or.((i+4).gt.nres)
3571 c & .or.((i-1).le.0)
3572 C end of changes by Ana
3573 & .or. itype(i+2).eq.ntyp1
3574 & .or. itype(i+3).eq.ntyp1) cycle
3575 C Adam: Instructions below will switch off existing interactions
3577 c if(itype(i-1).eq.ntyp1)cycle
3579 c if(i.LT.nres-3)then
3580 c if (itype(i+4).eq.ntyp1) cycle
3585 dx_normi=dc_norm(1,i)
3586 dy_normi=dc_norm(2,i)
3587 dz_normi=dc_norm(3,i)
3588 xmedi=c(1,i)+0.5d0*dxi
3589 ymedi=c(2,i)+0.5d0*dyi
3590 zmedi=c(3,i)+0.5d0*dzi
3591 xmedi=mod(xmedi,boxxsize)
3592 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3593 ymedi=mod(ymedi,boxysize)
3594 if (ymedi.lt.0) ymedi=ymedi+boxysize
3595 zmedi=mod(zmedi,boxzsize)
3596 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3598 call eelecij(i,i+2,ees,evdw1,eel_loc)
3599 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3600 num_cont_hb(i)=num_conti
3602 do i=iturn4_start,iturn4_end
3604 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3605 C changes suggested by Ana to avoid out of bounds
3606 c & .or.((i+5).gt.nres)
3607 c & .or.((i-1).le.0)
3608 C end of changes suggested by Ana
3609 & .or. itype(i+3).eq.ntyp1
3610 & .or. itype(i+4).eq.ntyp1
3611 c & .or. itype(i+5).eq.ntyp1
3612 c & .or. itype(i).eq.ntyp1
3613 c & .or. itype(i-1).eq.ntyp1
3618 dx_normi=dc_norm(1,i)
3619 dy_normi=dc_norm(2,i)
3620 dz_normi=dc_norm(3,i)
3621 xmedi=c(1,i)+0.5d0*dxi
3622 ymedi=c(2,i)+0.5d0*dyi
3623 zmedi=c(3,i)+0.5d0*dzi
3624 C Return atom into box, boxxsize is size of box in x dimension
3626 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3627 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3628 C Condition for being inside the proper box
3629 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3630 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3634 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3635 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3636 C Condition for being inside the proper box
3637 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3638 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3642 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3643 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3644 C Condition for being inside the proper box
3645 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3646 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3649 xmedi=mod(xmedi,boxxsize)
3650 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3651 ymedi=mod(ymedi,boxysize)
3652 if (ymedi.lt.0) ymedi=ymedi+boxysize
3653 zmedi=mod(zmedi,boxzsize)
3654 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3656 num_conti=num_cont_hb(i)
3657 c write(iout,*) "JESTEM W PETLI"
3658 call eelecij(i,i+3,ees,evdw1,eel_loc)
3659 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3660 & call eturn4(i,eello_turn4)
3661 num_cont_hb(i)=num_conti
3663 C Loop over all neighbouring boxes
3668 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3671 do i=iatel_s,iatel_e
3674 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3675 C changes suggested by Ana to avoid out of bounds
3676 c & .or.((i+2).gt.nres)
3677 c & .or.((i-1).le.0)
3678 C end of changes by Ana
3679 c & .or. itype(i+2).eq.ntyp1
3680 c & .or. itype(i-1).eq.ntyp1
3685 dx_normi=dc_norm(1,i)
3686 dy_normi=dc_norm(2,i)
3687 dz_normi=dc_norm(3,i)
3688 xmedi=c(1,i)+0.5d0*dxi
3689 ymedi=c(2,i)+0.5d0*dyi
3690 zmedi=c(3,i)+0.5d0*dzi
3691 xmedi=mod(xmedi,boxxsize)
3692 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3693 ymedi=mod(ymedi,boxysize)
3694 if (ymedi.lt.0) ymedi=ymedi+boxysize
3695 zmedi=mod(zmedi,boxzsize)
3696 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3697 C xmedi=xmedi+xshift*boxxsize
3698 C ymedi=ymedi+yshift*boxysize
3699 C zmedi=zmedi+zshift*boxzsize
3701 C Return tom into box, boxxsize is size of box in x dimension
3703 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3704 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3705 C Condition for being inside the proper box
3706 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3707 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3711 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3712 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3713 C Condition for being inside the proper box
3714 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3715 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3719 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3720 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3721 cC Condition for being inside the proper box
3722 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3723 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3727 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3728 num_conti=num_cont_hb(i)
3730 do j=ielstart(i),ielend(i)
3732 C write (iout,*) i,j
3734 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3735 C changes suggested by Ana to avoid out of bounds
3736 c & .or.((j+2).gt.nres)
3737 c & .or.((j-1).le.0)
3738 C end of changes by Ana
3739 c & .or.itype(j+2).eq.ntyp1
3740 c & .or.itype(j-1).eq.ntyp1
3742 call eelecij(i,j,ees,evdw1,eel_loc)
3744 num_cont_hb(i)=num_conti
3750 c write (iout,*) "Number of loop steps in EELEC:",ind
3752 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3753 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3755 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3756 ccc eel_loc=eel_loc+eello_turn3
3757 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3760 C-------------------------------------------------------------------------------
3761 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3762 implicit real*8 (a-h,o-z)
3763 include 'DIMENSIONS'
3767 include 'COMMON.CONTROL'
3768 include 'COMMON.IOUNITS'
3769 include 'COMMON.GEO'
3770 include 'COMMON.VAR'
3771 include 'COMMON.LOCAL'
3772 include 'COMMON.CHAIN'
3773 include 'COMMON.DERIV'
3774 include 'COMMON.INTERACT'
3775 include 'COMMON.CONTACTS'
3776 include 'COMMON.TORSION'
3777 include 'COMMON.VECTORS'
3778 include 'COMMON.FFIELD'
3779 include 'COMMON.TIME1'
3780 include 'COMMON.SPLITELE'
3781 include 'COMMON.SHIELD'
3782 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3783 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3784 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3785 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3786 & gmuij2(4),gmuji2(4)
3787 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3788 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3790 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3792 double precision scal_el /1.0d0/
3794 double precision scal_el /0.5d0/
3797 C 13-go grudnia roku pamietnego...
3798 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3799 & 0.0d0,1.0d0,0.0d0,
3800 & 0.0d0,0.0d0,1.0d0/
3801 integer xshift,yshift,zshift
3802 c time00=MPI_Wtime()
3803 cd write (iout,*) "eelecij",i,j
3807 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3808 aaa=app(iteli,itelj)
3809 bbb=bpp(iteli,itelj)
3810 ael6i=ael6(iteli,itelj)
3811 ael3i=ael3(iteli,itelj)
3815 dx_normj=dc_norm(1,j)
3816 dy_normj=dc_norm(2,j)
3817 dz_normj=dc_norm(3,j)
3818 C xj=c(1,j)+0.5D0*dxj-xmedi
3819 C yj=c(2,j)+0.5D0*dyj-ymedi
3820 C zj=c(3,j)+0.5D0*dzj-zmedi
3825 if (xj.lt.0) xj=xj+boxxsize
3827 if (yj.lt.0) yj=yj+boxysize
3829 if (zj.lt.0) zj=zj+boxzsize
3830 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3831 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3839 xj=xj_safe+xshift*boxxsize
3840 yj=yj_safe+yshift*boxysize
3841 zj=zj_safe+zshift*boxzsize
3842 dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3843 if(dist_temp.lt.dist_init) then
3853 if (isubchap.eq.1) then
3862 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3864 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3865 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3866 C Condition for being inside the proper box
3867 c if ((xj.gt.((0.5d0)*boxxsize)).or.
3868 c & (xj.lt.((-0.5d0)*boxxsize))) then
3872 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3873 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3874 C Condition for being inside the proper box
3875 c if ((yj.gt.((0.5d0)*boxysize)).or.
3876 c & (yj.lt.((-0.5d0)*boxysize))) then
3880 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3881 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3882 C Condition for being inside the proper box
3883 c if ((zj.gt.((0.5d0)*boxzsize)).or.
3884 c & (zj.lt.((-0.5d0)*boxzsize))) then
3887 C endif !endPBC condintion
3891 rij=xj*xj+yj*yj+zj*zj
3893 sss=sscale(sqrt(rij))
3894 sssgrad=sscagrad(sqrt(rij))
3895 c if (sss.gt.0.0d0) then
3901 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3902 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3903 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3904 fac=cosa-3.0D0*cosb*cosg
3906 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3907 if (j.eq.i+2) ev1=scal_el*ev1
3912 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3916 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3917 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3918 if (shield_mode.gt.0) then
3921 el1=el1*fac_shield(i)**2*fac_shield(j)**2
3922 el2=el2*fac_shield(i)**2*fac_shield(j)**2
3931 evdw1=evdw1+evdwij*sss
3932 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3933 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3934 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
3935 cd & xmedi,ymedi,zmedi,xj,yj,zj
3937 if (energy_dec) then
3938 write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
3940 &,iteli,itelj,aaa,evdw1,sss
3941 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3942 &fac_shield(i),fac_shield(j)
3946 C Calculate contributions to the Cartesian gradient.
3949 facvdw=-6*rrmij*(ev1+evdwij)*sss
3950 facel=-3*rrmij*(el1+eesij)
3957 * Radial derivatives. First process both termini of the fragment (i,j)
3962 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3963 & (shield_mode.gt.0)) then
3965 do ilist=1,ishield_list(i)
3966 iresshield=shield_list(ilist,i)
3968 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3970 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3972 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3973 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3974 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3975 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3976 C if (iresshield.gt.i) then
3977 C do ishi=i+1,iresshield-1
3978 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3979 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3983 C do ishi=iresshield,i
3984 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3985 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3991 do ilist=1,ishield_list(j)
3992 iresshield=shield_list(ilist,j)
3994 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3996 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3998 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3999 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4001 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4002 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4003 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4004 C if (iresshield.gt.j) then
4005 C do ishi=j+1,iresshield-1
4006 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4007 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4011 C do ishi=iresshield,j
4012 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4013 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4020 gshieldc(k,i)=gshieldc(k,i)+
4021 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4022 gshieldc(k,j)=gshieldc(k,j)+
4023 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4024 gshieldc(k,i-1)=gshieldc(k,i-1)+
4025 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4026 gshieldc(k,j-1)=gshieldc(k,j-1)+
4027 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4032 c ghalf=0.5D0*ggg(k)
4033 c gelc(k,i)=gelc(k,i)+ghalf
4034 c gelc(k,j)=gelc(k,j)+ghalf
4036 c 9/28/08 AL Gradient compotents will be summed only at the end
4037 C print *,"before", gelc_long(1,i), gelc_long(1,j)
4039 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4040 C & +grad_shield(k,j)*eesij/fac_shield(j)
4041 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4042 C & +grad_shield(k,i)*eesij/fac_shield(i)
4043 C gelc_long(k,i-1)=gelc_long(k,i-1)
4044 C & +grad_shield(k,i)*eesij/fac_shield(i)
4045 C gelc_long(k,j-1)=gelc_long(k,j-1)
4046 C & +grad_shield(k,j)*eesij/fac_shield(j)
4048 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4051 * Loop over residues i+1 thru j-1.
4055 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4058 if (sss.gt.0.0) then
4059 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4060 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4061 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4068 c ghalf=0.5D0*ggg(k)
4069 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4070 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4072 c 9/28/08 AL Gradient compotents will be summed only at the end
4074 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4075 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4078 * Loop over residues i+1 thru j-1.
4082 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4087 facvdw=(ev1+evdwij)*sss
4090 fac=-3*rrmij*(facvdw+facvdw+facel)
4095 * Radial derivatives. First process both termini of the fragment (i,j)
4098 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4100 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4102 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4104 c ghalf=0.5D0*ggg(k)
4105 c gelc(k,i)=gelc(k,i)+ghalf
4106 c gelc(k,j)=gelc(k,j)+ghalf
4108 c 9/28/08 AL Gradient compotents will be summed only at the end
4110 gelc_long(k,j)=gelc(k,j)+ggg(k)
4111 gelc_long(k,i)=gelc(k,i)-ggg(k)
4114 * Loop over residues i+1 thru j-1.
4118 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4121 c 9/28/08 AL Gradient compotents will be summed only at the end
4122 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4123 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4124 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4126 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4127 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4133 ecosa=2.0D0*fac3*fac1+fac4
4136 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4137 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4139 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4140 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4142 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4143 cd & (dcosg(k),k=1,3)
4145 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4146 & fac_shield(i)**2*fac_shield(j)**2
4149 c ghalf=0.5D0*ggg(k)
4150 c gelc(k,i)=gelc(k,i)+ghalf
4151 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4152 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4153 c gelc(k,j)=gelc(k,j)+ghalf
4154 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4155 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4159 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4162 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4165 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4166 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4167 & *fac_shield(i)**2*fac_shield(j)**2
4169 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4170 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4171 & *fac_shield(i)**2*fac_shield(j)**2
4172 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4173 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4175 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4179 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4180 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4181 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4183 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4184 C energy of a peptide unit is assumed in the form of a second-order
4185 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4186 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4187 C are computed for EVERY pair of non-contiguous peptide groups.
4190 if (j.lt.nres-1) then
4202 muij(kkk)=mu(k,i)*mu(l,j)
4203 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4205 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4206 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4207 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4208 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4209 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4210 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4215 write (iout,*) 'EELEC: i',i,' j',j
4216 write (iout,*) 'j',j,' j1',j1,' j2',j2
4217 write(iout,*) 'muij',muij
4219 ury=scalar(uy(1,i),erij)
4220 urz=scalar(uz(1,i),erij)
4221 vry=scalar(uy(1,j),erij)
4222 vrz=scalar(uz(1,j),erij)
4223 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4224 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4225 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4226 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4227 fac=dsqrt(-ael6i)*r3ij
4229 write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4230 write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4231 & "uyvz",scalar(uy(1,i),uz(1,j)),
4232 & "uzvy",scalar(uz(1,i),uy(1,j)),
4233 & "uzvz",scalar(uz(1,i),uz(1,j))
4234 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4235 write (iout,*) "fac",fac
4242 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4245 cd write (iout,'(4i5,4f10.5)')
4246 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4247 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4248 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4249 cd & uy(:,j),uz(:,j)
4250 cd write (iout,'(4f10.5)')
4251 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4252 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4253 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4254 cd write (iout,'(9f10.5/)')
4255 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4256 C Derivatives of the elements of A in virtual-bond vectors
4257 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4259 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4260 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4261 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4262 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4263 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4264 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4265 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4266 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4267 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4268 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4269 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4270 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4272 C Compute radial contributions to the gradient
4290 C Add the contributions coming from er
4293 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4294 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4295 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4296 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4299 C Derivatives in DC(i)
4300 cgrad ghalf1=0.5d0*agg(k,1)
4301 cgrad ghalf2=0.5d0*agg(k,2)
4302 cgrad ghalf3=0.5d0*agg(k,3)
4303 cgrad ghalf4=0.5d0*agg(k,4)
4304 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4305 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4306 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4307 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4308 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4309 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4310 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4311 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4312 C Derivatives in DC(i+1)
4313 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4314 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4315 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4316 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4317 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4318 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4319 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4320 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4321 C Derivatives in DC(j)
4322 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4323 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4324 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4325 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4326 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4327 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4328 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4329 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4330 C Derivatives in DC(j+1) or DC(nres-1)
4331 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4332 & -3.0d0*vryg(k,3)*ury)
4333 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4334 & -3.0d0*vrzg(k,3)*ury)
4335 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4336 & -3.0d0*vryg(k,3)*urz)
4337 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4338 & -3.0d0*vrzg(k,3)*urz)
4339 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4341 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4354 aggi(k,l)=-aggi(k,l)
4355 aggi1(k,l)=-aggi1(k,l)
4356 aggj(k,l)=-aggj(k,l)
4357 aggj1(k,l)=-aggj1(k,l)
4360 if (j.lt.nres-1) then
4366 aggi(k,l)=-aggi(k,l)
4367 aggi1(k,l)=-aggi1(k,l)
4368 aggj(k,l)=-aggj(k,l)
4369 aggj1(k,l)=-aggj1(k,l)
4380 aggi(k,l)=-aggi(k,l)
4381 aggi1(k,l)=-aggi1(k,l)
4382 aggj(k,l)=-aggj(k,l)
4383 aggj1(k,l)=-aggj1(k,l)
4388 IF (wel_loc.gt.0.0d0) THEN
4389 C Contribution to the local-electrostatic energy coming from the i-j pair
4390 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4393 write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4395 write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4396 & " wel_loc",wel_loc
4398 if (shield_mode.eq.0) then
4405 eel_loc_ij=eel_loc_ij
4406 & *fac_shield(i)*fac_shield(j)
4407 c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4408 c & 'eelloc',i,j,eel_loc_ij
4409 C Now derivative over eel_loc
4410 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4411 & (shield_mode.gt.0)) then
4414 do ilist=1,ishield_list(i)
4415 iresshield=shield_list(ilist,i)
4417 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4420 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4422 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4423 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4427 do ilist=1,ishield_list(j)
4428 iresshield=shield_list(ilist,j)
4430 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4433 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4435 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4436 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4443 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4444 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4445 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4446 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4447 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4448 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4449 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4450 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4455 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4456 c & ' eel_loc_ij',eel_loc_ij
4457 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4458 C Calculate patrial derivative for theta angle
4460 geel_loc_ij=(a22*gmuij1(1)
4464 & *fac_shield(i)*fac_shield(j)
4465 c write(iout,*) "derivative over thatai"
4466 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4468 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4469 & geel_loc_ij*wel_loc
4470 c write(iout,*) "derivative over thatai-1"
4471 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4478 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4479 & geel_loc_ij*wel_loc
4480 & *fac_shield(i)*fac_shield(j)
4482 c Derivative over j residue
4483 geel_loc_ji=a22*gmuji1(1)
4487 c write(iout,*) "derivative over thataj"
4488 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4491 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4492 & geel_loc_ji*wel_loc
4493 & *fac_shield(i)*fac_shield(j)
4500 c write(iout,*) "derivative over thataj-1"
4501 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4503 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4504 & geel_loc_ji*wel_loc
4505 & *fac_shield(i)*fac_shield(j)
4507 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4509 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4510 & 'eelloc',i,j,eel_loc_ij
4511 c if (eel_loc_ij.ne.0)
4512 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4513 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4515 eel_loc=eel_loc+eel_loc_ij
4516 C Partial derivatives in virtual-bond dihedral angles gamma
4518 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4519 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4520 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4521 & *fac_shield(i)*fac_shield(j)
4523 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4524 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4525 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4526 & *fac_shield(i)*fac_shield(j)
4527 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4529 ggg(l)=(agg(l,1)*muij(1)+
4530 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4531 & *fac_shield(i)*fac_shield(j)
4532 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4533 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4534 cgrad ghalf=0.5d0*ggg(l)
4535 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4536 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4540 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4543 C Remaining derivatives of eello
4545 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4546 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4547 & *fac_shield(i)*fac_shield(j)
4549 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4550 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4551 & *fac_shield(i)*fac_shield(j)
4553 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4554 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4555 & *fac_shield(i)*fac_shield(j)
4557 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4558 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4559 & *fac_shield(i)*fac_shield(j)
4563 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4564 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4565 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4566 & .and. num_conti.le.maxconts) then
4567 c write (iout,*) i,j," entered corr"
4569 C Calculate the contact function. The ith column of the array JCONT will
4570 C contain the numbers of atoms that make contacts with the atom I (of numbers
4571 C greater than I). The arrays FACONT and GACONT will contain the values of
4572 C the contact function and its derivative.
4573 c r0ij=1.02D0*rpp(iteli,itelj)
4574 c r0ij=1.11D0*rpp(iteli,itelj)
4575 r0ij=2.20D0*rpp(iteli,itelj)
4576 c r0ij=1.55D0*rpp(iteli,itelj)
4577 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4578 if (fcont.gt.0.0D0) then
4579 num_conti=num_conti+1
4580 if (num_conti.gt.maxconts) then
4581 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4582 & ' will skip next contacts for this conf.'
4584 jcont_hb(num_conti,i)=j
4585 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4586 cd & " jcont_hb",jcont_hb(num_conti,i)
4587 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4588 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4589 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4591 d_cont(num_conti,i)=rij
4592 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4593 C --- Electrostatic-interaction matrix ---
4594 a_chuj(1,1,num_conti,i)=a22
4595 a_chuj(1,2,num_conti,i)=a23
4596 a_chuj(2,1,num_conti,i)=a32
4597 a_chuj(2,2,num_conti,i)=a33
4598 C --- Gradient of rij
4600 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4607 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4608 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4609 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4610 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4611 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4616 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4617 C Calculate contact energies
4619 wij=cosa-3.0D0*cosb*cosg
4622 c fac3=dsqrt(-ael6i)/r0ij**3
4623 fac3=dsqrt(-ael6i)*r3ij
4624 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4625 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4626 if (ees0tmp.gt.0) then
4627 ees0pij=dsqrt(ees0tmp)
4631 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4632 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4633 if (ees0tmp.gt.0) then
4634 ees0mij=dsqrt(ees0tmp)
4639 if (shield_mode.eq.0) then
4643 ees0plist(num_conti,i)=j
4644 C fac_shield(i)=0.4d0
4645 C fac_shield(j)=0.6d0
4647 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4648 & *fac_shield(i)*fac_shield(j)
4649 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4650 & *fac_shield(i)*fac_shield(j)
4651 C Diagnostics. Comment out or remove after debugging!
4652 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4653 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4654 c ees0m(num_conti,i)=0.0D0
4656 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4657 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4658 C Angular derivatives of the contact function
4659 ees0pij1=fac3/ees0pij
4660 ees0mij1=fac3/ees0mij
4661 fac3p=-3.0D0*fac3*rrmij
4662 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4663 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4665 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4666 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4667 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4668 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4669 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4670 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4671 ecosap=ecosa1+ecosa2
4672 ecosbp=ecosb1+ecosb2
4673 ecosgp=ecosg1+ecosg2
4674 ecosam=ecosa1-ecosa2
4675 ecosbm=ecosb1-ecosb2
4676 ecosgm=ecosg1-ecosg2
4685 facont_hb(num_conti,i)=fcont
4686 fprimcont=fprimcont/rij
4687 cd facont_hb(num_conti,i)=1.0D0
4688 C Following line is for diagnostics.
4691 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4692 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4695 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4696 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4698 gggp(1)=gggp(1)+ees0pijp*xj
4699 gggp(2)=gggp(2)+ees0pijp*yj
4700 gggp(3)=gggp(3)+ees0pijp*zj
4701 gggm(1)=gggm(1)+ees0mijp*xj
4702 gggm(2)=gggm(2)+ees0mijp*yj
4703 gggm(3)=gggm(3)+ees0mijp*zj
4704 C Derivatives due to the contact function
4705 gacont_hbr(1,num_conti,i)=fprimcont*xj
4706 gacont_hbr(2,num_conti,i)=fprimcont*yj
4707 gacont_hbr(3,num_conti,i)=fprimcont*zj
4710 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4711 c following the change of gradient-summation algorithm.
4713 cgrad ghalfp=0.5D0*gggp(k)
4714 cgrad ghalfm=0.5D0*gggm(k)
4715 gacontp_hb1(k,num_conti,i)=!ghalfp
4716 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4717 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4718 & *fac_shield(i)*fac_shield(j)
4720 gacontp_hb2(k,num_conti,i)=!ghalfp
4721 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4722 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4723 & *fac_shield(i)*fac_shield(j)
4725 gacontp_hb3(k,num_conti,i)=gggp(k)
4726 & *fac_shield(i)*fac_shield(j)
4728 gacontm_hb1(k,num_conti,i)=!ghalfm
4729 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4730 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4731 & *fac_shield(i)*fac_shield(j)
4733 gacontm_hb2(k,num_conti,i)=!ghalfm
4734 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4735 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4736 & *fac_shield(i)*fac_shield(j)
4738 gacontm_hb3(k,num_conti,i)=gggm(k)
4739 & *fac_shield(i)*fac_shield(j)
4742 C Diagnostics. Comment out or remove after debugging!
4744 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4745 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4746 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4747 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4748 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4749 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4752 endif ! num_conti.le.maxconts
4755 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4758 ghalf=0.5d0*agg(l,k)
4759 aggi(l,k)=aggi(l,k)+ghalf
4760 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4761 aggj(l,k)=aggj(l,k)+ghalf
4764 if (j.eq.nres-1 .and. i.lt.j-2) then
4767 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4772 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4775 C-----------------------------------------------------------------------------
4776 subroutine eturn3(i,eello_turn3)
4777 C Third- and fourth-order contributions from turns
4778 implicit real*8 (a-h,o-z)
4779 include 'DIMENSIONS'
4780 include 'COMMON.IOUNITS'
4781 include 'COMMON.GEO'
4782 include 'COMMON.VAR'
4783 include 'COMMON.LOCAL'
4784 include 'COMMON.CHAIN'
4785 include 'COMMON.DERIV'
4786 include 'COMMON.INTERACT'
4787 include 'COMMON.CONTACTS'
4788 include 'COMMON.TORSION'
4789 include 'COMMON.VECTORS'
4790 include 'COMMON.FFIELD'
4791 include 'COMMON.CONTROL'
4792 include 'COMMON.SHIELD'
4794 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4795 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4796 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4797 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4798 & auxgmat2(2,2),auxgmatt2(2,2)
4799 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4800 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4801 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4802 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4805 c write (iout,*) "eturn3",i,j,j1,j2
4810 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4812 C Third-order contributions
4819 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4820 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4821 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4822 c auxalary matices for theta gradient
4823 c auxalary matrix for i+1 and constant i+2
4824 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4825 c auxalary matrix for i+2 and constant i+1
4826 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4827 call transpose2(auxmat(1,1),auxmat1(1,1))
4828 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4829 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4830 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4831 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4832 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4833 if (shield_mode.eq.0) then
4840 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4841 & *fac_shield(i)*fac_shield(j)
4842 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4843 & *fac_shield(i)*fac_shield(j)
4844 if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4847 C Derivatives in theta
4848 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4849 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4850 & *fac_shield(i)*fac_shield(j)
4851 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4852 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4853 & *fac_shield(i)*fac_shield(j)
4856 C Derivatives in shield mode
4857 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4858 & (shield_mode.gt.0)) then
4861 do ilist=1,ishield_list(i)
4862 iresshield=shield_list(ilist,i)
4864 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4866 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4868 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4869 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4873 do ilist=1,ishield_list(j)
4874 iresshield=shield_list(ilist,j)
4876 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4878 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4880 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4881 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4888 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4889 & grad_shield(k,i)*eello_t3/fac_shield(i)
4890 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4891 & grad_shield(k,j)*eello_t3/fac_shield(j)
4892 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4893 & grad_shield(k,i)*eello_t3/fac_shield(i)
4894 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4895 & grad_shield(k,j)*eello_t3/fac_shield(j)
4899 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4900 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
4901 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
4902 cd & ' eello_turn3_num',4*eello_turn3_num
4903 C Derivatives in gamma(i)
4904 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4905 call transpose2(auxmat2(1,1),auxmat3(1,1))
4906 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4907 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4908 & *fac_shield(i)*fac_shield(j)
4909 C Derivatives in gamma(i+1)
4910 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4911 call transpose2(auxmat2(1,1),auxmat3(1,1))
4912 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4913 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4914 & +0.5d0*(pizda(1,1)+pizda(2,2))
4915 & *fac_shield(i)*fac_shield(j)
4916 C Cartesian derivatives
4918 c ghalf1=0.5d0*agg(l,1)
4919 c ghalf2=0.5d0*agg(l,2)
4920 c ghalf3=0.5d0*agg(l,3)
4921 c ghalf4=0.5d0*agg(l,4)
4922 a_temp(1,1)=aggi(l,1)!+ghalf1
4923 a_temp(1,2)=aggi(l,2)!+ghalf2
4924 a_temp(2,1)=aggi(l,3)!+ghalf3
4925 a_temp(2,2)=aggi(l,4)!+ghalf4
4926 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4927 gcorr3_turn(l,i)=gcorr3_turn(l,i)
4928 & +0.5d0*(pizda(1,1)+pizda(2,2))
4929 & *fac_shield(i)*fac_shield(j)
4931 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4932 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4933 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4934 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4935 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4936 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4937 & +0.5d0*(pizda(1,1)+pizda(2,2))
4938 & *fac_shield(i)*fac_shield(j)
4939 a_temp(1,1)=aggj(l,1)!+ghalf1
4940 a_temp(1,2)=aggj(l,2)!+ghalf2
4941 a_temp(2,1)=aggj(l,3)!+ghalf3
4942 a_temp(2,2)=aggj(l,4)!+ghalf4
4943 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4944 gcorr3_turn(l,j)=gcorr3_turn(l,j)
4945 & +0.5d0*(pizda(1,1)+pizda(2,2))
4946 & *fac_shield(i)*fac_shield(j)
4947 a_temp(1,1)=aggj1(l,1)
4948 a_temp(1,2)=aggj1(l,2)
4949 a_temp(2,1)=aggj1(l,3)
4950 a_temp(2,2)=aggj1(l,4)
4951 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4952 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4953 & +0.5d0*(pizda(1,1)+pizda(2,2))
4954 & *fac_shield(i)*fac_shield(j)
4958 C-------------------------------------------------------------------------------
4959 subroutine eturn4(i,eello_turn4)
4960 C Third- and fourth-order contributions from turns
4961 implicit real*8 (a-h,o-z)
4962 include 'DIMENSIONS'
4963 include 'COMMON.IOUNITS'
4964 include 'COMMON.GEO'
4965 include 'COMMON.VAR'
4966 include 'COMMON.LOCAL'
4967 include 'COMMON.CHAIN'
4968 include 'COMMON.DERIV'
4969 include 'COMMON.INTERACT'
4970 include 'COMMON.CONTACTS'
4971 include 'COMMON.TORSION'
4972 include 'COMMON.VECTORS'
4973 include 'COMMON.FFIELD'
4974 include 'COMMON.CONTROL'
4975 include 'COMMON.SHIELD'
4977 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4978 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4979 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4980 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4981 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
4982 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4983 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4984 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4985 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4986 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4987 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4990 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4992 C Fourth-order contributions
5000 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5001 cd call checkint_turn4(i,a_temp,eello_turn4_num)
5002 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5003 c write(iout,*)"WCHODZE W PROGRAM"
5008 iti1=itype2loc(itype(i+1))
5009 iti2=itype2loc(itype(i+2))
5010 iti3=itype2loc(itype(i+3))
5011 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5012 call transpose2(EUg(1,1,i+1),e1t(1,1))
5013 call transpose2(Eug(1,1,i+2),e2t(1,1))
5014 call transpose2(Eug(1,1,i+3),e3t(1,1))
5015 C Ematrix derivative in theta
5016 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5017 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5018 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5019 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5020 c eta1 in derivative theta
5021 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5022 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5023 c auxgvec is derivative of Ub2 so i+3 theta
5024 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5025 c auxalary matrix of E i+1
5026 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5029 s1=scalar2(b1(1,i+2),auxvec(1))
5030 c derivative of theta i+2 with constant i+3
5031 gs23=scalar2(gtb1(1,i+2),auxvec(1))
5032 c derivative of theta i+2 with constant i+2
5033 gs32=scalar2(b1(1,i+2),auxgvec(1))
5034 c derivative of E matix in theta of i+1
5035 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5037 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5038 c ea31 in derivative theta
5039 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5040 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5041 c auxilary matrix auxgvec of Ub2 with constant E matirx
5042 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5043 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5044 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5048 s2=scalar2(b1(1,i+1),auxvec(1))
5049 c derivative of theta i+1 with constant i+3
5050 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5051 c derivative of theta i+2 with constant i+1
5052 gs21=scalar2(b1(1,i+1),auxgvec(1))
5053 c derivative of theta i+3 with constant i+1
5054 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5055 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5057 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5058 c two derivatives over diffetent matrices
5059 c gtae3e2 is derivative over i+3
5060 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5061 c ae3gte2 is derivative over i+2
5062 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5063 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5064 c three possible derivative over theta E matices
5066 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5068 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5070 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5071 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5073 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5074 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5075 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5076 if (shield_mode.eq.0) then
5083 eello_turn4=eello_turn4-(s1+s2+s3)
5084 & *fac_shield(i)*fac_shield(j)
5085 eello_t4=-(s1+s2+s3)
5086 & *fac_shield(i)*fac_shield(j)
5087 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5088 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5089 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5090 C Now derivative over shield:
5091 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5092 & (shield_mode.gt.0)) then
5095 do ilist=1,ishield_list(i)
5096 iresshield=shield_list(ilist,i)
5098 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5100 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5102 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5103 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5107 do ilist=1,ishield_list(j)
5108 iresshield=shield_list(ilist,j)
5110 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5112 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5114 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5115 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5122 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5123 & grad_shield(k,i)*eello_t4/fac_shield(i)
5124 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5125 & grad_shield(k,j)*eello_t4/fac_shield(j)
5126 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5127 & grad_shield(k,i)*eello_t4/fac_shield(i)
5128 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5129 & grad_shield(k,j)*eello_t4/fac_shield(j)
5138 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5139 cd & ' eello_turn4_num',8*eello_turn4_num
5141 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5142 & -(gs13+gsE13+gsEE1)*wturn4
5143 & *fac_shield(i)*fac_shield(j)
5144 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5145 & -(gs23+gs21+gsEE2)*wturn4
5146 & *fac_shield(i)*fac_shield(j)
5148 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5149 & -(gs32+gsE31+gsEE3)*wturn4
5150 & *fac_shield(i)*fac_shield(j)
5152 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5155 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5156 & 'eturn4',i,j,-(s1+s2+s3)
5157 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5158 c & ' eello_turn4_num',8*eello_turn4_num
5159 C Derivatives in gamma(i)
5160 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5161 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5162 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5163 s1=scalar2(b1(1,i+2),auxvec(1))
5164 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5165 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5166 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5167 & *fac_shield(i)*fac_shield(j)
5168 C Derivatives in gamma(i+1)
5169 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5170 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5171 s2=scalar2(b1(1,i+1),auxvec(1))
5172 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5173 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5174 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5175 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5176 & *fac_shield(i)*fac_shield(j)
5177 C Derivatives in gamma(i+2)
5178 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5179 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5180 s1=scalar2(b1(1,i+2),auxvec(1))
5181 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5182 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5183 s2=scalar2(b1(1,i+1),auxvec(1))
5184 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5185 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5186 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5187 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5188 & *fac_shield(i)*fac_shield(j)
5189 C Cartesian derivatives
5190 C Derivatives of this turn contributions in DC(i+2)
5191 if (j.lt.nres-1) then
5193 a_temp(1,1)=agg(l,1)
5194 a_temp(1,2)=agg(l,2)
5195 a_temp(2,1)=agg(l,3)
5196 a_temp(2,2)=agg(l,4)
5197 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5198 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5199 s1=scalar2(b1(1,i+2),auxvec(1))
5200 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5201 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5202 s2=scalar2(b1(1,i+1),auxvec(1))
5203 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5204 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5205 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5207 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5208 & *fac_shield(i)*fac_shield(j)
5211 C Remaining derivatives of this turn contribution
5213 a_temp(1,1)=aggi(l,1)
5214 a_temp(1,2)=aggi(l,2)
5215 a_temp(2,1)=aggi(l,3)
5216 a_temp(2,2)=aggi(l,4)
5217 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5218 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5219 s1=scalar2(b1(1,i+2),auxvec(1))
5220 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5221 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5222 s2=scalar2(b1(1,i+1),auxvec(1))
5223 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5224 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5225 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5226 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5227 & *fac_shield(i)*fac_shield(j)
5228 a_temp(1,1)=aggi1(l,1)
5229 a_temp(1,2)=aggi1(l,2)
5230 a_temp(2,1)=aggi1(l,3)
5231 a_temp(2,2)=aggi1(l,4)
5232 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5233 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5234 s1=scalar2(b1(1,i+2),auxvec(1))
5235 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5236 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5237 s2=scalar2(b1(1,i+1),auxvec(1))
5238 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5239 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5240 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5241 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5242 & *fac_shield(i)*fac_shield(j)
5243 a_temp(1,1)=aggj(l,1)
5244 a_temp(1,2)=aggj(l,2)
5245 a_temp(2,1)=aggj(l,3)
5246 a_temp(2,2)=aggj(l,4)
5247 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5248 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5249 s1=scalar2(b1(1,i+2),auxvec(1))
5250 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5251 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5252 s2=scalar2(b1(1,i+1),auxvec(1))
5253 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5254 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5255 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5256 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5257 & *fac_shield(i)*fac_shield(j)
5258 a_temp(1,1)=aggj1(l,1)
5259 a_temp(1,2)=aggj1(l,2)
5260 a_temp(2,1)=aggj1(l,3)
5261 a_temp(2,2)=aggj1(l,4)
5262 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5263 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5264 s1=scalar2(b1(1,i+2),auxvec(1))
5265 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5266 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5267 s2=scalar2(b1(1,i+1),auxvec(1))
5268 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5269 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5270 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5271 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5272 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5273 & *fac_shield(i)*fac_shield(j)
5277 C-----------------------------------------------------------------------------
5278 subroutine vecpr(u,v,w)
5279 implicit real*8(a-h,o-z)
5280 dimension u(3),v(3),w(3)
5281 w(1)=u(2)*v(3)-u(3)*v(2)
5282 w(2)=-u(1)*v(3)+u(3)*v(1)
5283 w(3)=u(1)*v(2)-u(2)*v(1)
5286 C-----------------------------------------------------------------------------
5287 subroutine unormderiv(u,ugrad,unorm,ungrad)
5288 C This subroutine computes the derivatives of a normalized vector u, given
5289 C the derivatives computed without normalization conditions, ugrad. Returns
5292 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5293 double precision vec(3)
5294 double precision scalar
5296 c write (2,*) 'ugrad',ugrad
5299 vec(i)=scalar(ugrad(1,i),u(1))
5301 c write (2,*) 'vec',vec
5304 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5307 c write (2,*) 'ungrad',ungrad
5310 C-----------------------------------------------------------------------------
5311 subroutine escp_soft_sphere(evdw2,evdw2_14)
5313 C This subroutine calculates the excluded-volume interaction energy between
5314 C peptide-group centers and side chains and its gradient in virtual-bond and
5315 C side-chain vectors.
5317 implicit real*8 (a-h,o-z)
5318 include 'DIMENSIONS'
5319 include 'COMMON.GEO'
5320 include 'COMMON.VAR'
5321 include 'COMMON.LOCAL'
5322 include 'COMMON.CHAIN'
5323 include 'COMMON.DERIV'
5324 include 'COMMON.INTERACT'
5325 include 'COMMON.FFIELD'
5326 include 'COMMON.IOUNITS'
5327 include 'COMMON.CONTROL'
5329 integer xshift,yshift,zshift
5333 cd print '(a)','Enter ESCP'
5334 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5338 do i=iatscp_s,iatscp_e
5339 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5341 xi=0.5D0*(c(1,i)+c(1,i+1))
5342 yi=0.5D0*(c(2,i)+c(2,i+1))
5343 zi=0.5D0*(c(3,i)+c(3,i+1))
5344 C Return atom into box, boxxsize is size of box in x dimension
5346 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5347 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5348 C Condition for being inside the proper box
5349 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5350 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5354 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5355 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5356 C Condition for being inside the proper box
5357 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5358 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5362 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5363 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5364 cC Condition for being inside the proper box
5365 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5366 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5370 if (xi.lt.0) xi=xi+boxxsize
5372 if (yi.lt.0) yi=yi+boxysize
5374 if (zi.lt.0) zi=zi+boxzsize
5375 C xi=xi+xshift*boxxsize
5376 C yi=yi+yshift*boxysize
5377 C zi=zi+zshift*boxzsize
5378 do iint=1,nscp_gr(i)
5380 do j=iscpstart(i,iint),iscpend(i,iint)
5381 if (itype(j).eq.ntyp1) cycle
5382 itypj=iabs(itype(j))
5383 C Uncomment following three lines for SC-p interactions
5387 C Uncomment following three lines for Ca-p interactions
5392 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5393 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5394 C Condition for being inside the proper box
5395 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5396 c & (xj.lt.((-0.5d0)*boxxsize))) then
5400 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5401 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5402 cC Condition for being inside the proper box
5403 c if ((yj.gt.((0.5d0)*boxysize)).or.
5404 c & (yj.lt.((-0.5d0)*boxysize))) then
5408 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5409 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5410 C Condition for being inside the proper box
5411 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5412 c & (zj.lt.((-0.5d0)*boxzsize))) then
5415 if (xj.lt.0) xj=xj+boxxsize
5417 if (yj.lt.0) yj=yj+boxysize
5419 if (zj.lt.0) zj=zj+boxzsize
5420 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5428 xj=xj_safe+xshift*boxxsize
5429 yj=yj_safe+yshift*boxysize
5430 zj=zj_safe+zshift*boxzsize
5431 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5432 if(dist_temp.lt.dist_init) then
5442 if (subchap.eq.1) then
5455 rij=xj*xj+yj*yj+zj*zj
5459 if (rij.lt.r0ijsq) then
5460 evdwij=0.25d0*(rij-r0ijsq)**2
5468 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5473 cgrad if (j.lt.i) then
5474 cd write (iout,*) 'j<i'
5475 C Uncomment following three lines for SC-p interactions
5477 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5480 cd write (iout,*) 'j>i'
5482 cgrad ggg(k)=-ggg(k)
5483 C Uncomment following line for SC-p interactions
5484 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5488 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5490 cgrad kstart=min0(i+1,j)
5491 cgrad kend=max0(i-1,j-1)
5492 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5493 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5494 cgrad do k=kstart,kend
5496 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5500 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5501 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5512 C-----------------------------------------------------------------------------
5513 subroutine escp(evdw2,evdw2_14)
5515 C This subroutine calculates the excluded-volume interaction energy between
5516 C peptide-group centers and side chains and its gradient in virtual-bond and
5517 C side-chain vectors.
5519 implicit real*8 (a-h,o-z)
5520 include 'DIMENSIONS'
5521 include 'COMMON.GEO'
5522 include 'COMMON.VAR'
5523 include 'COMMON.LOCAL'
5524 include 'COMMON.CHAIN'
5525 include 'COMMON.DERIV'
5526 include 'COMMON.INTERACT'
5527 include 'COMMON.FFIELD'
5528 include 'COMMON.IOUNITS'
5529 include 'COMMON.CONTROL'
5530 include 'COMMON.SPLITELE'
5531 integer xshift,yshift,zshift
5535 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5536 cd print '(a)','Enter ESCP'
5537 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5541 if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5542 do i=iatscp_s,iatscp_e
5543 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5545 xi=0.5D0*(c(1,i)+c(1,i+1))
5546 yi=0.5D0*(c(2,i)+c(2,i+1))
5547 zi=0.5D0*(c(3,i)+c(3,i+1))
5549 if (xi.lt.0) xi=xi+boxxsize
5551 if (yi.lt.0) yi=yi+boxysize
5553 if (zi.lt.0) zi=zi+boxzsize
5554 c xi=xi+xshift*boxxsize
5555 c yi=yi+yshift*boxysize
5556 c zi=zi+zshift*boxzsize
5557 c print *,xi,yi,zi,'polozenie i'
5558 C Return atom into box, boxxsize is size of box in x dimension
5560 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5561 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5562 C Condition for being inside the proper box
5563 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5564 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5568 c print *,xi,boxxsize,"pierwszy"
5570 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5571 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5572 C Condition for being inside the proper box
5573 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5574 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5578 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5579 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5580 C Condition for being inside the proper box
5581 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5582 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5585 do iint=1,nscp_gr(i)
5587 do j=iscpstart(i,iint),iscpend(i,iint)
5588 itypj=iabs(itype(j))
5589 if (itypj.eq.ntyp1) cycle
5590 C Uncomment following three lines for SC-p interactions
5594 C Uncomment following three lines for Ca-p interactions
5599 if (xj.lt.0) xj=xj+boxxsize
5601 if (yj.lt.0) yj=yj+boxysize
5603 if (zj.lt.0) zj=zj+boxzsize
5605 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5606 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5607 C Condition for being inside the proper box
5608 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5609 c & (xj.lt.((-0.5d0)*boxxsize))) then
5613 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5614 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5615 cC Condition for being inside the proper box
5616 c if ((yj.gt.((0.5d0)*boxysize)).or.
5617 c & (yj.lt.((-0.5d0)*boxysize))) then
5621 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5622 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5623 C Condition for being inside the proper box
5624 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5625 c & (zj.lt.((-0.5d0)*boxzsize))) then
5628 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5629 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5637 xj=xj_safe+xshift*boxxsize
5638 yj=yj_safe+yshift*boxysize
5639 zj=zj_safe+zshift*boxzsize
5640 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5641 if(dist_temp.lt.dist_init) then
5651 if (subchap.eq.1) then
5660 c print *,xj,yj,zj,'polozenie j'
5661 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5663 sss=sscale(1.0d0/(dsqrt(rrij)))
5664 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5665 c if (sss.eq.0) print *,'czasem jest OK'
5666 if (sss.le.0.0d0) cycle
5667 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5669 e1=fac*fac*aad(itypj,iteli)
5670 e2=fac*bad(itypj,iteli)
5671 if (iabs(j-i) .le. 2) then
5674 evdw2_14=evdw2_14+(e1+e2)*sss
5677 evdw2=evdw2+evdwij*sss
5678 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5679 & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5682 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5684 fac=-(evdwij+e1)*rrij*sss
5685 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5689 cgrad if (j.lt.i) then
5690 cd write (iout,*) 'j<i'
5691 C Uncomment following three lines for SC-p interactions
5693 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5696 cd write (iout,*) 'j>i'
5698 cgrad ggg(k)=-ggg(k)
5699 C Uncomment following line for SC-p interactions
5700 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5701 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5705 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5707 cgrad kstart=min0(i+1,j)
5708 cgrad kend=max0(i-1,j-1)
5709 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5710 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5711 cgrad do k=kstart,kend
5713 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5717 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5718 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5720 c endif !endif for sscale cutoff
5730 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5731 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5732 gradx_scp(j,i)=expon*gradx_scp(j,i)
5735 C******************************************************************************
5739 C To save time the factor EXPON has been extracted from ALL components
5740 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5743 C******************************************************************************
5746 C--------------------------------------------------------------------------
5747 subroutine edis(ehpb)
5749 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5751 implicit real*8 (a-h,o-z)
5752 include 'DIMENSIONS'
5753 include 'COMMON.SBRIDGE'
5754 include 'COMMON.CHAIN'
5755 include 'COMMON.DERIV'
5756 include 'COMMON.VAR'
5757 include 'COMMON.INTERACT'
5758 include 'COMMON.IOUNITS'
5759 include 'COMMON.CONTROL'
5760 dimension ggg(3),ggg_peak(3,1000)
5765 c 8/21/18 AL: added explicit restraints on reference coords
5766 c write (iout,*) "restr_on_coord",restr_on_coord
5767 if (restr_on_coord) then
5771 if (itype(i).eq.ntyp1) cycle
5773 ecoor=ecoor+(c(j,i)-cref(j,i))**2
5774 ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5776 if (itype(i).ne.10) then
5778 ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5779 ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5782 if (energy_dec) write (iout,*)
5783 & "i",i," bfac",bfac(i)," ecoor",ecoor
5784 ehpb=ehpb+0.5d0*bfac(i)*ecoor
5788 C write (iout,*) ,"link_end",link_end,constr_dist
5789 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5790 c write(iout,*)'link_start=',link_start,' link_end=',link_end,
5791 c & " constr_dist",constr_dist," link_start_peak",link_start_peak,
5792 c & " link_end_peak",link_end_peak
5793 if (link_end.eq.0.and.link_end_peak.eq.0) return
5794 do i=link_start_peak,link_end_peak
5796 c print *,"i",i," link_end_peak",link_end_peak," ipeak",
5797 c & ipeak(1,i),ipeak(2,i)
5798 do ip=ipeak(1,i),ipeak(2,i)
5803 C iii and jjj point to the residues for which the distance is assigned.
5804 c if (ii.gt.nres) then
5811 if (ii.gt.nres) then
5816 if (jj.gt.nres) then
5821 aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5822 aux=dexp(-scal_peak*aux)
5823 ehpb_peak=ehpb_peak+aux
5824 fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5825 & forcon_peak(ip))*aux/dd
5827 ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5829 if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5830 & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5831 & forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5833 c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5834 ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5835 do ip=ipeak(1,i),ipeak(2,i)
5838 ggg(j)=ggg_peak(j,iip)/ehpb_peak
5842 C iii and jjj point to the residues for which the distance is assigned.
5843 c if (ii.gt.nres) then
5850 if (ii.gt.nres) then
5855 if (jj.gt.nres) then
5862 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5867 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5871 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5872 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5876 do i=link_start,link_end
5877 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5878 C CA-CA distance used in regularization of structure.
5881 C iii and jjj point to the residues for which the distance is assigned.
5882 if (ii.gt.nres) then
5887 if (jj.gt.nres) then
5892 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5893 c & dhpb(i),dhpb1(i),forcon(i)
5894 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5895 C distance and angle dependent SS bond potential.
5896 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5897 C & iabs(itype(jjj)).eq.1) then
5898 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5899 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5900 if (.not.dyn_ss .and. i.le.nss) then
5901 C 15/02/13 CC dynamic SSbond - additional check
5902 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5903 & iabs(itype(jjj)).eq.1) then
5904 call ssbond_ene(iii,jjj,eij)
5907 cd write (iout,*) "eij",eij
5908 cd & ' waga=',waga,' fac=',fac
5909 ! else if (ii.gt.nres .and. jj.gt.nres) then
5911 C Calculate the distance between the two points and its difference from the
5914 if (irestr_type(i).eq.11) then
5915 ehpb=ehpb+fordepth(i)!**4.0d0
5916 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5917 fac=fordepth(i)!**4.0d0
5918 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5919 if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5920 & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5921 & ehpb,irestr_type(i)
5922 else if (irestr_type(i).eq.10) then
5923 c AL 6//19/2018 cross-link restraints
5924 xdis = 0.5d0*(dd/forcon(i))**2
5925 expdis = dexp(-xdis)
5926 c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5927 aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5928 c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5929 c & " wboltzd",wboltzd
5930 ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5931 c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5932 fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5933 & *expdis/(aux*forcon(i)**2)
5934 if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5935 & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5936 & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5937 else if (irestr_type(i).eq.2) then
5938 c Quartic restraints
5939 ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5940 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5941 & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5942 & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5943 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5945 c Quadratic restraints
5947 C Get the force constant corresponding to this distance.
5949 C Calculate the contribution to energy.
5950 ehpb=ehpb+0.5d0*waga*rdis*rdis
5951 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5952 & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5953 & 0.5d0*waga*rdis*rdis,irestr_type(i)
5955 C Evaluate gradient.
5959 c Calculate Cartesian gradient
5961 ggg(j)=fac*(c(j,jj)-c(j,ii))
5963 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5964 C If this is a SC-SC distance, we need to calculate the contributions to the
5965 C Cartesian gradient in the SC vectors (ghpbx).
5968 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5973 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5977 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5978 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5984 C--------------------------------------------------------------------------
5985 subroutine ssbond_ene(i,j,eij)
5987 C Calculate the distance and angle dependent SS-bond potential energy
5988 C using a free-energy function derived based on RHF/6-31G** ab initio
5989 C calculations of diethyl disulfide.
5991 C A. Liwo and U. Kozlowska, 11/24/03
5993 implicit real*8 (a-h,o-z)
5994 include 'DIMENSIONS'
5995 include 'COMMON.SBRIDGE'
5996 include 'COMMON.CHAIN'
5997 include 'COMMON.DERIV'
5998 include 'COMMON.LOCAL'
5999 include 'COMMON.INTERACT'
6000 include 'COMMON.VAR'
6001 include 'COMMON.IOUNITS'
6002 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6003 itypi=iabs(itype(i))
6007 dxi=dc_norm(1,nres+i)
6008 dyi=dc_norm(2,nres+i)
6009 dzi=dc_norm(3,nres+i)
6010 c dsci_inv=dsc_inv(itypi)
6011 dsci_inv=vbld_inv(nres+i)
6012 itypj=iabs(itype(j))
6013 c dscj_inv=dsc_inv(itypj)
6014 dscj_inv=vbld_inv(nres+j)
6018 dxj=dc_norm(1,nres+j)
6019 dyj=dc_norm(2,nres+j)
6020 dzj=dc_norm(3,nres+j)
6021 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6026 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6027 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6028 om12=dxi*dxj+dyi*dyj+dzi*dzj
6030 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6031 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6037 deltat12=om2-om1+2.0d0
6039 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6040 & +akct*deltad*deltat12
6041 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6042 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6043 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6044 c & " deltat12",deltat12," eij",eij
6045 ed=2*akcm*deltad+akct*deltat12
6047 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6048 eom1=-2*akth*deltat1-pom1-om2*pom2
6049 eom2= 2*akth*deltat2+pom1-om1*pom2
6052 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6053 ghpbx(k,i)=ghpbx(k,i)-ggk
6054 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6055 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6056 ghpbx(k,j)=ghpbx(k,j)+ggk
6057 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6058 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6059 ghpbc(k,i)=ghpbc(k,i)-ggk
6060 ghpbc(k,j)=ghpbc(k,j)+ggk
6063 C Calculate the components of the gradient in DC and X
6067 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
6072 C--------------------------------------------------------------------------
6073 subroutine ebond(estr)
6075 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6077 implicit real*8 (a-h,o-z)
6078 include 'DIMENSIONS'
6079 include 'COMMON.LOCAL'
6080 include 'COMMON.GEO'
6081 include 'COMMON.INTERACT'
6082 include 'COMMON.DERIV'
6083 include 'COMMON.VAR'
6084 include 'COMMON.CHAIN'
6085 include 'COMMON.IOUNITS'
6086 include 'COMMON.NAMES'
6087 include 'COMMON.FFIELD'
6088 include 'COMMON.CONTROL'
6089 include 'COMMON.SETUP'
6090 double precision u(3),ud(3)
6093 do i=ibondp_start,ibondp_end
6094 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6095 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6097 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6098 c & *dc(j,i-1)/vbld(i)
6100 c if (energy_dec) write(iout,*)
6101 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6103 C Checking if it involves dummy (NH3+ or COO-) group
6104 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6105 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
6106 diff = vbld(i)-vbldpDUM
6107 if (energy_dec) write(iout,*) "dum_bond",i,diff
6109 C NO vbldp0 is the equlibrium lenght of spring for peptide group
6110 diff = vbld(i)-vbldp0
6112 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6113 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6116 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6118 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6122 estr=0.5d0*AKP*estr+estr1
6124 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6126 do i=ibond_start,ibond_end
6128 if (iti.ne.10 .and. iti.ne.ntyp1) then
6131 diff=vbld(i+nres)-vbldsc0(1,iti)
6132 if (energy_dec) write (iout,*)
6133 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6134 & AKSC(1,iti),AKSC(1,iti)*diff*diff
6135 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6137 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6141 diff=vbld(i+nres)-vbldsc0(j,iti)
6142 ud(j)=aksc(j,iti)*diff
6143 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6157 uprod2=uprod2*u(k)*u(k)
6161 usumsqder=usumsqder+ud(j)*uprod2
6163 estr=estr+uprod/usum
6165 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6173 C--------------------------------------------------------------------------
6174 subroutine ebend(etheta)
6176 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6177 C angles gamma and its derivatives in consecutive thetas and gammas.
6179 implicit real*8 (a-h,o-z)
6180 include 'DIMENSIONS'
6181 include 'COMMON.LOCAL'
6182 include 'COMMON.GEO'
6183 include 'COMMON.INTERACT'
6184 include 'COMMON.DERIV'
6185 include 'COMMON.VAR'
6186 include 'COMMON.CHAIN'
6187 include 'COMMON.IOUNITS'
6188 include 'COMMON.NAMES'
6189 include 'COMMON.FFIELD'
6190 include 'COMMON.CONTROL'
6191 include 'COMMON.TORCNSTR'
6192 common /calcthet/ term1,term2,termm,diffak,ratak,
6193 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6194 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6195 double precision y(2),z(2)
6197 c time11=dexp(-2*time)
6200 c write (*,'(a,i2)') 'EBEND ICG=',icg
6201 do i=ithet_start,ithet_end
6202 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6203 & .or.itype(i).eq.ntyp1) cycle
6204 C Zero the energy function and its derivative at 0 or pi.
6205 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6207 ichir1=isign(1,itype(i-2))
6208 ichir2=isign(1,itype(i))
6209 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6210 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6211 if (itype(i-1).eq.10) then
6212 itype1=isign(10,itype(i-2))
6213 ichir11=isign(1,itype(i-2))
6214 ichir12=isign(1,itype(i-2))
6215 itype2=isign(10,itype(i))
6216 ichir21=isign(1,itype(i))
6217 ichir22=isign(1,itype(i))
6220 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6223 if (phii.ne.phii) phii=150.0
6233 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6236 if (phii1.ne.phii1) phii1=150.0
6248 C Calculate the "mean" value of theta from the part of the distribution
6249 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6250 C In following comments this theta will be referred to as t_c.
6251 thet_pred_mean=0.0d0
6253 athetk=athet(k,it,ichir1,ichir2)
6254 bthetk=bthet(k,it,ichir1,ichir2)
6256 athetk=athet(k,itype1,ichir11,ichir12)
6257 bthetk=bthet(k,itype2,ichir21,ichir22)
6259 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6260 c write(iout,*) 'chuj tu', y(k),z(k)
6262 dthett=thet_pred_mean*ssd
6263 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6264 C Derivatives of the "mean" values in gamma1 and gamma2.
6265 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6266 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6267 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6268 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6270 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6271 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6272 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6273 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6275 if (theta(i).gt.pi-delta) then
6276 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6278 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6279 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6280 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6282 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6284 else if (theta(i).lt.delta) then
6285 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6286 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6287 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6289 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6290 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6293 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6296 etheta=etheta+ethetai
6297 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6298 & 'ebend',i,ethetai,theta(i),itype(i)
6299 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6300 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6301 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6304 C Ufff.... We've done all this!!!
6307 C---------------------------------------------------------------------------
6308 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6310 implicit real*8 (a-h,o-z)
6311 include 'DIMENSIONS'
6312 include 'COMMON.LOCAL'
6313 include 'COMMON.IOUNITS'
6314 common /calcthet/ term1,term2,termm,diffak,ratak,
6315 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6316 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6317 C Calculate the contributions to both Gaussian lobes.
6318 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6319 C The "polynomial part" of the "standard deviation" of this part of
6320 C the distributioni.
6321 ccc write (iout,*) thetai,thet_pred_mean
6324 sig=sig*thet_pred_mean+polthet(j,it)
6326 C Derivative of the "interior part" of the "standard deviation of the"
6327 C gamma-dependent Gaussian lobe in t_c.
6328 sigtc=3*polthet(3,it)
6330 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6333 C Set the parameters of both Gaussian lobes of the distribution.
6334 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6335 fac=sig*sig+sigc0(it)
6338 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6339 sigsqtc=-4.0D0*sigcsq*sigtc
6340 c print *,i,sig,sigtc,sigsqtc
6341 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6342 sigtc=-sigtc/(fac*fac)
6343 C Following variable is sigma(t_c)**(-2)
6344 sigcsq=sigcsq*sigcsq
6346 sig0inv=1.0D0/sig0i**2
6347 delthec=thetai-thet_pred_mean
6348 delthe0=thetai-theta0i
6349 term1=-0.5D0*sigcsq*delthec*delthec
6350 term2=-0.5D0*sig0inv*delthe0*delthe0
6351 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6352 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6353 C NaNs in taking the logarithm. We extract the largest exponent which is added
6354 C to the energy (this being the log of the distribution) at the end of energy
6355 C term evaluation for this virtual-bond angle.
6356 if (term1.gt.term2) then
6358 term2=dexp(term2-termm)
6362 term1=dexp(term1-termm)
6365 C The ratio between the gamma-independent and gamma-dependent lobes of
6366 C the distribution is a Gaussian function of thet_pred_mean too.
6367 diffak=gthet(2,it)-thet_pred_mean
6368 ratak=diffak/gthet(3,it)**2
6369 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6370 C Let's differentiate it in thet_pred_mean NOW.
6372 C Now put together the distribution terms to make complete distribution.
6373 termexp=term1+ak*term2
6374 termpre=sigc+ak*sig0i
6375 C Contribution of the bending energy from this theta is just the -log of
6376 C the sum of the contributions from the two lobes and the pre-exponential
6377 C factor. Simple enough, isn't it?
6378 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6379 C write (iout,*) 'termexp',termexp,termm,termpre,i
6380 C NOW the derivatives!!!
6381 C 6/6/97 Take into account the deformation.
6382 E_theta=(delthec*sigcsq*term1
6383 & +ak*delthe0*sig0inv*term2)/termexp
6384 E_tc=((sigtc+aktc*sig0i)/termpre
6385 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6386 & aktc*term2)/termexp)
6389 c-----------------------------------------------------------------------------
6390 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6391 implicit real*8 (a-h,o-z)
6392 include 'DIMENSIONS'
6393 include 'COMMON.LOCAL'
6394 include 'COMMON.IOUNITS'
6395 common /calcthet/ term1,term2,termm,diffak,ratak,
6396 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6397 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6398 delthec=thetai-thet_pred_mean
6399 delthe0=thetai-theta0i
6400 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6401 t3 = thetai-thet_pred_mean
6405 t14 = t12+t6*sigsqtc
6407 t21 = thetai-theta0i
6413 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6414 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6415 & *(-t12*t9-ak*sig0inv*t27)
6419 C--------------------------------------------------------------------------
6420 subroutine ebend(etheta)
6422 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6423 C angles gamma and its derivatives in consecutive thetas and gammas.
6424 C ab initio-derived potentials from
6425 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6427 implicit real*8 (a-h,o-z)
6428 include 'DIMENSIONS'
6429 include 'COMMON.LOCAL'
6430 include 'COMMON.GEO'
6431 include 'COMMON.INTERACT'
6432 include 'COMMON.DERIV'
6433 include 'COMMON.VAR'
6434 include 'COMMON.CHAIN'
6435 include 'COMMON.IOUNITS'
6436 include 'COMMON.NAMES'
6437 include 'COMMON.FFIELD'
6438 include 'COMMON.CONTROL'
6439 include 'COMMON.TORCNSTR'
6440 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6441 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6442 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6443 & sinph1ph2(maxdouble,maxdouble)
6444 logical lprn /.false./, lprn1 /.false./
6446 do i=ithet_start,ithet_end
6447 c print *,i,itype(i-1),itype(i),itype(i-2)
6448 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6449 & .or.itype(i).eq.ntyp1) cycle
6450 C print *,i,theta(i)
6451 if (iabs(itype(i+1)).eq.20) iblock=2
6452 if (iabs(itype(i+1)).ne.20) iblock=1
6456 theti2=0.5d0*theta(i)
6457 ityp2=ithetyp((itype(i-1)))
6459 coskt(k)=dcos(k*theti2)
6460 sinkt(k)=dsin(k*theti2)
6463 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6466 if (phii.ne.phii) phii=150.0
6470 ityp1=ithetyp((itype(i-2)))
6471 C propagation of chirality for glycine type
6473 cosph1(k)=dcos(k*phii)
6474 sinph1(k)=dsin(k*phii)
6479 ityp1=ithetyp((itype(i-2)))
6484 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6487 if (phii1.ne.phii1) phii1=150.0
6492 ityp3=ithetyp((itype(i)))
6494 cosph2(k)=dcos(k*phii1)
6495 sinph2(k)=dsin(k*phii1)
6499 ityp3=ithetyp((itype(i)))
6505 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6508 ccl=cosph1(l)*cosph2(k-l)
6509 ssl=sinph1(l)*sinph2(k-l)
6510 scl=sinph1(l)*cosph2(k-l)
6511 csl=cosph1(l)*sinph2(k-l)
6512 cosph1ph2(l,k)=ccl-ssl
6513 cosph1ph2(k,l)=ccl+ssl
6514 sinph1ph2(l,k)=scl+csl
6515 sinph1ph2(k,l)=scl-csl
6519 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6520 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6521 write (iout,*) "coskt and sinkt"
6523 write (iout,*) k,coskt(k),sinkt(k)
6527 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6528 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6531 & write (iout,*) "k",k,"
6532 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6533 & " ethetai",ethetai
6536 write (iout,*) "cosph and sinph"
6538 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6540 write (iout,*) "cosph1ph2 and sinph2ph2"
6543 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6544 & sinph1ph2(l,k),sinph1ph2(k,l)
6547 write(iout,*) "ethetai",ethetai
6552 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6553 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6554 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6555 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6556 ethetai=ethetai+sinkt(m)*aux
6557 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6558 dephii=dephii+k*sinkt(m)*(
6559 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6560 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6561 dephii1=dephii1+k*sinkt(m)*(
6562 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6563 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6565 & write (iout,*) "m",m," k",k," bbthet",
6566 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6567 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6568 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6569 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6570 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6573 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6574 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6575 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6576 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6578 & write(iout,*) "ethetai",ethetai
6579 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6583 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6584 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6585 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6586 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6587 ethetai=ethetai+sinkt(m)*aux
6588 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6589 dephii=dephii+l*sinkt(m)*(
6590 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6591 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6592 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6593 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6594 dephii1=dephii1+(k-l)*sinkt(m)*(
6595 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6596 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6597 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6598 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6600 write (iout,*) "m",m," k",k," l",l," ffthet",
6601 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6602 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6603 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6604 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6605 & " ethetai",ethetai
6606 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6607 & cosph1ph2(k,l)*sinkt(m),
6608 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6617 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6618 & i,theta(i)*rad2deg,phii*rad2deg,
6619 & phii1*rad2deg,ethetai
6621 etheta=etheta+ethetai
6622 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6623 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6624 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6631 c-----------------------------------------------------------------------------
6632 subroutine esc(escloc)
6633 C Calculate the local energy of a side chain and its derivatives in the
6634 C corresponding virtual-bond valence angles THETA and the spherical angles
6636 implicit real*8 (a-h,o-z)
6637 include 'DIMENSIONS'
6638 include 'COMMON.GEO'
6639 include 'COMMON.LOCAL'
6640 include 'COMMON.VAR'
6641 include 'COMMON.INTERACT'
6642 include 'COMMON.DERIV'
6643 include 'COMMON.CHAIN'
6644 include 'COMMON.IOUNITS'
6645 include 'COMMON.NAMES'
6646 include 'COMMON.FFIELD'
6647 include 'COMMON.CONTROL'
6648 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6649 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6650 common /sccalc/ time11,time12,time112,theti,it,nlobit
6653 c write (iout,'(a)') 'ESC'
6654 do i=loc_start,loc_end
6656 if (it.eq.ntyp1) cycle
6657 if (it.eq.10) goto 1
6658 nlobit=nlob(iabs(it))
6659 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6660 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6661 theti=theta(i+1)-pipol
6666 if (x(2).gt.pi-delta) then
6670 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6672 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6673 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6675 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6676 & ddersc0(1),dersc(1))
6677 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6678 & ddersc0(3),dersc(3))
6680 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6682 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6683 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6684 & dersc0(2),esclocbi,dersc02)
6685 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6687 call splinthet(x(2),0.5d0*delta,ss,ssd)
6692 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6694 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6695 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6697 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6699 c write (iout,*) escloci
6700 else if (x(2).lt.delta) then
6704 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6706 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6707 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6709 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6710 & ddersc0(1),dersc(1))
6711 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6712 & ddersc0(3),dersc(3))
6714 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6716 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6717 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6718 & dersc0(2),esclocbi,dersc02)
6719 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6724 call splinthet(x(2),0.5d0*delta,ss,ssd)
6726 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6728 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6729 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6731 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6732 c write (iout,*) escloci
6734 call enesc(x,escloci,dersc,ddummy,.false.)
6737 escloc=escloc+escloci
6738 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6739 & 'escloc',i,escloci
6740 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6742 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6744 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6745 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6750 C---------------------------------------------------------------------------
6751 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6752 implicit real*8 (a-h,o-z)
6753 include 'DIMENSIONS'
6754 include 'COMMON.GEO'
6755 include 'COMMON.LOCAL'
6756 include 'COMMON.IOUNITS'
6757 common /sccalc/ time11,time12,time112,theti,it,nlobit
6758 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6759 double precision contr(maxlob,-1:1)
6761 c write (iout,*) 'it=',it,' nlobit=',nlobit
6765 if (mixed) ddersc(j)=0.0d0
6769 C Because of periodicity of the dependence of the SC energy in omega we have
6770 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6771 C To avoid underflows, first compute & store the exponents.
6779 z(k)=x(k)-censc(k,j,it)
6784 Axk=Axk+gaussc(l,k,j,it)*z(l)
6790 expfac=expfac+Ax(k,j,iii)*z(k)
6798 C As in the case of ebend, we want to avoid underflows in exponentiation and
6799 C subsequent NaNs and INFs in energy calculation.
6800 C Find the largest exponent
6804 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6808 cd print *,'it=',it,' emin=',emin
6810 C Compute the contribution to SC energy and derivatives
6815 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6816 if(adexp.ne.adexp) adexp=1.0
6819 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6821 cd print *,'j=',j,' expfac=',expfac
6822 escloc_i=escloc_i+expfac
6824 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6828 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6829 & +gaussc(k,2,j,it))*expfac
6836 dersc(1)=dersc(1)/cos(theti)**2
6837 ddersc(1)=ddersc(1)/cos(theti)**2
6840 escloci=-(dlog(escloc_i)-emin)
6842 dersc(j)=dersc(j)/escloc_i
6846 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6851 C------------------------------------------------------------------------------
6852 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6853 implicit real*8 (a-h,o-z)
6854 include 'DIMENSIONS'
6855 include 'COMMON.GEO'
6856 include 'COMMON.LOCAL'
6857 include 'COMMON.IOUNITS'
6858 common /sccalc/ time11,time12,time112,theti,it,nlobit
6859 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6860 double precision contr(maxlob)
6871 z(k)=x(k)-censc(k,j,it)
6877 Axk=Axk+gaussc(l,k,j,it)*z(l)
6883 expfac=expfac+Ax(k,j)*z(k)
6888 C As in the case of ebend, we want to avoid underflows in exponentiation and
6889 C subsequent NaNs and INFs in energy calculation.
6890 C Find the largest exponent
6893 if (emin.gt.contr(j)) emin=contr(j)
6897 C Compute the contribution to SC energy and derivatives
6901 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6902 escloc_i=escloc_i+expfac
6904 dersc(k)=dersc(k)+Ax(k,j)*expfac
6906 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6907 & +gaussc(1,2,j,it))*expfac
6911 dersc(1)=dersc(1)/cos(theti)**2
6912 dersc12=dersc12/cos(theti)**2
6913 escloci=-(dlog(escloc_i)-emin)
6915 dersc(j)=dersc(j)/escloc_i
6917 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6921 c----------------------------------------------------------------------------------
6922 subroutine esc(escloc)
6923 C Calculate the local energy of a side chain and its derivatives in the
6924 C corresponding virtual-bond valence angles THETA and the spherical angles
6925 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6926 C added by Urszula Kozlowska. 07/11/2007
6928 implicit real*8 (a-h,o-z)
6929 include 'DIMENSIONS'
6930 include 'COMMON.GEO'
6931 include 'COMMON.LOCAL'
6932 include 'COMMON.VAR'
6933 include 'COMMON.SCROT'
6934 include 'COMMON.INTERACT'
6935 include 'COMMON.DERIV'
6936 include 'COMMON.CHAIN'
6937 include 'COMMON.IOUNITS'
6938 include 'COMMON.NAMES'
6939 include 'COMMON.FFIELD'
6940 include 'COMMON.CONTROL'
6941 include 'COMMON.VECTORS'
6942 double precision x_prime(3),y_prime(3),z_prime(3)
6943 & , sumene,dsc_i,dp2_i,x(65),
6944 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6945 & de_dxx,de_dyy,de_dzz,de_dt
6946 double precision s1_t,s1_6_t,s2_t,s2_6_t
6948 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6949 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6950 & dt_dCi(3),dt_dCi1(3)
6951 common /sccalc/ time11,time12,time112,theti,it,nlobit
6954 do i=loc_start,loc_end
6955 if (itype(i).eq.ntyp1) cycle
6956 costtab(i+1) =dcos(theta(i+1))
6957 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6958 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6959 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6960 cosfac2=0.5d0/(1.0d0+costtab(i+1))
6961 cosfac=dsqrt(cosfac2)
6962 sinfac2=0.5d0/(1.0d0-costtab(i+1))
6963 sinfac=dsqrt(sinfac2)
6965 if (it.eq.10) goto 1
6967 C Compute the axes of tghe local cartesian coordinates system; store in
6968 c x_prime, y_prime and z_prime
6975 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6976 C & dc_norm(3,i+nres)
6978 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6979 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6982 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6985 c write (2,*) "x_prime",(x_prime(j),j=1,3)
6986 c write (2,*) "y_prime",(y_prime(j),j=1,3)
6987 c write (2,*) "z_prime",(z_prime(j),j=1,3)
6988 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6989 c & " xy",scalar(x_prime(1),y_prime(1)),
6990 c & " xz",scalar(x_prime(1),z_prime(1)),
6991 c & " yy",scalar(y_prime(1),y_prime(1)),
6992 c & " yz",scalar(y_prime(1),z_prime(1)),
6993 c & " zz",scalar(z_prime(1),z_prime(1))
6995 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6996 C to local coordinate system. Store in xx, yy, zz.
7002 xx = xx + x_prime(j)*dc_norm(j,i+nres)
7003 yy = yy + y_prime(j)*dc_norm(j,i+nres)
7004 zz = zz + z_prime(j)*dc_norm(j,i+nres)
7011 C Compute the energy of the ith side cbain
7013 c write (2,*) "xx",xx," yy",yy," zz",zz
7016 x(j) = sc_parmin(j,it)
7019 Cc diagnostics - remove later
7021 yy1 = dsin(alph(2))*dcos(omeg(2))
7022 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7023 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7024 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7026 C," --- ", xx_w,yy_w,zz_w
7029 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7030 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7032 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7033 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7035 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7036 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7037 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7038 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7039 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7041 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7042 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7043 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7044 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7045 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7047 dsc_i = 0.743d0+x(61)
7049 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7050 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7051 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7052 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7053 s1=(1+x(63))/(0.1d0 + dscp1)
7054 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7055 s2=(1+x(65))/(0.1d0 + dscp2)
7056 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7057 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7058 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7059 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7061 c & dscp1,dscp2,sumene
7062 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7063 escloc = escloc + sumene
7064 c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7069 C This section to check the numerical derivatives of the energy of ith side
7070 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7071 C #define DEBUG in the code to turn it on.
7073 write (2,*) "sumene =",sumene
7077 write (2,*) xx,yy,zz
7078 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7079 de_dxx_num=(sumenep-sumene)/aincr
7081 write (2,*) "xx+ sumene from enesc=",sumenep
7084 write (2,*) xx,yy,zz
7085 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7086 de_dyy_num=(sumenep-sumene)/aincr
7088 write (2,*) "yy+ sumene from enesc=",sumenep
7091 write (2,*) xx,yy,zz
7092 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7093 de_dzz_num=(sumenep-sumene)/aincr
7095 write (2,*) "zz+ sumene from enesc=",sumenep
7096 costsave=cost2tab(i+1)
7097 sintsave=sint2tab(i+1)
7098 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7099 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7100 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7101 de_dt_num=(sumenep-sumene)/aincr
7102 write (2,*) " t+ sumene from enesc=",sumenep
7103 cost2tab(i+1)=costsave
7104 sint2tab(i+1)=sintsave
7105 C End of diagnostics section.
7108 C Compute the gradient of esc
7110 c zz=zz*dsign(1.0,dfloat(itype(i)))
7111 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7112 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7113 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7114 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7115 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7116 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7117 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7118 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7119 pom1=(sumene3*sint2tab(i+1)+sumene1)
7120 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7121 pom2=(sumene4*cost2tab(i+1)+sumene2)
7122 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7123 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7124 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7125 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7127 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7128 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7129 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7131 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7132 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7133 & +(pom1+pom2)*pom_dx
7135 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7138 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7139 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7140 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7142 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7143 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7144 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7145 & +x(59)*zz**2 +x(60)*xx*zz
7146 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7147 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7148 & +(pom1-pom2)*pom_dy
7150 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7153 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7154 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7155 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7156 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7157 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7158 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7159 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7160 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7162 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7165 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7166 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7167 & +pom1*pom_dt1+pom2*pom_dt2
7169 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7174 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7175 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7176 cosfac2xx=cosfac2*xx
7177 sinfac2yy=sinfac2*yy
7179 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7181 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7183 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7184 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7185 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7186 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7187 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7188 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7189 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7190 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7191 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7192 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7196 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7197 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7198 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7199 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7202 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7203 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7204 dZZ_XYZ(k)=vbld_inv(i+nres)*
7205 & (z_prime(k)-zz*dC_norm(k,i+nres))
7207 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7208 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7212 dXX_Ctab(k,i)=dXX_Ci(k)
7213 dXX_C1tab(k,i)=dXX_Ci1(k)
7214 dYY_Ctab(k,i)=dYY_Ci(k)
7215 dYY_C1tab(k,i)=dYY_Ci1(k)
7216 dZZ_Ctab(k,i)=dZZ_Ci(k)
7217 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7218 dXX_XYZtab(k,i)=dXX_XYZ(k)
7219 dYY_XYZtab(k,i)=dYY_XYZ(k)
7220 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7224 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7225 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7226 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7227 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7228 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7230 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7231 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7232 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7233 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7234 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7235 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7236 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7237 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7239 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7240 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7242 C to check gradient call subroutine check_grad
7248 c------------------------------------------------------------------------------
7249 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7251 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7252 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7253 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7254 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7256 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7257 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7259 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7260 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7261 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7262 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7263 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7265 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7266 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7267 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7268 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7269 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7271 dsc_i = 0.743d0+x(61)
7273 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7274 & *(xx*cost2+yy*sint2))
7275 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7276 & *(xx*cost2-yy*sint2))
7277 s1=(1+x(63))/(0.1d0 + dscp1)
7278 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7279 s2=(1+x(65))/(0.1d0 + dscp2)
7280 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7281 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7282 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7287 c------------------------------------------------------------------------------
7288 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7290 C This procedure calculates two-body contact function g(rij) and its derivative:
7293 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7296 C where x=(rij-r0ij)/delta
7298 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7301 double precision rij,r0ij,eps0ij,fcont,fprimcont
7302 double precision x,x2,x4,delta
7306 if (x.lt.-1.0D0) then
7309 else if (x.le.1.0D0) then
7312 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7313 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7320 c------------------------------------------------------------------------------
7321 subroutine splinthet(theti,delta,ss,ssder)
7322 implicit real*8 (a-h,o-z)
7323 include 'DIMENSIONS'
7324 include 'COMMON.VAR'
7325 include 'COMMON.GEO'
7328 if (theti.gt.pipol) then
7329 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7331 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7336 c------------------------------------------------------------------------------
7337 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7339 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7340 double precision ksi,ksi2,ksi3,a1,a2,a3
7341 a1=fprim0*delta/(f1-f0)
7347 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7348 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7351 c------------------------------------------------------------------------------
7352 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7354 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7355 double precision ksi,ksi2,ksi3,a1,a2,a3
7360 a2=3*(f1x-f0x)-2*fprim0x*delta
7361 a3=fprim0x*delta-2*(f1x-f0x)
7362 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7365 C-----------------------------------------------------------------------------
7367 C-----------------------------------------------------------------------------
7368 subroutine etor(etors)
7369 implicit real*8 (a-h,o-z)
7370 include 'DIMENSIONS'
7371 include 'COMMON.VAR'
7372 include 'COMMON.GEO'
7373 include 'COMMON.LOCAL'
7374 include 'COMMON.TORSION'
7375 include 'COMMON.INTERACT'
7376 include 'COMMON.DERIV'
7377 include 'COMMON.CHAIN'
7378 include 'COMMON.NAMES'
7379 include 'COMMON.IOUNITS'
7380 include 'COMMON.FFIELD'
7381 include 'COMMON.TORCNSTR'
7382 include 'COMMON.CONTROL'
7384 C Set lprn=.true. for debugging
7388 do i=iphi_start,iphi_end
7390 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7391 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7392 itori=itortyp(itype(i-2))
7393 itori1=itortyp(itype(i-1))
7396 C Proline-Proline pair is a special case...
7397 if (itori.eq.3 .and. itori1.eq.3) then
7398 if (phii.gt.-dwapi3) then
7400 fac=1.0D0/(1.0D0-cosphi)
7401 etorsi=v1(1,3,3)*fac
7402 etorsi=etorsi+etorsi
7403 etors=etors+etorsi-v1(1,3,3)
7404 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7405 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7408 v1ij=v1(j+1,itori,itori1)
7409 v2ij=v2(j+1,itori,itori1)
7412 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7413 if (energy_dec) etors_ii=etors_ii+
7414 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7415 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7419 v1ij=v1(j,itori,itori1)
7420 v2ij=v2(j,itori,itori1)
7423 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7424 if (energy_dec) etors_ii=etors_ii+
7425 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7426 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7429 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7432 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7433 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7434 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7435 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7436 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7440 c------------------------------------------------------------------------------
7441 subroutine etor_d(etors_d)
7445 c----------------------------------------------------------------------------
7447 subroutine etor(etors)
7448 implicit real*8 (a-h,o-z)
7449 include 'DIMENSIONS'
7450 include 'COMMON.VAR'
7451 include 'COMMON.GEO'
7452 include 'COMMON.LOCAL'
7453 include 'COMMON.TORSION'
7454 include 'COMMON.INTERACT'
7455 include 'COMMON.DERIV'
7456 include 'COMMON.CHAIN'
7457 include 'COMMON.NAMES'
7458 include 'COMMON.IOUNITS'
7459 include 'COMMON.FFIELD'
7460 include 'COMMON.TORCNSTR'
7461 include 'COMMON.CONTROL'
7463 C Set lprn=.true. for debugging
7467 do i=iphi_start,iphi_end
7468 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7469 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7470 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7471 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7472 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7473 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7474 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7475 C For introducing the NH3+ and COO- group please check the etor_d for reference
7478 if (iabs(itype(i)).eq.20) then
7483 itori=itortyp(itype(i-2))
7484 itori1=itortyp(itype(i-1))
7487 C Regular cosine and sine terms
7488 do j=1,nterm(itori,itori1,iblock)
7489 v1ij=v1(j,itori,itori1,iblock)
7490 v2ij=v2(j,itori,itori1,iblock)
7493 etors=etors+v1ij*cosphi+v2ij*sinphi
7494 if (energy_dec) etors_ii=etors_ii+
7495 & v1ij*cosphi+v2ij*sinphi
7496 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7500 C E = SUM ----------------------------------- - v1
7501 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7503 cosphi=dcos(0.5d0*phii)
7504 sinphi=dsin(0.5d0*phii)
7505 do j=1,nlor(itori,itori1,iblock)
7506 vl1ij=vlor1(j,itori,itori1)
7507 vl2ij=vlor2(j,itori,itori1)
7508 vl3ij=vlor3(j,itori,itori1)
7509 pom=vl2ij*cosphi+vl3ij*sinphi
7510 pom1=1.0d0/(pom*pom+1.0d0)
7511 etors=etors+vl1ij*pom1
7512 if (energy_dec) etors_ii=etors_ii+
7515 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7517 C Subtract the constant term
7518 etors=etors-v0(itori,itori1,iblock)
7519 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7520 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7522 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7523 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7524 & (v1(j,itori,itori1,iblock),j=1,6),
7525 & (v2(j,itori,itori1,iblock),j=1,6)
7526 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7527 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7531 c----------------------------------------------------------------------------
7532 subroutine etor_d(etors_d)
7533 C 6/23/01 Compute double torsional energy
7534 implicit real*8 (a-h,o-z)
7535 include 'DIMENSIONS'
7536 include 'COMMON.VAR'
7537 include 'COMMON.GEO'
7538 include 'COMMON.LOCAL'
7539 include 'COMMON.TORSION'
7540 include 'COMMON.INTERACT'
7541 include 'COMMON.DERIV'
7542 include 'COMMON.CHAIN'
7543 include 'COMMON.NAMES'
7544 include 'COMMON.IOUNITS'
7545 include 'COMMON.FFIELD'
7546 include 'COMMON.TORCNSTR'
7548 C Set lprn=.true. for debugging
7552 c write(iout,*) "a tu??"
7553 do i=iphid_start,iphid_end
7554 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7555 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7556 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7557 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7558 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7559 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7560 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7561 & (itype(i+1).eq.ntyp1)) cycle
7562 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7563 itori=itortyp(itype(i-2))
7564 itori1=itortyp(itype(i-1))
7565 itori2=itortyp(itype(i))
7571 if (iabs(itype(i+1)).eq.20) iblock=2
7572 C Iblock=2 Proline type
7573 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7574 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7575 C if (itype(i+1).eq.ntyp1) iblock=3
7576 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7577 C IS or IS NOT need for this
7578 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7579 C is (itype(i-3).eq.ntyp1) ntblock=2
7580 C ntblock is N-terminal blocking group
7582 C Regular cosine and sine terms
7583 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7584 C Example of changes for NH3+ blocking group
7585 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7586 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7587 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7588 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7589 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7590 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7591 cosphi1=dcos(j*phii)
7592 sinphi1=dsin(j*phii)
7593 cosphi2=dcos(j*phii1)
7594 sinphi2=dsin(j*phii1)
7595 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7596 & v2cij*cosphi2+v2sij*sinphi2
7597 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7598 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7600 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7602 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7603 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7604 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7605 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7606 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7607 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7608 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7609 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7610 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7611 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7612 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7613 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7614 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7615 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7618 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7619 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7624 C----------------------------------------------------------------------------------
7625 C The rigorous attempt to derive energy function
7626 subroutine etor_kcc(etors)
7627 implicit real*8 (a-h,o-z)
7628 include 'DIMENSIONS'
7629 include 'COMMON.VAR'
7630 include 'COMMON.GEO'
7631 include 'COMMON.LOCAL'
7632 include 'COMMON.TORSION'
7633 include 'COMMON.INTERACT'
7634 include 'COMMON.DERIV'
7635 include 'COMMON.CHAIN'
7636 include 'COMMON.NAMES'
7637 include 'COMMON.IOUNITS'
7638 include 'COMMON.FFIELD'
7639 include 'COMMON.TORCNSTR'
7640 include 'COMMON.CONTROL'
7641 double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7643 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7644 C Set lprn=.true. for debugging
7647 C print *,"wchodze kcc"
7648 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7650 do i=iphi_start,iphi_end
7651 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7652 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7653 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7654 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7655 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7656 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7657 itori=itortyp(itype(i-2))
7658 itori1=itortyp(itype(i-1))
7663 C to avoid multiple devision by 2
7664 c theti22=0.5d0*theta(i)
7665 C theta 12 is the theta_1 /2
7666 C theta 22 is theta_2 /2
7667 c theti12=0.5d0*theta(i-1)
7668 C and appropriate sinus function
7669 sinthet1=dsin(theta(i-1))
7670 sinthet2=dsin(theta(i))
7671 costhet1=dcos(theta(i-1))
7672 costhet2=dcos(theta(i))
7673 C to speed up lets store its mutliplication
7674 sint1t2=sinthet2*sinthet1
7676 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7677 C +d_n*sin(n*gamma)) *
7678 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7679 C we have two sum 1) Non-Chebyshev which is with n and gamma
7680 nval=nterm_kcc_Tb(itori,itori1)
7686 c1(j)=c1(j-1)*costhet1
7687 c2(j)=c2(j-1)*costhet2
7690 do j=1,nterm_kcc(itori,itori1)
7694 sint1t2n=sint1t2n*sint1t2
7700 sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7701 gradvalct1=gradvalct1+
7702 & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7703 gradvalct2=gradvalct2+
7704 & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7707 gradvalct1=-gradvalct1*sinthet1
7708 gradvalct2=-gradvalct2*sinthet2
7714 sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7715 gradvalst1=gradvalst1+
7716 & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7717 gradvalst2=gradvalst2+
7718 & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7721 gradvalst1=-gradvalst1*sinthet1
7722 gradvalst2=-gradvalst2*sinthet2
7723 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7724 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7725 C glocig is the gradient local i site in gamma
7726 glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7727 C now gradient over theta_1
7728 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7729 & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7730 glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7731 & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7734 C derivative over gamma
7735 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7736 C derivative over theta1
7737 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7738 C now derivative over theta2
7739 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7741 write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7742 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7743 write (iout,*) "c1",(c1(k),k=0,nval),
7744 & " c2",(c2(k),k=0,nval)
7749 c---------------------------------------------------------------------------------------------
7750 subroutine etor_constr(edihcnstr)
7751 implicit real*8 (a-h,o-z)
7752 include 'DIMENSIONS'
7753 include 'COMMON.VAR'
7754 include 'COMMON.GEO'
7755 include 'COMMON.LOCAL'
7756 include 'COMMON.TORSION'
7757 include 'COMMON.INTERACT'
7758 include 'COMMON.DERIV'
7759 include 'COMMON.CHAIN'
7760 include 'COMMON.NAMES'
7761 include 'COMMON.IOUNITS'
7762 include 'COMMON.FFIELD'
7763 include 'COMMON.TORCNSTR'
7764 include 'COMMON.BOUNDS'
7765 include 'COMMON.CONTROL'
7766 ! 6/20/98 - dihedral angle constraints
7768 c do i=1,ndih_constr
7769 if (raw_psipred) then
7770 do i=idihconstr_start,idihconstr_end
7771 itori=idih_constr(i)
7773 gaudih_i=vpsipred(1,i)
7777 cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7778 dexpcos_i=dexp(-cos_i*cos_i)
7779 gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7780 gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7781 & *cos_i*dexpcos_i/s**2
7783 edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7784 gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7786 & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7787 & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7788 & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7789 & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7790 & -wdihc*dlog(gaudih_i)
7794 do i=idihconstr_start,idihconstr_end
7795 itori=idih_constr(i)
7797 difi=pinorm(phii-phi0(i))
7798 if (difi.gt.drange(i)) then
7800 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7801 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7802 else if (difi.lt.-drange(i)) then
7804 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7805 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7815 c----------------------------------------------------------------------------
7816 C The rigorous attempt to derive energy function
7817 subroutine ebend_kcc(etheta)
7819 implicit real*8 (a-h,o-z)
7820 include 'DIMENSIONS'
7821 include 'COMMON.VAR'
7822 include 'COMMON.GEO'
7823 include 'COMMON.LOCAL'
7824 include 'COMMON.TORSION'
7825 include 'COMMON.INTERACT'
7826 include 'COMMON.DERIV'
7827 include 'COMMON.CHAIN'
7828 include 'COMMON.NAMES'
7829 include 'COMMON.IOUNITS'
7830 include 'COMMON.FFIELD'
7831 include 'COMMON.TORCNSTR'
7832 include 'COMMON.CONTROL'
7834 double precision thybt1(maxang_kcc)
7835 C Set lprn=.true. for debugging
7838 C print *,"wchodze kcc"
7839 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7841 do i=ithet_start,ithet_end
7842 c print *,i,itype(i-1),itype(i),itype(i-2)
7843 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7844 & .or.itype(i).eq.ntyp1) cycle
7845 iti=iabs(itortyp(itype(i-1)))
7846 sinthet=dsin(theta(i))
7847 costhet=dcos(theta(i))
7848 do j=1,nbend_kcc_Tb(iti)
7849 thybt1(j)=v1bend_chyb(j,iti)
7851 sumth1thyb=v1bend_chyb(0,iti)+
7852 & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7853 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7855 ihelp=nbend_kcc_Tb(iti)-1
7856 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7857 etheta=etheta+sumth1thyb
7858 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7859 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7863 c-------------------------------------------------------------------------------------
7864 subroutine etheta_constr(ethetacnstr)
7866 implicit real*8 (a-h,o-z)
7867 include 'DIMENSIONS'
7868 include 'COMMON.VAR'
7869 include 'COMMON.GEO'
7870 include 'COMMON.LOCAL'
7871 include 'COMMON.TORSION'
7872 include 'COMMON.INTERACT'
7873 include 'COMMON.DERIV'
7874 include 'COMMON.CHAIN'
7875 include 'COMMON.NAMES'
7876 include 'COMMON.IOUNITS'
7877 include 'COMMON.FFIELD'
7878 include 'COMMON.TORCNSTR'
7879 include 'COMMON.CONTROL'
7881 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
7882 do i=ithetaconstr_start,ithetaconstr_end
7883 itheta=itheta_constr(i)
7884 thetiii=theta(itheta)
7885 difi=pinorm(thetiii-theta_constr0(i))
7886 if (difi.gt.theta_drange(i)) then
7887 difi=difi-theta_drange(i)
7888 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7889 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7890 & +for_thet_constr(i)*difi**3
7891 else if (difi.lt.-drange(i)) then
7893 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7894 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7895 & +for_thet_constr(i)*difi**3
7899 if (energy_dec) then
7900 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7901 & i,itheta,rad2deg*thetiii,
7902 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
7903 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7904 & gloc(itheta+nphi-2,icg)
7909 c------------------------------------------------------------------------------
7910 subroutine eback_sc_corr(esccor)
7911 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7912 c conformational states; temporarily implemented as differences
7913 c between UNRES torsional potentials (dependent on three types of
7914 c residues) and the torsional potentials dependent on all 20 types
7915 c of residues computed from AM1 energy surfaces of terminally-blocked
7916 c amino-acid residues.
7917 implicit real*8 (a-h,o-z)
7918 include 'DIMENSIONS'
7919 include 'COMMON.VAR'
7920 include 'COMMON.GEO'
7921 include 'COMMON.LOCAL'
7922 include 'COMMON.TORSION'
7923 include 'COMMON.SCCOR'
7924 include 'COMMON.INTERACT'
7925 include 'COMMON.DERIV'
7926 include 'COMMON.CHAIN'
7927 include 'COMMON.NAMES'
7928 include 'COMMON.IOUNITS'
7929 include 'COMMON.FFIELD'
7930 include 'COMMON.CONTROL'
7932 C Set lprn=.true. for debugging
7935 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7937 do i=itau_start,itau_end
7938 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7940 isccori=isccortyp(itype(i-2))
7941 isccori1=isccortyp(itype(i-1))
7942 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7944 do intertyp=1,3 !intertyp
7945 cc Added 09 May 2012 (Adasko)
7946 cc Intertyp means interaction type of backbone mainchain correlation:
7947 c 1 = SC...Ca...Ca...Ca
7948 c 2 = Ca...Ca...Ca...SC
7949 c 3 = SC...Ca...Ca...SCi
7951 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7952 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7953 & (itype(i-1).eq.ntyp1)))
7954 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7955 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7956 & .or.(itype(i).eq.ntyp1)))
7957 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7958 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7959 & (itype(i-3).eq.ntyp1)))) cycle
7960 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7961 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7963 do j=1,nterm_sccor(isccori,isccori1)
7964 v1ij=v1sccor(j,intertyp,isccori,isccori1)
7965 v2ij=v2sccor(j,intertyp,isccori,isccori1)
7966 cosphi=dcos(j*tauangle(intertyp,i))
7967 sinphi=dsin(j*tauangle(intertyp,i))
7968 esccor=esccor+v1ij*cosphi+v2ij*sinphi
7969 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7971 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7972 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7974 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7975 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7976 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7977 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7978 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7984 c----------------------------------------------------------------------------
7985 subroutine multibody(ecorr)
7986 C This subroutine calculates multi-body contributions to energy following
7987 C the idea of Skolnick et al. If side chains I and J make a contact and
7988 C at the same time side chains I+1 and J+1 make a contact, an extra
7989 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7990 implicit real*8 (a-h,o-z)
7991 include 'DIMENSIONS'
7992 include 'COMMON.IOUNITS'
7993 include 'COMMON.DERIV'
7994 include 'COMMON.INTERACT'
7995 include 'COMMON.CONTACTS'
7996 double precision gx(3),gx1(3)
7999 C Set lprn=.true. for debugging
8003 write (iout,'(a)') 'Contact function values:'
8005 write (iout,'(i2,20(1x,i2,f10.5))')
8006 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8021 num_conti=num_cont(i)
8022 num_conti1=num_cont(i1)
8027 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8028 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8029 cd & ' ishift=',ishift
8030 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8031 C The system gains extra energy.
8032 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8033 endif ! j1==j+-ishift
8042 c------------------------------------------------------------------------------
8043 double precision function esccorr(i,j,k,l,jj,kk)
8044 implicit real*8 (a-h,o-z)
8045 include 'DIMENSIONS'
8046 include 'COMMON.IOUNITS'
8047 include 'COMMON.DERIV'
8048 include 'COMMON.INTERACT'
8049 include 'COMMON.CONTACTS'
8050 include 'COMMON.SHIELD'
8051 double precision gx(3),gx1(3)
8056 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8057 C Calculate the multi-body contribution to energy.
8058 C Calculate multi-body contributions to the gradient.
8059 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8060 cd & k,l,(gacont(m,kk,k),m=1,3)
8062 gx(m) =ekl*gacont(m,jj,i)
8063 gx1(m)=eij*gacont(m,kk,k)
8064 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8065 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8066 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8067 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8071 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8076 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8082 c------------------------------------------------------------------------------
8083 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8084 C This subroutine calculates multi-body contributions to hydrogen-bonding
8085 implicit real*8 (a-h,o-z)
8086 include 'DIMENSIONS'
8087 include 'COMMON.IOUNITS'
8090 parameter (max_cont=maxconts)
8091 parameter (max_dim=26)
8092 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8093 double precision zapas(max_dim,maxconts,max_fg_procs),
8094 & zapas_recv(max_dim,maxconts,max_fg_procs)
8095 common /przechowalnia/ zapas
8096 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8097 & status_array(MPI_STATUS_SIZE,maxconts*2)
8099 include 'COMMON.SETUP'
8100 include 'COMMON.FFIELD'
8101 include 'COMMON.DERIV'
8102 include 'COMMON.INTERACT'
8103 include 'COMMON.CONTACTS'
8104 include 'COMMON.CONTROL'
8105 include 'COMMON.LOCAL'
8106 double precision gx(3),gx1(3),time00
8109 C Set lprn=.true. for debugging
8114 if (nfgtasks.le.1) goto 30
8116 write (iout,'(a)') 'Contact function values before RECEIVE:'
8118 write (iout,'(2i3,50(1x,i2,f5.2))')
8119 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8120 & j=1,num_cont_hb(i))
8124 do i=1,ntask_cont_from
8127 do i=1,ntask_cont_to
8130 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8132 C Make the list of contacts to send to send to other procesors
8133 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8135 do i=iturn3_start,iturn3_end
8136 c write (iout,*) "make contact list turn3",i," num_cont",
8138 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8140 do i=iturn4_start,iturn4_end
8141 c write (iout,*) "make contact list turn4",i," num_cont",
8143 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8147 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8149 do j=1,num_cont_hb(i)
8152 iproc=iint_sent_local(k,jjc,ii)
8153 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8154 if (iproc.gt.0) then
8155 ncont_sent(iproc)=ncont_sent(iproc)+1
8156 nn=ncont_sent(iproc)
8158 zapas(2,nn,iproc)=jjc
8159 zapas(3,nn,iproc)=facont_hb(j,i)
8160 zapas(4,nn,iproc)=ees0p(j,i)
8161 zapas(5,nn,iproc)=ees0m(j,i)
8162 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8163 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8164 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8165 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8166 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8167 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8168 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8169 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8170 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8171 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8172 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8173 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8174 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8175 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8176 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8177 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8178 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8179 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8180 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8181 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8182 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8189 & "Numbers of contacts to be sent to other processors",
8190 & (ncont_sent(i),i=1,ntask_cont_to)
8191 write (iout,*) "Contacts sent"
8192 do ii=1,ntask_cont_to
8194 iproc=itask_cont_to(ii)
8195 write (iout,*) nn," contacts to processor",iproc,
8196 & " of CONT_TO_COMM group"
8198 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8206 CorrelID1=nfgtasks+fg_rank+1
8208 C Receive the numbers of needed contacts from other processors
8209 do ii=1,ntask_cont_from
8210 iproc=itask_cont_from(ii)
8212 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8213 & FG_COMM,req(ireq),IERR)
8215 c write (iout,*) "IRECV ended"
8217 C Send the number of contacts needed by other processors
8218 do ii=1,ntask_cont_to
8219 iproc=itask_cont_to(ii)
8221 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8222 & FG_COMM,req(ireq),IERR)
8224 c write (iout,*) "ISEND ended"
8225 c write (iout,*) "number of requests (nn)",ireq
8228 & call MPI_Waitall(ireq,req,status_array,ierr)
8230 c & "Numbers of contacts to be received from other processors",
8231 c & (ncont_recv(i),i=1,ntask_cont_from)
8235 do ii=1,ntask_cont_from
8236 iproc=itask_cont_from(ii)
8238 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8239 c & " of CONT_TO_COMM group"
8243 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8244 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8245 c write (iout,*) "ireq,req",ireq,req(ireq)
8248 C Send the contacts to processors that need them
8249 do ii=1,ntask_cont_to
8250 iproc=itask_cont_to(ii)
8252 c write (iout,*) nn," contacts to processor",iproc,
8253 c & " of CONT_TO_COMM group"
8256 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8257 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8258 c write (iout,*) "ireq,req",ireq,req(ireq)
8260 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8264 c write (iout,*) "number of requests (contacts)",ireq
8265 c write (iout,*) "req",(req(i),i=1,4)
8268 & call MPI_Waitall(ireq,req,status_array,ierr)
8269 do iii=1,ntask_cont_from
8270 iproc=itask_cont_from(iii)
8273 write (iout,*) "Received",nn," contacts from processor",iproc,
8274 & " of CONT_FROM_COMM group"
8277 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8282 ii=zapas_recv(1,i,iii)
8283 c Flag the received contacts to prevent double-counting
8284 jj=-zapas_recv(2,i,iii)
8285 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8287 nnn=num_cont_hb(ii)+1
8290 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8291 ees0p(nnn,ii)=zapas_recv(4,i,iii)
8292 ees0m(nnn,ii)=zapas_recv(5,i,iii)
8293 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8294 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8295 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8296 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8297 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8298 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8299 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8300 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8301 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8302 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8303 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8304 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8305 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8306 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8307 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8308 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8309 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8310 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8311 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8312 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8313 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8317 write (iout,'(a)') 'Contact function values after receive:'
8319 write (iout,'(2i3,50(1x,i3,f5.2))')
8320 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8321 & j=1,num_cont_hb(i))
8328 write (iout,'(a)') 'Contact function values:'
8330 write (iout,'(2i3,50(1x,i3,f5.2))')
8331 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8332 & j=1,num_cont_hb(i))
8337 C Remove the loop below after debugging !!!
8344 C Calculate the local-electrostatic correlation terms
8345 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8347 num_conti=num_cont_hb(i)
8348 num_conti1=num_cont_hb(i+1)
8355 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8356 c & ' jj=',jj,' kk=',kk
8358 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8359 & .or. j.lt.0 .and. j1.gt.0) .and.
8360 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8361 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8362 C The system gains extra energy.
8363 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8364 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8365 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8367 else if (j1.eq.j) then
8368 C Contacts I-J and I-(J+1) occur simultaneously.
8369 C The system loses extra energy.
8370 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8375 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8376 c & ' jj=',jj,' kk=',kk
8378 C Contacts I-J and (I+1)-J occur simultaneously.
8379 C The system loses extra energy.
8380 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8387 c------------------------------------------------------------------------------
8388 subroutine add_hb_contact(ii,jj,itask)
8389 implicit real*8 (a-h,o-z)
8390 include "DIMENSIONS"
8391 include "COMMON.IOUNITS"
8394 parameter (max_cont=maxconts)
8395 parameter (max_dim=26)
8396 include "COMMON.CONTACTS"
8397 double precision zapas(max_dim,maxconts,max_fg_procs),
8398 & zapas_recv(max_dim,maxconts,max_fg_procs)
8399 common /przechowalnia/ zapas
8400 integer i,j,ii,jj,iproc,itask(4),nn
8401 c write (iout,*) "itask",itask
8404 if (iproc.gt.0) then
8405 do j=1,num_cont_hb(ii)
8407 c write (iout,*) "i",ii," j",jj," jjc",jjc
8409 ncont_sent(iproc)=ncont_sent(iproc)+1
8410 nn=ncont_sent(iproc)
8411 zapas(1,nn,iproc)=ii
8412 zapas(2,nn,iproc)=jjc
8413 zapas(3,nn,iproc)=facont_hb(j,ii)
8414 zapas(4,nn,iproc)=ees0p(j,ii)
8415 zapas(5,nn,iproc)=ees0m(j,ii)
8416 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8417 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8418 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8419 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8420 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8421 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8422 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8423 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8424 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8425 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8426 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8427 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8428 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8429 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8430 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8431 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8432 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8433 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8434 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8435 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8436 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8444 c------------------------------------------------------------------------------
8445 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8447 C This subroutine calculates multi-body contributions to hydrogen-bonding
8448 implicit real*8 (a-h,o-z)
8449 include 'DIMENSIONS'
8450 include 'COMMON.IOUNITS'
8453 parameter (max_cont=maxconts)
8454 parameter (max_dim=70)
8455 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8456 double precision zapas(max_dim,maxconts,max_fg_procs),
8457 & zapas_recv(max_dim,maxconts,max_fg_procs)
8458 common /przechowalnia/ zapas
8459 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8460 & status_array(MPI_STATUS_SIZE,maxconts*2)
8462 include 'COMMON.SETUP'
8463 include 'COMMON.FFIELD'
8464 include 'COMMON.DERIV'
8465 include 'COMMON.LOCAL'
8466 include 'COMMON.INTERACT'
8467 include 'COMMON.CONTACTS'
8468 include 'COMMON.CHAIN'
8469 include 'COMMON.CONTROL'
8470 include 'COMMON.SHIELD'
8471 double precision gx(3),gx1(3)
8472 integer num_cont_hb_old(maxres)
8474 double precision eello4,eello5,eelo6,eello_turn6
8475 external eello4,eello5,eello6,eello_turn6
8476 C Set lprn=.true. for debugging
8481 num_cont_hb_old(i)=num_cont_hb(i)
8485 if (nfgtasks.le.1) goto 30
8487 write (iout,'(a)') 'Contact function values before RECEIVE:'
8489 write (iout,'(2i3,50(1x,i2,f5.2))')
8490 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8491 & j=1,num_cont_hb(i))
8494 do i=1,ntask_cont_from
8497 do i=1,ntask_cont_to
8500 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8502 C Make the list of contacts to send to send to other procesors
8503 do i=iturn3_start,iturn3_end
8504 c write (iout,*) "make contact list turn3",i," num_cont",
8506 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8508 do i=iturn4_start,iturn4_end
8509 c write (iout,*) "make contact list turn4",i," num_cont",
8511 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8515 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8517 do j=1,num_cont_hb(i)
8520 iproc=iint_sent_local(k,jjc,ii)
8521 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8522 if (iproc.ne.0) then
8523 ncont_sent(iproc)=ncont_sent(iproc)+1
8524 nn=ncont_sent(iproc)
8526 zapas(2,nn,iproc)=jjc
8527 zapas(3,nn,iproc)=d_cont(j,i)
8531 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8536 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8544 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8555 & "Numbers of contacts to be sent to other processors",
8556 & (ncont_sent(i),i=1,ntask_cont_to)
8557 write (iout,*) "Contacts sent"
8558 do ii=1,ntask_cont_to
8560 iproc=itask_cont_to(ii)
8561 write (iout,*) nn," contacts to processor",iproc,
8562 & " of CONT_TO_COMM group"
8564 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8572 CorrelID1=nfgtasks+fg_rank+1
8574 C Receive the numbers of needed contacts from other processors
8575 do ii=1,ntask_cont_from
8576 iproc=itask_cont_from(ii)
8578 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8579 & FG_COMM,req(ireq),IERR)
8581 c write (iout,*) "IRECV ended"
8583 C Send the number of contacts needed by other processors
8584 do ii=1,ntask_cont_to
8585 iproc=itask_cont_to(ii)
8587 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8588 & FG_COMM,req(ireq),IERR)
8590 c write (iout,*) "ISEND ended"
8591 c write (iout,*) "number of requests (nn)",ireq
8594 & call MPI_Waitall(ireq,req,status_array,ierr)
8596 c & "Numbers of contacts to be received from other processors",
8597 c & (ncont_recv(i),i=1,ntask_cont_from)
8601 do ii=1,ntask_cont_from
8602 iproc=itask_cont_from(ii)
8604 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8605 c & " of CONT_TO_COMM group"
8609 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8610 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8611 c write (iout,*) "ireq,req",ireq,req(ireq)
8614 C Send the contacts to processors that need them
8615 do ii=1,ntask_cont_to
8616 iproc=itask_cont_to(ii)
8618 c write (iout,*) nn," contacts to processor",iproc,
8619 c & " of CONT_TO_COMM group"
8622 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8623 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8624 c write (iout,*) "ireq,req",ireq,req(ireq)
8626 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8630 c write (iout,*) "number of requests (contacts)",ireq
8631 c write (iout,*) "req",(req(i),i=1,4)
8634 & call MPI_Waitall(ireq,req,status_array,ierr)
8635 do iii=1,ntask_cont_from
8636 iproc=itask_cont_from(iii)
8639 write (iout,*) "Received",nn," contacts from processor",iproc,
8640 & " of CONT_FROM_COMM group"
8643 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8648 ii=zapas_recv(1,i,iii)
8649 c Flag the received contacts to prevent double-counting
8650 jj=-zapas_recv(2,i,iii)
8651 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8653 nnn=num_cont_hb(ii)+1
8656 d_cont(nnn,ii)=zapas_recv(3,i,iii)
8660 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8665 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8673 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8681 write (iout,'(a)') 'Contact function values after receive:'
8683 write (iout,'(2i3,50(1x,i3,5f6.3))')
8684 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8685 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8692 write (iout,'(a)') 'Contact function values:'
8694 write (iout,'(2i3,50(1x,i2,5f6.3))')
8695 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8696 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8702 C Remove the loop below after debugging !!!
8709 C Calculate the dipole-dipole interaction energies
8710 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8711 do i=iatel_s,iatel_e+1
8712 num_conti=num_cont_hb(i)
8721 C Calculate the local-electrostatic correlation terms
8722 c write (iout,*) "gradcorr5 in eello5 before loop"
8724 c write (iout,'(i5,3f10.5)')
8725 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8727 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8728 c write (iout,*) "corr loop i",i
8730 num_conti=num_cont_hb(i)
8731 num_conti1=num_cont_hb(i+1)
8738 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8739 c & ' jj=',jj,' kk=',kk
8740 c if (j1.eq.j+1 .or. j1.eq.j-1) then
8741 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8742 & .or. j.lt.0 .and. j1.gt.0) .and.
8743 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8744 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8745 C The system gains extra energy.
8747 sqd1=dsqrt(d_cont(jj,i))
8748 sqd2=dsqrt(d_cont(kk,i1))
8749 sred_geom = sqd1*sqd2
8750 IF (sred_geom.lt.cutoff_corr) THEN
8751 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8753 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8754 cd & ' jj=',jj,' kk=',kk
8755 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8756 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8758 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8759 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8762 cd write (iout,*) 'sred_geom=',sred_geom,
8763 cd & ' ekont=',ekont,' fprim=',fprimcont,
8764 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8765 cd write (iout,*) "g_contij",g_contij
8766 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8767 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8768 call calc_eello(i,jp,i+1,jp1,jj,kk)
8769 if (wcorr4.gt.0.0d0)
8770 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8771 CC & *fac_shield(i)**2*fac_shield(j)**2
8772 if (energy_dec.and.wcorr4.gt.0.0d0)
8773 1 write (iout,'(a6,4i5,0pf7.3)')
8774 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8775 c write (iout,*) "gradcorr5 before eello5"
8777 c write (iout,'(i5,3f10.5)')
8778 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8780 if (wcorr5.gt.0.0d0)
8781 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8782 c write (iout,*) "gradcorr5 after eello5"
8784 c write (iout,'(i5,3f10.5)')
8785 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8787 if (energy_dec.and.wcorr5.gt.0.0d0)
8788 1 write (iout,'(a6,4i5,0pf7.3)')
8789 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8790 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8791 cd write(2,*)'ijkl',i,jp,i+1,jp1
8792 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8793 & .or. wturn6.eq.0.0d0))then
8794 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8795 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8796 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8797 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8798 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8799 cd & 'ecorr6=',ecorr6
8800 cd write (iout,'(4e15.5)') sred_geom,
8801 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8802 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8803 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
8804 else if (wturn6.gt.0.0d0
8805 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8806 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8807 eturn6=eturn6+eello_turn6(i,jj,kk)
8808 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8809 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8810 cd write (2,*) 'multibody_eello:eturn6',eturn6
8819 num_cont_hb(i)=num_cont_hb_old(i)
8821 c write (iout,*) "gradcorr5 in eello5"
8823 c write (iout,'(i5,3f10.5)')
8824 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8828 c------------------------------------------------------------------------------
8829 subroutine add_hb_contact_eello(ii,jj,itask)
8830 implicit real*8 (a-h,o-z)
8831 include "DIMENSIONS"
8832 include "COMMON.IOUNITS"
8835 parameter (max_cont=maxconts)
8836 parameter (max_dim=70)
8837 include "COMMON.CONTACTS"
8838 double precision zapas(max_dim,maxconts,max_fg_procs),
8839 & zapas_recv(max_dim,maxconts,max_fg_procs)
8840 common /przechowalnia/ zapas
8841 integer i,j,ii,jj,iproc,itask(4),nn
8842 c write (iout,*) "itask",itask
8845 if (iproc.gt.0) then
8846 do j=1,num_cont_hb(ii)
8848 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8850 ncont_sent(iproc)=ncont_sent(iproc)+1
8851 nn=ncont_sent(iproc)
8852 zapas(1,nn,iproc)=ii
8853 zapas(2,nn,iproc)=jjc
8854 zapas(3,nn,iproc)=d_cont(j,ii)
8858 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8863 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8871 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8883 c------------------------------------------------------------------------------
8884 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8885 implicit real*8 (a-h,o-z)
8886 include 'DIMENSIONS'
8887 include 'COMMON.IOUNITS'
8888 include 'COMMON.DERIV'
8889 include 'COMMON.INTERACT'
8890 include 'COMMON.CONTACTS'
8891 include 'COMMON.SHIELD'
8892 include 'COMMON.CONTROL'
8893 double precision gx(3),gx1(3)
8896 C print *,"wchodze",fac_shield(i),shield_mode
8904 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8906 C & fac_shield(i)**2*fac_shield(j)**2
8907 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8908 C Following 4 lines for diagnostics.
8913 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8914 c & 'Contacts ',i,j,
8915 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8916 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8918 C Calculate the multi-body contribution to energy.
8919 C ecorr=ecorr+ekont*ees
8920 C Calculate multi-body contributions to the gradient.
8921 coeffpees0pij=coeffp*ees0pij
8922 coeffmees0mij=coeffm*ees0mij
8923 coeffpees0pkl=coeffp*ees0pkl
8924 coeffmees0mkl=coeffm*ees0mkl
8926 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8927 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8928 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8929 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
8930 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8931 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8932 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
8933 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8934 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8935 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8936 & coeffmees0mij*gacontm_hb1(ll,kk,k))
8937 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8938 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8939 & coeffmees0mij*gacontm_hb2(ll,kk,k))
8940 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8941 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8942 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
8943 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8944 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8945 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8946 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8947 & coeffmees0mij*gacontm_hb3(ll,kk,k))
8948 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8949 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8950 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8955 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
8956 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
8957 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8958 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8963 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
8964 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
8965 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8966 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8969 c write (iout,*) "ehbcorr",ekont*ees
8970 C print *,ekont,ees,i,k
8972 C now gradient over shielding
8974 if (shield_mode.gt.0) then
8977 C print *,i,j,fac_shield(i),fac_shield(j),
8978 C &fac_shield(k),fac_shield(l)
8979 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8980 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8981 do ilist=1,ishield_list(i)
8982 iresshield=shield_list(ilist,i)
8984 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8986 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8988 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8989 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8993 do ilist=1,ishield_list(j)
8994 iresshield=shield_list(ilist,j)
8996 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8998 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9000 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9001 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9006 do ilist=1,ishield_list(k)
9007 iresshield=shield_list(ilist,k)
9009 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9011 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9013 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9014 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9018 do ilist=1,ishield_list(l)
9019 iresshield=shield_list(ilist,l)
9021 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9023 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9025 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9026 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9030 C print *,gshieldx(m,iresshield)
9032 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9033 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9034 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9035 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9036 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9037 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9038 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9039 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9041 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9042 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9043 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9044 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9045 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9046 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9047 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9048 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9056 C---------------------------------------------------------------------------
9057 subroutine dipole(i,j,jj)
9058 implicit real*8 (a-h,o-z)
9059 include 'DIMENSIONS'
9060 include 'COMMON.IOUNITS'
9061 include 'COMMON.CHAIN'
9062 include 'COMMON.FFIELD'
9063 include 'COMMON.DERIV'
9064 include 'COMMON.INTERACT'
9065 include 'COMMON.CONTACTS'
9066 include 'COMMON.TORSION'
9067 include 'COMMON.VAR'
9068 include 'COMMON.GEO'
9069 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9071 iti1 = itortyp(itype(i+1))
9072 if (j.lt.nres-1) then
9073 itj1 = itype2loc(itype(j+1))
9078 dipi(iii,1)=Ub2(iii,i)
9079 dipderi(iii)=Ub2der(iii,i)
9080 dipi(iii,2)=b1(iii,i+1)
9081 dipj(iii,1)=Ub2(iii,j)
9082 dipderj(iii)=Ub2der(iii,j)
9083 dipj(iii,2)=b1(iii,j+1)
9087 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9090 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9097 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9101 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9106 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9107 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9109 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9111 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9113 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9118 C---------------------------------------------------------------------------
9119 subroutine calc_eello(i,j,k,l,jj,kk)
9121 C This subroutine computes matrices and vectors needed to calculate
9122 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9124 implicit real*8 (a-h,o-z)
9125 include 'DIMENSIONS'
9126 include 'COMMON.IOUNITS'
9127 include 'COMMON.CHAIN'
9128 include 'COMMON.DERIV'
9129 include 'COMMON.INTERACT'
9130 include 'COMMON.CONTACTS'
9131 include 'COMMON.TORSION'
9132 include 'COMMON.VAR'
9133 include 'COMMON.GEO'
9134 include 'COMMON.FFIELD'
9135 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9136 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9139 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9140 cd & ' jj=',jj,' kk=',kk
9141 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9142 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9143 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9146 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9147 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9150 call transpose2(aa1(1,1),aa1t(1,1))
9151 call transpose2(aa2(1,1),aa2t(1,1))
9154 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9155 & aa1tder(1,1,lll,kkk))
9156 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9157 & aa2tder(1,1,lll,kkk))
9161 C parallel orientation of the two CA-CA-CA frames.
9163 iti=itype2loc(itype(i))
9167 itk1=itype2loc(itype(k+1))
9168 itj=itype2loc(itype(j))
9169 if (l.lt.nres-1) then
9170 itl1=itype2loc(itype(l+1))
9174 C A1 kernel(j+1) A2T
9176 cd write (iout,'(3f10.5,5x,3f10.5)')
9177 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9179 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9180 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9181 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9182 C Following matrices are needed only for 6-th order cumulants
9183 IF (wcorr6.gt.0.0d0) THEN
9184 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9185 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9186 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9187 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9188 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9189 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9190 & ADtEAderx(1,1,1,1,1,1))
9192 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9193 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9194 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9195 & ADtEA1derx(1,1,1,1,1,1))
9197 C End 6-th order cumulants
9200 cd write (2,*) 'In calc_eello6'
9202 cd write (2,*) 'iii=',iii
9204 cd write (2,*) 'kkk=',kkk
9206 cd write (2,'(3(2f10.5),5x)')
9207 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9212 call transpose2(EUgder(1,1,k),auxmat(1,1))
9213 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9214 call transpose2(EUg(1,1,k),auxmat(1,1))
9215 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9216 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9217 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9218 c in theta; to be sriten later.
9220 c call transpose2(gtEE(1,1,k),auxmat(1,1))
9221 c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9222 c call transpose2(EUg(1,1,k),auxmat(1,1))
9223 c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9228 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9229 & EAEAderx(1,1,lll,kkk,iii,1))
9233 C A1T kernel(i+1) A2
9234 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9235 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9236 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9237 C Following matrices are needed only for 6-th order cumulants
9238 IF (wcorr6.gt.0.0d0) THEN
9239 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9240 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9241 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9242 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9243 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9244 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9245 & ADtEAderx(1,1,1,1,1,2))
9246 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9247 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9248 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9249 & ADtEA1derx(1,1,1,1,1,2))
9251 C End 6-th order cumulants
9252 call transpose2(EUgder(1,1,l),auxmat(1,1))
9253 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9254 call transpose2(EUg(1,1,l),auxmat(1,1))
9255 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9256 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9260 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9261 & EAEAderx(1,1,lll,kkk,iii,2))
9266 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9267 C They are needed only when the fifth- or the sixth-order cumulants are
9269 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9270 call transpose2(AEA(1,1,1),auxmat(1,1))
9271 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9272 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9273 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9274 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9275 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9276 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9277 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9278 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9279 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9280 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9281 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9282 call transpose2(AEA(1,1,2),auxmat(1,1))
9283 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9284 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9285 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9286 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9287 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9288 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9289 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9290 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9291 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9292 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9293 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9294 C Calculate the Cartesian derivatives of the vectors.
9298 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9299 call matvec2(auxmat(1,1),b1(1,i),
9300 & AEAb1derx(1,lll,kkk,iii,1,1))
9301 call matvec2(auxmat(1,1),Ub2(1,i),
9302 & AEAb2derx(1,lll,kkk,iii,1,1))
9303 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9304 & AEAb1derx(1,lll,kkk,iii,2,1))
9305 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9306 & AEAb2derx(1,lll,kkk,iii,2,1))
9307 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9308 call matvec2(auxmat(1,1),b1(1,j),
9309 & AEAb1derx(1,lll,kkk,iii,1,2))
9310 call matvec2(auxmat(1,1),Ub2(1,j),
9311 & AEAb2derx(1,lll,kkk,iii,1,2))
9312 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9313 & AEAb1derx(1,lll,kkk,iii,2,2))
9314 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9315 & AEAb2derx(1,lll,kkk,iii,2,2))
9322 C Antiparallel orientation of the two CA-CA-CA frames.
9324 iti=itype2loc(itype(i))
9328 itk1=itype2loc(itype(k+1))
9329 itl=itype2loc(itype(l))
9330 itj=itype2loc(itype(j))
9331 if (j.lt.nres-1) then
9332 itj1=itype2loc(itype(j+1))
9336 C A2 kernel(j-1)T A1T
9337 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9338 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9339 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9340 C Following matrices are needed only for 6-th order cumulants
9341 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9342 & j.eq.i+4 .and. l.eq.i+3)) THEN
9343 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9344 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9345 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9346 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9347 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9348 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9349 & ADtEAderx(1,1,1,1,1,1))
9350 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9351 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9352 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9353 & ADtEA1derx(1,1,1,1,1,1))
9355 C End 6-th order cumulants
9356 call transpose2(EUgder(1,1,k),auxmat(1,1))
9357 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9358 call transpose2(EUg(1,1,k),auxmat(1,1))
9359 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9360 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9364 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9365 & EAEAderx(1,1,lll,kkk,iii,1))
9369 C A2T kernel(i+1)T A1
9370 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9371 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9372 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9373 C Following matrices are needed only for 6-th order cumulants
9374 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9375 & j.eq.i+4 .and. l.eq.i+3)) THEN
9376 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9377 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9378 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9379 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9380 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9381 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9382 & ADtEAderx(1,1,1,1,1,2))
9383 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9384 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9385 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9386 & ADtEA1derx(1,1,1,1,1,2))
9388 C End 6-th order cumulants
9389 call transpose2(EUgder(1,1,j),auxmat(1,1))
9390 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9391 call transpose2(EUg(1,1,j),auxmat(1,1))
9392 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9393 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9397 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9398 & EAEAderx(1,1,lll,kkk,iii,2))
9403 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9404 C They are needed only when the fifth- or the sixth-order cumulants are
9406 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9407 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9408 call transpose2(AEA(1,1,1),auxmat(1,1))
9409 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9410 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9411 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9412 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9413 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9414 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9415 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9416 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9417 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9418 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9419 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9420 call transpose2(AEA(1,1,2),auxmat(1,1))
9421 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9422 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9423 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9424 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9425 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9426 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9427 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9428 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9429 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9430 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9431 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9432 C Calculate the Cartesian derivatives of the vectors.
9436 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9437 call matvec2(auxmat(1,1),b1(1,i),
9438 & AEAb1derx(1,lll,kkk,iii,1,1))
9439 call matvec2(auxmat(1,1),Ub2(1,i),
9440 & AEAb2derx(1,lll,kkk,iii,1,1))
9441 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9442 & AEAb1derx(1,lll,kkk,iii,2,1))
9443 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9444 & AEAb2derx(1,lll,kkk,iii,2,1))
9445 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9446 call matvec2(auxmat(1,1),b1(1,l),
9447 & AEAb1derx(1,lll,kkk,iii,1,2))
9448 call matvec2(auxmat(1,1),Ub2(1,l),
9449 & AEAb2derx(1,lll,kkk,iii,1,2))
9450 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9451 & AEAb1derx(1,lll,kkk,iii,2,2))
9452 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9453 & AEAb2derx(1,lll,kkk,iii,2,2))
9462 C---------------------------------------------------------------------------
9463 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9464 & KK,KKderg,AKA,AKAderg,AKAderx)
9468 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9469 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9470 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9475 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9477 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9480 cd if (lprn) write (2,*) 'In kernel'
9482 cd if (lprn) write (2,*) 'kkk=',kkk
9484 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9485 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9487 cd write (2,*) 'lll=',lll
9488 cd write (2,*) 'iii=1'
9490 cd write (2,'(3(2f10.5),5x)')
9491 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9494 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9495 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9497 cd write (2,*) 'lll=',lll
9498 cd write (2,*) 'iii=2'
9500 cd write (2,'(3(2f10.5),5x)')
9501 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9508 C---------------------------------------------------------------------------
9509 double precision function eello4(i,j,k,l,jj,kk)
9510 implicit real*8 (a-h,o-z)
9511 include 'DIMENSIONS'
9512 include 'COMMON.IOUNITS'
9513 include 'COMMON.CHAIN'
9514 include 'COMMON.DERIV'
9515 include 'COMMON.INTERACT'
9516 include 'COMMON.CONTACTS'
9517 include 'COMMON.TORSION'
9518 include 'COMMON.VAR'
9519 include 'COMMON.GEO'
9520 double precision pizda(2,2),ggg1(3),ggg2(3)
9521 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9525 cd print *,'eello4:',i,j,k,l,jj,kk
9526 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
9527 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
9528 cold eij=facont_hb(jj,i)
9529 cold ekl=facont_hb(kk,k)
9531 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9532 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9533 gcorr_loc(k-1)=gcorr_loc(k-1)
9534 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9536 gcorr_loc(l-1)=gcorr_loc(l-1)
9537 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9538 C Al 4/16/16: Derivatives in theta, to be added later.
9540 c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
9541 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9544 gcorr_loc(j-1)=gcorr_loc(j-1)
9545 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9547 c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
9548 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9554 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9555 & -EAEAderx(2,2,lll,kkk,iii,1)
9556 cd derx(lll,kkk,iii)=0.0d0
9560 cd gcorr_loc(l-1)=0.0d0
9561 cd gcorr_loc(j-1)=0.0d0
9562 cd gcorr_loc(k-1)=0.0d0
9564 cd write (iout,*)'Contacts have occurred for peptide groups',
9565 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
9566 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9567 if (j.lt.nres-1) then
9574 if (l.lt.nres-1) then
9582 cgrad ggg1(ll)=eel4*g_contij(ll,1)
9583 cgrad ggg2(ll)=eel4*g_contij(ll,2)
9584 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9585 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9586 cgrad ghalf=0.5d0*ggg1(ll)
9587 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9588 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9589 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9590 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9591 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9592 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9593 cgrad ghalf=0.5d0*ggg2(ll)
9594 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9595 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9596 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9597 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9598 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9599 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9603 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9608 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9613 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9618 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9622 cd write (2,*) iii,gcorr_loc(iii)
9625 cd write (2,*) 'ekont',ekont
9626 cd write (iout,*) 'eello4',ekont*eel4
9629 C---------------------------------------------------------------------------
9630 double precision function eello5(i,j,k,l,jj,kk)
9631 implicit real*8 (a-h,o-z)
9632 include 'DIMENSIONS'
9633 include 'COMMON.IOUNITS'
9634 include 'COMMON.CHAIN'
9635 include 'COMMON.DERIV'
9636 include 'COMMON.INTERACT'
9637 include 'COMMON.CONTACTS'
9638 include 'COMMON.TORSION'
9639 include 'COMMON.VAR'
9640 include 'COMMON.GEO'
9641 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9642 double precision ggg1(3),ggg2(3)
9643 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9648 C /l\ / \ \ / \ / \ / C
9649 C / \ / \ \ / \ / \ / C
9650 C j| o |l1 | o | o| o | | o |o C
9651 C \ |/k\| |/ \| / |/ \| |/ \| C
9652 C \i/ \ / \ / / \ / \ C
9654 C (I) (II) (III) (IV) C
9656 C eello5_1 eello5_2 eello5_3 eello5_4 C
9658 C Antiparallel chains C
9661 C /j\ / \ \ / \ / \ / C
9662 C / \ / \ \ / \ / \ / C
9663 C j1| o |l | o | o| o | | o |o C
9664 C \ |/k\| |/ \| / |/ \| |/ \| C
9665 C \i/ \ / \ / / \ / \ C
9667 C (I) (II) (III) (IV) C
9669 C eello5_1 eello5_2 eello5_3 eello5_4 C
9671 C o denotes a local interaction, vertical lines an electrostatic interaction. C
9673 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9674 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9679 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
9681 itk=itype2loc(itype(k))
9682 itl=itype2loc(itype(l))
9683 itj=itype2loc(itype(j))
9688 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9689 cd & eel5_3_num,eel5_4_num)
9693 derx(lll,kkk,iii)=0.0d0
9697 cd eij=facont_hb(jj,i)
9698 cd ekl=facont_hb(kk,k)
9700 cd write (iout,*)'Contacts have occurred for peptide groups',
9701 cd & i,j,' fcont:',eij,' eij',' and ',k,l
9703 C Contribution from the graph I.
9704 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9705 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9706 call transpose2(EUg(1,1,k),auxmat(1,1))
9707 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9708 vv(1)=pizda(1,1)-pizda(2,2)
9709 vv(2)=pizda(1,2)+pizda(2,1)
9710 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9711 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9712 C Explicit gradient in virtual-dihedral angles.
9713 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9714 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9715 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9716 call transpose2(EUgder(1,1,k),auxmat1(1,1))
9717 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9718 vv(1)=pizda(1,1)-pizda(2,2)
9719 vv(2)=pizda(1,2)+pizda(2,1)
9720 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9721 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9722 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9723 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9724 vv(1)=pizda(1,1)-pizda(2,2)
9725 vv(2)=pizda(1,2)+pizda(2,1)
9727 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9728 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9729 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9731 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9732 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9733 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9735 C Cartesian gradient
9739 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9741 vv(1)=pizda(1,1)-pizda(2,2)
9742 vv(2)=pizda(1,2)+pizda(2,1)
9743 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9744 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9745 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9751 C Contribution from graph II
9752 call transpose2(EE(1,1,k),auxmat(1,1))
9753 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9754 vv(1)=pizda(1,1)+pizda(2,2)
9755 vv(2)=pizda(2,1)-pizda(1,2)
9756 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9757 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9758 C Explicit gradient in virtual-dihedral angles.
9759 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9760 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9761 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9762 vv(1)=pizda(1,1)+pizda(2,2)
9763 vv(2)=pizda(2,1)-pizda(1,2)
9765 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9766 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9767 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9769 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9770 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9771 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9773 C Cartesian gradient
9777 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9779 vv(1)=pizda(1,1)+pizda(2,2)
9780 vv(2)=pizda(2,1)-pizda(1,2)
9781 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9782 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9783 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9791 C Parallel orientation
9792 C Contribution from graph III
9793 call transpose2(EUg(1,1,l),auxmat(1,1))
9794 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9795 vv(1)=pizda(1,1)-pizda(2,2)
9796 vv(2)=pizda(1,2)+pizda(2,1)
9797 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9798 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9799 C Explicit gradient in virtual-dihedral angles.
9800 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9801 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9802 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9803 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9804 vv(1)=pizda(1,1)-pizda(2,2)
9805 vv(2)=pizda(1,2)+pizda(2,1)
9806 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9807 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9808 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9809 call transpose2(EUgder(1,1,l),auxmat1(1,1))
9810 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9811 vv(1)=pizda(1,1)-pizda(2,2)
9812 vv(2)=pizda(1,2)+pizda(2,1)
9813 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9814 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9815 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9816 C Cartesian gradient
9820 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9822 vv(1)=pizda(1,1)-pizda(2,2)
9823 vv(2)=pizda(1,2)+pizda(2,1)
9824 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9825 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9826 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9831 C Contribution from graph IV
9833 call transpose2(EE(1,1,l),auxmat(1,1))
9834 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9835 vv(1)=pizda(1,1)+pizda(2,2)
9836 vv(2)=pizda(2,1)-pizda(1,2)
9837 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9838 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
9839 C Explicit gradient in virtual-dihedral angles.
9840 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9841 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9842 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9843 vv(1)=pizda(1,1)+pizda(2,2)
9844 vv(2)=pizda(2,1)-pizda(1,2)
9845 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9846 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9847 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9848 C Cartesian gradient
9852 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9854 vv(1)=pizda(1,1)+pizda(2,2)
9855 vv(2)=pizda(2,1)-pizda(1,2)
9856 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9857 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9858 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
9863 C Antiparallel orientation
9864 C Contribution from graph III
9866 call transpose2(EUg(1,1,j),auxmat(1,1))
9867 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9868 vv(1)=pizda(1,1)-pizda(2,2)
9869 vv(2)=pizda(1,2)+pizda(2,1)
9870 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9871 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9872 C Explicit gradient in virtual-dihedral angles.
9873 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9874 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9875 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9876 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9877 vv(1)=pizda(1,1)-pizda(2,2)
9878 vv(2)=pizda(1,2)+pizda(2,1)
9879 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9880 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9881 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9882 call transpose2(EUgder(1,1,j),auxmat1(1,1))
9883 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9884 vv(1)=pizda(1,1)-pizda(2,2)
9885 vv(2)=pizda(1,2)+pizda(2,1)
9886 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9887 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9888 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9889 C Cartesian gradient
9893 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9895 vv(1)=pizda(1,1)-pizda(2,2)
9896 vv(2)=pizda(1,2)+pizda(2,1)
9897 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9898 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9899 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9904 C Contribution from graph IV
9906 call transpose2(EE(1,1,j),auxmat(1,1))
9907 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9908 vv(1)=pizda(1,1)+pizda(2,2)
9909 vv(2)=pizda(2,1)-pizda(1,2)
9910 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9911 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
9912 C Explicit gradient in virtual-dihedral angles.
9913 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9914 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9915 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9916 vv(1)=pizda(1,1)+pizda(2,2)
9917 vv(2)=pizda(2,1)-pizda(1,2)
9918 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9919 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9920 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9921 C Cartesian gradient
9925 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9927 vv(1)=pizda(1,1)+pizda(2,2)
9928 vv(2)=pizda(2,1)-pizda(1,2)
9929 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9930 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9931 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
9937 eel5=eello5_1+eello5_2+eello5_3+eello5_4
9938 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9939 cd write (2,*) 'ijkl',i,j,k,l
9940 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9941 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
9943 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9944 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9945 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9946 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9947 if (j.lt.nres-1) then
9954 if (l.lt.nres-1) then
9964 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9965 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9966 C summed up outside the subrouine as for the other subroutines
9967 C handling long-range interactions. The old code is commented out
9968 C with "cgrad" to keep track of changes.
9970 cgrad ggg1(ll)=eel5*g_contij(ll,1)
9971 cgrad ggg2(ll)=eel5*g_contij(ll,2)
9972 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9973 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9974 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9975 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9976 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9977 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9978 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9979 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9981 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9982 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9983 cgrad ghalf=0.5d0*ggg1(ll)
9985 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9986 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9987 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9988 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9989 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9990 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9991 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9992 cgrad ghalf=0.5d0*ggg2(ll)
9994 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9995 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9996 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9997 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9998 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9999 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10004 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10005 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10010 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10011 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10017 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10022 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10026 cd write (2,*) iii,g_corr5_loc(iii)
10029 cd write (2,*) 'ekont',ekont
10030 cd write (iout,*) 'eello5',ekont*eel5
10033 c--------------------------------------------------------------------------
10034 double precision function eello6(i,j,k,l,jj,kk)
10035 implicit real*8 (a-h,o-z)
10036 include 'DIMENSIONS'
10037 include 'COMMON.IOUNITS'
10038 include 'COMMON.CHAIN'
10039 include 'COMMON.DERIV'
10040 include 'COMMON.INTERACT'
10041 include 'COMMON.CONTACTS'
10042 include 'COMMON.TORSION'
10043 include 'COMMON.VAR'
10044 include 'COMMON.GEO'
10045 include 'COMMON.FFIELD'
10046 double precision ggg1(3),ggg2(3)
10047 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10052 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10060 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10061 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10065 derx(lll,kkk,iii)=0.0d0
10069 cd eij=facont_hb(jj,i)
10070 cd ekl=facont_hb(kk,k)
10076 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10077 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10078 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10079 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10080 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10081 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10083 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10084 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10085 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10086 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10087 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10088 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10092 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10094 C If turn contributions are considered, they will be handled separately.
10095 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10096 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10097 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10098 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10099 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10100 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10101 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10103 if (j.lt.nres-1) then
10110 if (l.lt.nres-1) then
10118 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10119 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10120 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10121 cgrad ghalf=0.5d0*ggg1(ll)
10123 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10124 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10125 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10126 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10127 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10128 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10129 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10130 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10131 cgrad ghalf=0.5d0*ggg2(ll)
10132 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10134 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10135 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10136 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10137 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10138 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10139 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10144 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10145 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10150 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10151 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10157 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10162 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10166 cd write (2,*) iii,g_corr6_loc(iii)
10169 cd write (2,*) 'ekont',ekont
10170 cd write (iout,*) 'eello6',ekont*eel6
10173 c--------------------------------------------------------------------------
10174 double precision function eello6_graph1(i,j,k,l,imat,swap)
10175 implicit real*8 (a-h,o-z)
10176 include 'DIMENSIONS'
10177 include 'COMMON.IOUNITS'
10178 include 'COMMON.CHAIN'
10179 include 'COMMON.DERIV'
10180 include 'COMMON.INTERACT'
10181 include 'COMMON.CONTACTS'
10182 include 'COMMON.TORSION'
10183 include 'COMMON.VAR'
10184 include 'COMMON.GEO'
10185 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10188 common /kutas/ lprn
10189 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10191 C Parallel Antiparallel C
10197 C \ j|/k\| / \ |/k\|l / C
10198 C \ / \ / \ / \ / C
10202 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10203 itk=itype2loc(itype(k))
10204 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10205 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10206 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10207 call transpose2(EUgC(1,1,k),auxmat(1,1))
10208 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10209 vv1(1)=pizda1(1,1)-pizda1(2,2)
10210 vv1(2)=pizda1(1,2)+pizda1(2,1)
10211 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10212 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10213 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10214 s5=scalar2(vv(1),Dtobr2(1,i))
10215 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10216 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10217 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10218 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10219 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10220 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10221 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10222 & +scalar2(vv(1),Dtobr2der(1,i)))
10223 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10224 vv1(1)=pizda1(1,1)-pizda1(2,2)
10225 vv1(2)=pizda1(1,2)+pizda1(2,1)
10226 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10227 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10229 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10230 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10231 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10232 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10233 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10235 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10236 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10237 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10238 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10239 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10241 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10242 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10243 vv1(1)=pizda1(1,1)-pizda1(2,2)
10244 vv1(2)=pizda1(1,2)+pizda1(2,1)
10245 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10246 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10247 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10248 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10257 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10258 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10259 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10260 call transpose2(EUgC(1,1,k),auxmat(1,1))
10261 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10263 vv1(1)=pizda1(1,1)-pizda1(2,2)
10264 vv1(2)=pizda1(1,2)+pizda1(2,1)
10265 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10266 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10267 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10268 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10269 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10270 s5=scalar2(vv(1),Dtobr2(1,i))
10271 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10277 c----------------------------------------------------------------------------
10278 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10279 implicit real*8 (a-h,o-z)
10280 include 'DIMENSIONS'
10281 include 'COMMON.IOUNITS'
10282 include 'COMMON.CHAIN'
10283 include 'COMMON.DERIV'
10284 include 'COMMON.INTERACT'
10285 include 'COMMON.CONTACTS'
10286 include 'COMMON.TORSION'
10287 include 'COMMON.VAR'
10288 include 'COMMON.GEO'
10290 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10291 & auxvec1(2),auxvec2(2),auxmat1(2,2)
10293 common /kutas/ lprn
10294 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10296 C Parallel Antiparallel C
10302 C \ j|/k\| \ |/k\|l C
10307 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10308 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10309 C AL 7/4/01 s1 would occur in the sixth-order moment,
10310 C but not in a cluster cumulant
10312 s1=dip(1,jj,i)*dip(1,kk,k)
10314 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10315 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10316 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10317 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10318 call transpose2(EUg(1,1,k),auxmat(1,1))
10319 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10320 vv(1)=pizda(1,1)-pizda(2,2)
10321 vv(2)=pizda(1,2)+pizda(2,1)
10322 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10323 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10325 eello6_graph2=-(s1+s2+s3+s4)
10327 eello6_graph2=-(s2+s3+s4)
10329 c eello6_graph2=-s3
10330 C Derivatives in gamma(i-1)
10333 s1=dipderg(1,jj,i)*dip(1,kk,k)
10335 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10336 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10337 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10338 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10340 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10342 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10344 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10346 C Derivatives in gamma(k-1)
10348 s1=dip(1,jj,i)*dipderg(1,kk,k)
10350 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10351 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10352 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10353 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10354 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10355 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10356 vv(1)=pizda(1,1)-pizda(2,2)
10357 vv(2)=pizda(1,2)+pizda(2,1)
10358 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10360 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10362 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10364 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10365 C Derivatives in gamma(j-1) or gamma(l-1)
10368 s1=dipderg(3,jj,i)*dip(1,kk,k)
10370 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10371 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10372 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10373 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10374 vv(1)=pizda(1,1)-pizda(2,2)
10375 vv(2)=pizda(1,2)+pizda(2,1)
10376 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10379 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10381 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10384 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10385 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10387 C Derivatives in gamma(l-1) or gamma(j-1)
10390 s1=dip(1,jj,i)*dipderg(3,kk,k)
10392 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10393 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10394 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10395 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10396 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10397 vv(1)=pizda(1,1)-pizda(2,2)
10398 vv(2)=pizda(1,2)+pizda(2,1)
10399 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10402 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10404 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10407 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10408 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10410 C Cartesian derivatives.
10412 write (2,*) 'In eello6_graph2'
10414 write (2,*) 'iii=',iii
10416 write (2,*) 'kkk=',kkk
10418 write (2,'(3(2f10.5),5x)')
10419 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10429 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10431 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10434 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10436 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10437 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10439 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10440 call transpose2(EUg(1,1,k),auxmat(1,1))
10441 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10443 vv(1)=pizda(1,1)-pizda(2,2)
10444 vv(2)=pizda(1,2)+pizda(2,1)
10445 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10446 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10448 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10450 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10453 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10455 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10462 c----------------------------------------------------------------------------
10463 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10464 implicit real*8 (a-h,o-z)
10465 include 'DIMENSIONS'
10466 include 'COMMON.IOUNITS'
10467 include 'COMMON.CHAIN'
10468 include 'COMMON.DERIV'
10469 include 'COMMON.INTERACT'
10470 include 'COMMON.CONTACTS'
10471 include 'COMMON.TORSION'
10472 include 'COMMON.VAR'
10473 include 'COMMON.GEO'
10474 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10476 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10478 C Parallel Antiparallel C
10483 C /| o |o o| o |\ C
10484 C j|/k\| / |/k\|l / C
10489 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10491 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10492 C energy moment and not to the cluster cumulant.
10493 iti=itortyp(itype(i))
10494 if (j.lt.nres-1) then
10495 itj1=itype2loc(itype(j+1))
10499 itk=itype2loc(itype(k))
10500 itk1=itype2loc(itype(k+1))
10501 if (l.lt.nres-1) then
10502 itl1=itype2loc(itype(l+1))
10507 s1=dip(4,jj,i)*dip(4,kk,k)
10509 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10510 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10511 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10512 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10513 call transpose2(EE(1,1,k),auxmat(1,1))
10514 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10515 vv(1)=pizda(1,1)+pizda(2,2)
10516 vv(2)=pizda(2,1)-pizda(1,2)
10517 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10518 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10519 cd & "sum",-(s2+s3+s4)
10521 eello6_graph3=-(s1+s2+s3+s4)
10523 eello6_graph3=-(s2+s3+s4)
10525 c eello6_graph3=-s4
10526 C Derivatives in gamma(k-1)
10527 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10528 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10529 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10530 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10531 C Derivatives in gamma(l-1)
10532 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10533 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10534 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10535 vv(1)=pizda(1,1)+pizda(2,2)
10536 vv(2)=pizda(2,1)-pizda(1,2)
10537 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10538 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10539 C Cartesian derivatives.
10545 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10547 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10550 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10552 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10553 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10555 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10556 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10558 vv(1)=pizda(1,1)+pizda(2,2)
10559 vv(2)=pizda(2,1)-pizda(1,2)
10560 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10562 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10564 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10567 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10569 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10571 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10577 c----------------------------------------------------------------------------
10578 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10579 implicit real*8 (a-h,o-z)
10580 include 'DIMENSIONS'
10581 include 'COMMON.IOUNITS'
10582 include 'COMMON.CHAIN'
10583 include 'COMMON.DERIV'
10584 include 'COMMON.INTERACT'
10585 include 'COMMON.CONTACTS'
10586 include 'COMMON.TORSION'
10587 include 'COMMON.VAR'
10588 include 'COMMON.GEO'
10589 include 'COMMON.FFIELD'
10590 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10591 & auxvec1(2),auxmat1(2,2)
10593 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10595 C Parallel Antiparallel C
10600 C /| o |o o| o |\ C
10601 C \ j|/k\| \ |/k\|l C
10606 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10608 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10609 C energy moment and not to the cluster cumulant.
10610 cd write (2,*) 'eello_graph4: wturn6',wturn6
10611 iti=itype2loc(itype(i))
10612 itj=itype2loc(itype(j))
10613 if (j.lt.nres-1) then
10614 itj1=itype2loc(itype(j+1))
10618 itk=itype2loc(itype(k))
10619 if (k.lt.nres-1) then
10620 itk1=itype2loc(itype(k+1))
10624 itl=itype2loc(itype(l))
10625 if (l.lt.nres-1) then
10626 itl1=itype2loc(itype(l+1))
10630 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10631 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10632 cd & ' itl',itl,' itl1',itl1
10634 if (imat.eq.1) then
10635 s1=dip(3,jj,i)*dip(3,kk,k)
10637 s1=dip(2,jj,j)*dip(2,kk,l)
10640 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10641 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10643 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10644 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10646 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10647 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10649 call transpose2(EUg(1,1,k),auxmat(1,1))
10650 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10651 vv(1)=pizda(1,1)-pizda(2,2)
10652 vv(2)=pizda(2,1)+pizda(1,2)
10653 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10654 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10656 eello6_graph4=-(s1+s2+s3+s4)
10658 eello6_graph4=-(s2+s3+s4)
10660 C Derivatives in gamma(i-1)
10663 if (imat.eq.1) then
10664 s1=dipderg(2,jj,i)*dip(3,kk,k)
10666 s1=dipderg(4,jj,j)*dip(2,kk,l)
10669 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10671 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10672 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10674 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10675 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10677 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10678 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10679 cd write (2,*) 'turn6 derivatives'
10681 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10683 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10687 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10689 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10693 C Derivatives in gamma(k-1)
10695 if (imat.eq.1) then
10696 s1=dip(3,jj,i)*dipderg(2,kk,k)
10698 s1=dip(2,jj,j)*dipderg(4,kk,l)
10701 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10702 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10704 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10705 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10707 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10708 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10710 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10711 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10712 vv(1)=pizda(1,1)-pizda(2,2)
10713 vv(2)=pizda(2,1)+pizda(1,2)
10714 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10715 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10717 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10719 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10723 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10725 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10728 C Derivatives in gamma(j-1) or gamma(l-1)
10729 if (l.eq.j+1 .and. l.gt.1) then
10730 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10731 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10732 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10733 vv(1)=pizda(1,1)-pizda(2,2)
10734 vv(2)=pizda(2,1)+pizda(1,2)
10735 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10736 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10737 else if (j.gt.1) then
10738 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10739 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10740 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10741 vv(1)=pizda(1,1)-pizda(2,2)
10742 vv(2)=pizda(2,1)+pizda(1,2)
10743 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10744 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10745 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10747 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10750 C Cartesian derivatives.
10756 if (imat.eq.1) then
10757 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10759 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10762 if (imat.eq.1) then
10763 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10765 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10769 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10771 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10773 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10774 & b1(1,j+1),auxvec(1))
10775 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10777 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10778 & b1(1,l+1),auxvec(1))
10779 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10781 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10783 vv(1)=pizda(1,1)-pizda(2,2)
10784 vv(2)=pizda(2,1)+pizda(1,2)
10785 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10787 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10789 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10792 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10795 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10798 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10800 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10802 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10806 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10808 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10811 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10813 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10821 c----------------------------------------------------------------------------
10822 double precision function eello_turn6(i,jj,kk)
10823 implicit real*8 (a-h,o-z)
10824 include 'DIMENSIONS'
10825 include 'COMMON.IOUNITS'
10826 include 'COMMON.CHAIN'
10827 include 'COMMON.DERIV'
10828 include 'COMMON.INTERACT'
10829 include 'COMMON.CONTACTS'
10830 include 'COMMON.TORSION'
10831 include 'COMMON.VAR'
10832 include 'COMMON.GEO'
10833 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10834 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10836 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10837 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10838 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10839 C the respective energy moment and not to the cluster cumulant.
10848 iti=itype2loc(itype(i))
10849 itk=itype2loc(itype(k))
10850 itk1=itype2loc(itype(k+1))
10851 itl=itype2loc(itype(l))
10852 itj=itype2loc(itype(j))
10853 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10854 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
10855 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10860 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10862 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
10866 derx_turn(lll,kkk,iii)=0.0d0
10873 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10875 cd write (2,*) 'eello6_5',eello6_5
10877 call transpose2(AEA(1,1,1),auxmat(1,1))
10878 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10879 ss1=scalar2(Ub2(1,i+2),b1(1,l))
10880 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10882 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10883 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10884 s2 = scalar2(b1(1,k),vtemp1(1))
10886 call transpose2(AEA(1,1,2),atemp(1,1))
10887 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10888 call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
10889 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10891 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10892 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10893 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10895 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10896 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10897 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10898 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10899 ss13 = scalar2(b1(1,k),vtemp4(1))
10900 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10902 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10908 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10909 C Derivatives in gamma(i+2)
10913 call transpose2(AEA(1,1,1),auxmatd(1,1))
10914 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10915 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10916 call transpose2(AEAderg(1,1,2),atempd(1,1))
10917 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10918 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10920 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10921 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10922 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10928 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10929 C Derivatives in gamma(i+3)
10931 call transpose2(AEA(1,1,1),auxmatd(1,1))
10932 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10933 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10934 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10936 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10937 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10938 s2d = scalar2(b1(1,k),vtemp1d(1))
10940 call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
10941 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
10943 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10945 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10946 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10947 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10955 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10956 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10958 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10959 & -0.5d0*ekont*(s2d+s12d)
10961 C Derivatives in gamma(i+4)
10962 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10963 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10964 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10966 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10967 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10968 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10976 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10978 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10980 C Derivatives in gamma(i+5)
10982 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10983 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10984 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10986 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10987 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10988 s2d = scalar2(b1(1,k),vtemp1d(1))
10990 call transpose2(AEA(1,1,2),atempd(1,1))
10991 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10992 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10994 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10995 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10997 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10998 ss13d = scalar2(b1(1,k),vtemp4d(1))
10999 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11007 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11008 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11010 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11011 & -0.5d0*ekont*(s2d+s12d)
11013 C Cartesian derivatives
11018 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11019 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11020 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11022 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11023 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11025 s2d = scalar2(b1(1,k),vtemp1d(1))
11027 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11028 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11029 s8d = -(atempd(1,1)+atempd(2,2))*
11030 & scalar2(cc(1,1,l),vtemp2(1))
11032 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11034 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11035 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11042 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11043 & - 0.5d0*(s1d+s2d)
11045 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11049 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11050 & - 0.5d0*(s8d+s12d)
11052 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11061 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11062 & achuj_tempd(1,1))
11063 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11064 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11065 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11066 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11067 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11069 ss13d = scalar2(b1(1,k),vtemp4d(1))
11070 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11071 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11075 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11076 cd & 16*eel_turn6_num
11078 if (j.lt.nres-1) then
11085 if (l.lt.nres-1) then
11093 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11094 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11095 cgrad ghalf=0.5d0*ggg1(ll)
11097 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11098 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11099 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11100 & +ekont*derx_turn(ll,2,1)
11101 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11102 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11103 & +ekont*derx_turn(ll,4,1)
11104 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11105 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11106 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11107 cgrad ghalf=0.5d0*ggg2(ll)
11109 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11110 & +ekont*derx_turn(ll,2,2)
11111 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11112 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11113 & +ekont*derx_turn(ll,4,2)
11114 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11115 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11116 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11121 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11126 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11132 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11137 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11141 cd write (2,*) iii,g_corr6_loc(iii)
11143 eello_turn6=ekont*eel_turn6
11144 cd write (2,*) 'ekont',ekont
11145 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11149 C-----------------------------------------------------------------------------
11150 double precision function scalar(u,v)
11151 !DIR$ INLINEALWAYS scalar
11153 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11156 double precision u(3),v(3)
11157 cd double precision sc
11165 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11168 crc-------------------------------------------------
11169 SUBROUTINE MATVEC2(A1,V1,V2)
11170 !DIR$ INLINEALWAYS MATVEC2
11172 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11174 implicit real*8 (a-h,o-z)
11175 include 'DIMENSIONS'
11176 DIMENSION A1(2,2),V1(2),V2(2)
11180 c 3 VI=VI+A1(I,K)*V1(K)
11184 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11185 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11190 C---------------------------------------
11191 SUBROUTINE MATMAT2(A1,A2,A3)
11193 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11195 implicit real*8 (a-h,o-z)
11196 include 'DIMENSIONS'
11197 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11198 c DIMENSION AI3(2,2)
11202 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11208 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11209 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11210 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11211 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11219 c-------------------------------------------------------------------------
11220 double precision function scalar2(u,v)
11221 !DIR$ INLINEALWAYS scalar2
11223 double precision u(2),v(2)
11224 double precision sc
11226 scalar2=u(1)*v(1)+u(2)*v(2)
11230 C-----------------------------------------------------------------------------
11232 subroutine transpose2(a,at)
11233 !DIR$ INLINEALWAYS transpose2
11235 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11238 double precision a(2,2),at(2,2)
11245 c--------------------------------------------------------------------------
11246 subroutine transpose(n,a,at)
11249 double precision a(n,n),at(n,n)
11257 C---------------------------------------------------------------------------
11258 subroutine prodmat3(a1,a2,kk,transp,prod)
11259 !DIR$ INLINEALWAYS prodmat3
11261 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11265 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11267 crc double precision auxmat(2,2),prod_(2,2)
11270 crc call transpose2(kk(1,1),auxmat(1,1))
11271 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11272 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11274 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11275 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11276 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11277 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11278 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11279 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11280 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11281 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11284 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11285 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11287 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11288 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11289 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11290 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11291 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11292 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11293 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11294 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11297 c call transpose2(a2(1,1),a2t(1,1))
11300 crc print *,((prod_(i,j),i=1,2),j=1,2)
11301 crc print *,((prod(i,j),i=1,2),j=1,2)
11305 CCC----------------------------------------------
11306 subroutine Eliptransfer(eliptran)
11307 implicit real*8 (a-h,o-z)
11308 include 'DIMENSIONS'
11309 include 'COMMON.GEO'
11310 include 'COMMON.VAR'
11311 include 'COMMON.LOCAL'
11312 include 'COMMON.CHAIN'
11313 include 'COMMON.DERIV'
11314 include 'COMMON.NAMES'
11315 include 'COMMON.INTERACT'
11316 include 'COMMON.IOUNITS'
11317 include 'COMMON.CALC'
11318 include 'COMMON.CONTROL'
11319 include 'COMMON.SPLITELE'
11320 include 'COMMON.SBRIDGE'
11321 C this is done by Adasko
11322 C print *,"wchodze"
11323 C structure of box:
11325 C--bordliptop-- buffore starts
11326 C--bufliptop--- here true lipid starts
11328 C--buflipbot--- lipid ends buffore starts
11329 C--bordlipbot--buffore ends
11331 do i=ilip_start,ilip_end
11333 if (itype(i).eq.ntyp1) cycle
11335 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11336 if (positi.le.0.0) positi=positi+boxzsize
11338 C first for peptide groups
11339 c for each residue check if it is in lipid or lipid water border area
11340 if ((positi.gt.bordlipbot)
11341 &.and.(positi.lt.bordliptop)) then
11342 C the energy transfer exist
11343 if (positi.lt.buflipbot) then
11344 C what fraction I am in
11346 & ((positi-bordlipbot)/lipbufthick)
11347 C lipbufthick is thickenes of lipid buffore
11348 sslip=sscalelip(fracinbuf)
11349 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11350 eliptran=eliptran+sslip*pepliptran
11351 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11352 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11353 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11355 C print *,"doing sccale for lower part"
11356 C print *,i,sslip,fracinbuf,ssgradlip
11357 elseif (positi.gt.bufliptop) then
11358 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11359 sslip=sscalelip(fracinbuf)
11360 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11361 eliptran=eliptran+sslip*pepliptran
11362 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11363 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11364 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11365 C print *, "doing sscalefor top part"
11366 C print *,i,sslip,fracinbuf,ssgradlip
11368 eliptran=eliptran+pepliptran
11369 C print *,"I am in true lipid"
11372 C eliptran=elpitran+0.0 ! I am in water
11375 C print *, "nic nie bylo w lipidzie?"
11376 C now multiply all by the peptide group transfer factor
11377 C eliptran=eliptran*pepliptran
11378 C now the same for side chains
11380 do i=ilip_start,ilip_end
11381 if (itype(i).eq.ntyp1) cycle
11382 positi=(mod(c(3,i+nres),boxzsize))
11383 if (positi.le.0) positi=positi+boxzsize
11384 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11385 c for each residue check if it is in lipid or lipid water border area
11386 C respos=mod(c(3,i+nres),boxzsize)
11387 C print *,positi,bordlipbot,buflipbot
11388 if ((positi.gt.bordlipbot)
11389 & .and.(positi.lt.bordliptop)) then
11390 C the energy transfer exist
11391 if (positi.lt.buflipbot) then
11393 & ((positi-bordlipbot)/lipbufthick)
11394 C lipbufthick is thickenes of lipid buffore
11395 sslip=sscalelip(fracinbuf)
11396 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11397 eliptran=eliptran+sslip*liptranene(itype(i))
11398 gliptranx(3,i)=gliptranx(3,i)
11399 &+ssgradlip*liptranene(itype(i))
11400 gliptranc(3,i-1)= gliptranc(3,i-1)
11401 &+ssgradlip*liptranene(itype(i))
11402 C print *,"doing sccale for lower part"
11403 elseif (positi.gt.bufliptop) then
11405 &((bordliptop-positi)/lipbufthick)
11406 sslip=sscalelip(fracinbuf)
11407 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11408 eliptran=eliptran+sslip*liptranene(itype(i))
11409 gliptranx(3,i)=gliptranx(3,i)
11410 &+ssgradlip*liptranene(itype(i))
11411 gliptranc(3,i-1)= gliptranc(3,i-1)
11412 &+ssgradlip*liptranene(itype(i))
11413 C print *, "doing sscalefor top part",sslip,fracinbuf
11415 eliptran=eliptran+liptranene(itype(i))
11416 C print *,"I am in true lipid"
11418 endif ! if in lipid or buffor
11420 C eliptran=elpitran+0.0 ! I am in water
11424 C---------------------------------------------------------
11425 C AFM soubroutine for constant force
11426 subroutine AFMforce(Eafmforce)
11427 implicit real*8 (a-h,o-z)
11428 include 'DIMENSIONS'
11429 include 'COMMON.GEO'
11430 include 'COMMON.VAR'
11431 include 'COMMON.LOCAL'
11432 include 'COMMON.CHAIN'
11433 include 'COMMON.DERIV'
11434 include 'COMMON.NAMES'
11435 include 'COMMON.INTERACT'
11436 include 'COMMON.IOUNITS'
11437 include 'COMMON.CALC'
11438 include 'COMMON.CONTROL'
11439 include 'COMMON.SPLITELE'
11440 include 'COMMON.SBRIDGE'
11445 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11446 dist=dist+diffafm(i)**2
11449 Eafmforce=-forceAFMconst*(dist-distafminit)
11451 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11452 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11454 C print *,'AFM',Eafmforce
11457 C---------------------------------------------------------
11458 C AFM subroutine with pseudoconstant velocity
11459 subroutine AFMvel(Eafmforce)
11460 implicit real*8 (a-h,o-z)
11461 include 'DIMENSIONS'
11462 include 'COMMON.GEO'
11463 include 'COMMON.VAR'
11464 include 'COMMON.LOCAL'
11465 include 'COMMON.CHAIN'
11466 include 'COMMON.DERIV'
11467 include 'COMMON.NAMES'
11468 include 'COMMON.INTERACT'
11469 include 'COMMON.IOUNITS'
11470 include 'COMMON.CALC'
11471 include 'COMMON.CONTROL'
11472 include 'COMMON.SPLITELE'
11473 include 'COMMON.SBRIDGE'
11475 C Only for check grad COMMENT if not used for checkgrad
11477 C--------------------------------------------------------
11478 C print *,"wchodze"
11482 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11483 dist=dist+diffafm(i)**2
11486 Eafmforce=0.5d0*forceAFMconst
11487 & *(distafminit+totTafm*velAFMconst-dist)**2
11488 C Eafmforce=-forceAFMconst*(dist-distafminit)
11490 gradafm(i,afmend-1)=-forceAFMconst*
11491 &(distafminit+totTafm*velAFMconst-dist)
11493 gradafm(i,afmbeg-1)=forceAFMconst*
11494 &(distafminit+totTafm*velAFMconst-dist)
11497 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11500 C-----------------------------------------------------------
11501 C first for shielding is setting of function of side-chains
11502 subroutine set_shield_fac
11503 implicit real*8 (a-h,o-z)
11504 include 'DIMENSIONS'
11505 include 'COMMON.CHAIN'
11506 include 'COMMON.DERIV'
11507 include 'COMMON.IOUNITS'
11508 include 'COMMON.SHIELD'
11509 include 'COMMON.INTERACT'
11510 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11511 double precision div77_81/0.974996043d0/,
11512 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11514 C the vector between center of side_chain and peptide group
11515 double precision pep_side(3),long,side_calf(3),
11516 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11517 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11518 C the line belowe needs to be changed for FGPROC>1
11520 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11522 Cif there two consequtive dummy atoms there is no peptide group between them
11523 C the line below has to be changed for FGPROC>1
11526 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11530 C first lets set vector conecting the ithe side-chain with kth side-chain
11531 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11532 C pep_side(j)=2.0d0
11533 C and vector conecting the side-chain with its proper calfa
11534 side_calf(j)=c(j,k+nres)-c(j,k)
11535 C side_calf(j)=2.0d0
11536 pept_group(j)=c(j,i)-c(j,i+1)
11537 C lets have their lenght
11538 dist_pep_side=pep_side(j)**2+dist_pep_side
11539 dist_side_calf=dist_side_calf+side_calf(j)**2
11540 dist_pept_group=dist_pept_group+pept_group(j)**2
11542 dist_pep_side=dsqrt(dist_pep_side)
11543 dist_pept_group=dsqrt(dist_pept_group)
11544 dist_side_calf=dsqrt(dist_side_calf)
11546 pep_side_norm(j)=pep_side(j)/dist_pep_side
11547 side_calf_norm(j)=dist_side_calf
11549 C now sscale fraction
11550 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11551 C print *,buff_shield,"buff"
11553 if (sh_frac_dist.le.0.0) cycle
11554 C If we reach here it means that this side chain reaches the shielding sphere
11555 C Lets add him to the list for gradient
11556 ishield_list(i)=ishield_list(i)+1
11557 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11558 C this list is essential otherwise problem would be O3
11559 shield_list(ishield_list(i),i)=k
11560 C Lets have the sscale value
11561 if (sh_frac_dist.gt.1.0) then
11562 scale_fac_dist=1.0d0
11564 sh_frac_dist_grad(j)=0.0d0
11567 scale_fac_dist=-sh_frac_dist*sh_frac_dist
11568 & *(2.0*sh_frac_dist-3.0d0)
11569 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11570 & /dist_pep_side/buff_shield*0.5
11571 C remember for the final gradient multiply sh_frac_dist_grad(j)
11572 C for side_chain by factor -2 !
11574 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11575 C print *,"jestem",scale_fac_dist,fac_help_scale,
11576 C & sh_frac_dist_grad(j)
11579 C if ((i.eq.3).and.(k.eq.2)) then
11580 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11584 C this is what is now we have the distance scaling now volume...
11585 short=short_r_sidechain(itype(k))
11586 long=long_r_sidechain(itype(k))
11587 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11590 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11591 C costhet_fac=0.0d0
11593 costhet_grad(j)=costhet_fac*pep_side(j)
11595 C remember for the final gradient multiply costhet_grad(j)
11596 C for side_chain by factor -2 !
11597 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11598 C pep_side0pept_group is vector multiplication
11599 pep_side0pept_group=0.0
11601 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11603 cosalfa=(pep_side0pept_group/
11604 & (dist_pep_side*dist_side_calf))
11605 fac_alfa_sin=1.0-cosalfa**2
11606 fac_alfa_sin=dsqrt(fac_alfa_sin)
11607 rkprim=fac_alfa_sin*(long-short)+short
11609 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11610 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11613 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11614 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11615 &*(long-short)/fac_alfa_sin*cosalfa/
11616 &((dist_pep_side*dist_side_calf))*
11617 &((side_calf(j))-cosalfa*
11618 &((pep_side(j)/dist_pep_side)*dist_side_calf))
11620 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11621 &*(long-short)/fac_alfa_sin*cosalfa
11622 &/((dist_pep_side*dist_side_calf))*
11624 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11627 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11630 C now the gradient...
11631 C grad_shield is gradient of Calfa for peptide groups
11632 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11634 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11635 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11637 grad_shield(j,i)=grad_shield(j,i)
11638 C gradient po skalowaniu
11639 & +(sh_frac_dist_grad(j)
11640 C gradient po costhet
11641 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11642 &-scale_fac_dist*(cosphi_grad_long(j))
11643 &/(1.0-cosphi) )*div77_81
11645 C grad_shield_side is Cbeta sidechain gradient
11646 grad_shield_side(j,ishield_list(i),i)=
11647 & (sh_frac_dist_grad(j)*(-2.0d0)
11648 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11649 & +scale_fac_dist*(cosphi_grad_long(j))
11650 & *2.0d0/(1.0-cosphi))
11651 & *div77_81*VofOverlap
11653 grad_shield_loc(j,ishield_list(i),i)=
11654 & scale_fac_dist*cosphi_grad_loc(j)
11655 & *2.0d0/(1.0-cosphi)
11656 & *div77_81*VofOverlap
11658 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11660 fac_shield(i)=VolumeTotal*div77_81+div4_81
11661 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11665 C--------------------------------------------------------------------------
11666 double precision function tschebyshev(m,n,x,y)
11668 include "DIMENSIONS"
11670 double precision x(n),y,yy(0:maxvar),aux
11671 c Tschebyshev polynomial. Note that the first term is omitted
11672 c m=0: the constant term is included
11673 c m=1: the constant term is not included
11677 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11686 C--------------------------------------------------------------------------
11687 double precision function gradtschebyshev(m,n,x,y)
11689 include "DIMENSIONS"
11691 double precision x(n+1),y,yy(0:maxvar),aux
11692 c Tschebyshev polynomial. Note that the first term is omitted
11693 c m=0: the constant term is included
11694 c m=1: the constant term is not included
11698 yy(i)=2*y*yy(i-1)-yy(i-2)
11702 aux=aux+x(i+1)*yy(i)*(i+1)
11703 C print *, x(i+1),yy(i),i
11705 gradtschebyshev=aux
11708 C------------------------------------------------------------------------
11709 C first for shielding is setting of function of side-chains
11710 subroutine set_shield_fac2
11711 implicit real*8 (a-h,o-z)
11712 include 'DIMENSIONS'
11713 include 'COMMON.CHAIN'
11714 include 'COMMON.DERIV'
11715 include 'COMMON.IOUNITS'
11716 include 'COMMON.SHIELD'
11717 include 'COMMON.INTERACT'
11718 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11719 double precision div77_81/0.974996043d0/,
11720 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11722 C the vector between center of side_chain and peptide group
11723 double precision pep_side(3),long,side_calf(3),
11724 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11725 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11726 C the line belowe needs to be changed for FGPROC>1
11728 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11730 Cif there two consequtive dummy atoms there is no peptide group between them
11731 C the line below has to be changed for FGPROC>1
11734 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11738 C first lets set vector conecting the ithe side-chain with kth side-chain
11739 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11740 C pep_side(j)=2.0d0
11741 C and vector conecting the side-chain with its proper calfa
11742 side_calf(j)=c(j,k+nres)-c(j,k)
11743 C side_calf(j)=2.0d0
11744 pept_group(j)=c(j,i)-c(j,i+1)
11745 C lets have their lenght
11746 dist_pep_side=pep_side(j)**2+dist_pep_side
11747 dist_side_calf=dist_side_calf+side_calf(j)**2
11748 dist_pept_group=dist_pept_group+pept_group(j)**2
11750 dist_pep_side=dsqrt(dist_pep_side)
11751 dist_pept_group=dsqrt(dist_pept_group)
11752 dist_side_calf=dsqrt(dist_side_calf)
11754 pep_side_norm(j)=pep_side(j)/dist_pep_side
11755 side_calf_norm(j)=dist_side_calf
11757 C now sscale fraction
11758 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11759 C print *,buff_shield,"buff"
11761 if (sh_frac_dist.le.0.0) cycle
11762 C If we reach here it means that this side chain reaches the shielding sphere
11763 C Lets add him to the list for gradient
11764 ishield_list(i)=ishield_list(i)+1
11765 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11766 C this list is essential otherwise problem would be O3
11767 shield_list(ishield_list(i),i)=k
11768 C Lets have the sscale value
11769 if (sh_frac_dist.gt.1.0) then
11770 scale_fac_dist=1.0d0
11772 sh_frac_dist_grad(j)=0.0d0
11775 scale_fac_dist=-sh_frac_dist*sh_frac_dist
11776 & *(2.0d0*sh_frac_dist-3.0d0)
11777 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11778 & /dist_pep_side/buff_shield*0.5d0
11779 C remember for the final gradient multiply sh_frac_dist_grad(j)
11780 C for side_chain by factor -2 !
11782 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11783 C sh_frac_dist_grad(j)=0.0d0
11784 C scale_fac_dist=1.0d0
11785 C print *,"jestem",scale_fac_dist,fac_help_scale,
11786 C & sh_frac_dist_grad(j)
11789 C this is what is now we have the distance scaling now volume...
11790 short=short_r_sidechain(itype(k))
11791 long=long_r_sidechain(itype(k))
11792 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11793 sinthet=short/dist_pep_side*costhet
11797 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11798 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11799 C & -short/dist_pep_side**2/costhet)
11800 C costhet_fac=0.0d0
11802 costhet_grad(j)=costhet_fac*pep_side(j)
11804 C remember for the final gradient multiply costhet_grad(j)
11805 C for side_chain by factor -2 !
11806 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11807 C pep_side0pept_group is vector multiplication
11808 pep_side0pept_group=0.0d0
11810 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11812 cosalfa=(pep_side0pept_group/
11813 & (dist_pep_side*dist_side_calf))
11814 fac_alfa_sin=1.0d0-cosalfa**2
11815 fac_alfa_sin=dsqrt(fac_alfa_sin)
11816 rkprim=fac_alfa_sin*(long-short)+short
11820 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11822 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11823 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11824 & dist_pep_side**2)
11827 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11828 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11829 &*(long-short)/fac_alfa_sin*cosalfa/
11830 &((dist_pep_side*dist_side_calf))*
11831 &((side_calf(j))-cosalfa*
11832 &((pep_side(j)/dist_pep_side)*dist_side_calf))
11833 C cosphi_grad_long(j)=0.0d0
11834 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11835 &*(long-short)/fac_alfa_sin*cosalfa
11836 &/((dist_pep_side*dist_side_calf))*
11838 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11839 C cosphi_grad_loc(j)=0.0d0
11841 C print *,sinphi,sinthet
11842 c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
11843 c & VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
11844 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11847 C now the gradient...
11849 grad_shield(j,i)=grad_shield(j,i)
11850 C gradient po skalowaniu
11851 & +(sh_frac_dist_grad(j)*VofOverlap
11852 C gradient po costhet
11853 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11854 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11855 & sinphi/sinthet*costhet*costhet_grad(j)
11856 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11858 C grad_shield_side is Cbeta sidechain gradient
11859 grad_shield_side(j,ishield_list(i),i)=
11860 & (sh_frac_dist_grad(j)*(-2.0d0)
11862 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11863 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11864 & sinphi/sinthet*costhet*costhet_grad(j)
11865 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11868 grad_shield_loc(j,ishield_list(i),i)=
11869 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11870 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11871 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11875 c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
11877 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11879 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11880 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
11881 c & " wshield",wshield
11882 c write(2,*) "TU",rpp(1,1),short,long,buff_shield
11886 C-----------------------------------------------------------------------
11887 C-----------------------------------------------------------
11888 C This subroutine is to mimic the histone like structure but as well can be
11889 C utilizet to nanostructures (infinit) small modification has to be used to
11890 C make it finite (z gradient at the ends has to be changes as well as the x,y
11891 C gradient has to be modified at the ends
11892 C The energy function is Kihara potential
11893 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11894 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11895 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11896 C simple Kihara potential
11897 subroutine calctube(Etube)
11898 implicit real*8 (a-h,o-z)
11899 include 'DIMENSIONS'
11900 include 'COMMON.GEO'
11901 include 'COMMON.VAR'
11902 include 'COMMON.LOCAL'
11903 include 'COMMON.CHAIN'
11904 include 'COMMON.DERIV'
11905 include 'COMMON.NAMES'
11906 include 'COMMON.INTERACT'
11907 include 'COMMON.IOUNITS'
11908 include 'COMMON.CALC'
11909 include 'COMMON.CONTROL'
11910 include 'COMMON.SPLITELE'
11911 include 'COMMON.SBRIDGE'
11912 double precision tub_r,vectube(3),enetube(maxres*2)
11917 C first we calculate the distance from tube center
11918 C first sugare-phosphate group for NARES this would be peptide group
11921 C lets ommit dummy atoms for now
11922 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11923 C now calculate distance from center of tube and direction vectors
11924 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
11925 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11926 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
11927 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11928 vectube(1)=vectube(1)-tubecenter(1)
11929 vectube(2)=vectube(2)-tubecenter(2)
11931 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11932 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11934 C as the tube is infinity we do not calculate the Z-vector use of Z
11937 C now calculte the distance
11938 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11939 C now normalize vector
11940 vectube(1)=vectube(1)/tub_r
11941 vectube(2)=vectube(2)/tub_r
11942 C calculte rdiffrence between r and r0
11945 rdiff6=rdiff**6.0d0
11946 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11947 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11948 C write(iout,*) "TU13",i,rdiff6,enetube(i)
11949 C print *,rdiff,rdiff6,pep_aa_tube
11950 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11951 C now we calculate gradient
11952 fac=(-12.0d0*pep_aa_tube/rdiff6+
11953 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
11954 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
11957 C now direction of gg_tube vector
11959 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
11960 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
11963 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
11965 C Lets not jump over memory as we use many times iti
11967 C lets ommit dummy atoms for now
11969 C in UNRES uncomment the line below as GLY has no side-chain...
11972 vectube(1)=c(1,i+nres)
11973 vectube(1)=mod(vectube(1),boxxsize)
11974 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11975 vectube(2)=c(2,i+nres)
11976 vectube(2)=mod(vectube(2),boxxsize)
11977 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11979 vectube(1)=vectube(1)-tubecenter(1)
11980 vectube(2)=vectube(2)-tubecenter(2)
11982 C as the tube is infinity we do not calculate the Z-vector use of Z
11985 C now calculte the distance
11986 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11987 C now normalize vector
11988 vectube(1)=vectube(1)/tub_r
11989 vectube(2)=vectube(2)/tub_r
11990 C calculte rdiffrence between r and r0
11993 rdiff6=rdiff**6.0d0
11994 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11995 sc_aa_tube=sc_aa_tube_par(iti)
11996 sc_bb_tube=sc_bb_tube_par(iti)
11997 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
11998 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11999 C now we calculate gradient
12000 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12001 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12002 C now direction of gg_tube vector
12004 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12005 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12009 Etube=Etube+enetube(i)
12011 C print *,"ETUBE", etube
12014 C TO DO 1) add to total energy
12015 C 2) add to gradient summation
12016 C 3) add reading parameters (AND of course oppening of PARAM file)
12017 C 4) add reading the center of tube
12019 C 6) add to zerograd
12021 C-----------------------------------------------------------------------
12022 C-----------------------------------------------------------
12023 C This subroutine is to mimic the histone like structure but as well can be
12024 C utilizet to nanostructures (infinit) small modification has to be used to
12025 C make it finite (z gradient at the ends has to be changes as well as the x,y
12026 C gradient has to be modified at the ends
12027 C The energy function is Kihara potential
12028 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12029 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12030 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12031 C simple Kihara potential
12032 subroutine calctube2(Etube)
12033 implicit real*8 (a-h,o-z)
12034 include 'DIMENSIONS'
12035 include 'COMMON.GEO'
12036 include 'COMMON.VAR'
12037 include 'COMMON.LOCAL'
12038 include 'COMMON.CHAIN'
12039 include 'COMMON.DERIV'
12040 include 'COMMON.NAMES'
12041 include 'COMMON.INTERACT'
12042 include 'COMMON.IOUNITS'
12043 include 'COMMON.CALC'
12044 include 'COMMON.CONTROL'
12045 include 'COMMON.SPLITELE'
12046 include 'COMMON.SBRIDGE'
12047 double precision tub_r,vectube(3),enetube(maxres*2)
12052 C first we calculate the distance from tube center
12053 C first sugare-phosphate group for NARES this would be peptide group
12056 C lets ommit dummy atoms for now
12057 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12058 C now calculate distance from center of tube and direction vectors
12059 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12060 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12061 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12062 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12063 vectube(1)=vectube(1)-tubecenter(1)
12064 vectube(2)=vectube(2)-tubecenter(2)
12066 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12067 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12069 C as the tube is infinity we do not calculate the Z-vector use of Z
12072 C now calculte the distance
12073 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12074 C now normalize vector
12075 vectube(1)=vectube(1)/tub_r
12076 vectube(2)=vectube(2)/tub_r
12077 C calculte rdiffrence between r and r0
12080 rdiff6=rdiff**6.0d0
12081 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12082 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12083 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12084 C print *,rdiff,rdiff6,pep_aa_tube
12085 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12086 C now we calculate gradient
12087 fac=(-12.0d0*pep_aa_tube/rdiff6+
12088 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12089 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12092 C now direction of gg_tube vector
12094 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12095 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12098 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12100 C Lets not jump over memory as we use many times iti
12102 C lets ommit dummy atoms for now
12104 C in UNRES uncomment the line below as GLY has no side-chain...
12107 vectube(1)=c(1,i+nres)
12108 vectube(1)=mod(vectube(1),boxxsize)
12109 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12110 vectube(2)=c(2,i+nres)
12111 vectube(2)=mod(vectube(2),boxxsize)
12112 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12114 vectube(1)=vectube(1)-tubecenter(1)
12115 vectube(2)=vectube(2)-tubecenter(2)
12116 C THIS FRAGMENT MAKES TUBE FINITE
12117 positi=(mod(c(3,i+nres),boxzsize))
12118 if (positi.le.0) positi=positi+boxzsize
12119 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12120 c for each residue check if it is in lipid or lipid water border area
12121 C respos=mod(c(3,i+nres),boxzsize)
12122 print *,positi,bordtubebot,buftubebot,bordtubetop
12123 if ((positi.gt.bordtubebot)
12124 & .and.(positi.lt.bordtubetop)) then
12125 C the energy transfer exist
12126 if (positi.lt.buftubebot) then
12128 & ((positi-bordtubebot)/tubebufthick)
12129 C lipbufthick is thickenes of lipid buffore
12130 sstube=sscalelip(fracinbuf)
12131 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12132 print *,ssgradtube, sstube,tubetranene(itype(i))
12133 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12134 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12135 &+ssgradtube*tubetranene(itype(i))
12136 gg_tube(3,i-1)= gg_tube(3,i-1)
12137 &+ssgradtube*tubetranene(itype(i))
12138 C print *,"doing sccale for lower part"
12139 elseif (positi.gt.buftubetop) then
12141 &((bordtubetop-positi)/tubebufthick)
12142 sstube=sscalelip(fracinbuf)
12143 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12144 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12145 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12146 C &+ssgradtube*tubetranene(itype(i))
12147 C gg_tube(3,i-1)= gg_tube(3,i-1)
12148 C &+ssgradtube*tubetranene(itype(i))
12149 C print *, "doing sscalefor top part",sslip,fracinbuf
12153 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12154 C print *,"I am in true lipid"
12160 endif ! if in lipid or buffor
12161 CEND OF FINITE FRAGMENT
12162 C as the tube is infinity we do not calculate the Z-vector use of Z
12165 C now calculte the distance
12166 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12167 C now normalize vector
12168 vectube(1)=vectube(1)/tub_r
12169 vectube(2)=vectube(2)/tub_r
12170 C calculte rdiffrence between r and r0
12173 rdiff6=rdiff**6.0d0
12174 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12175 sc_aa_tube=sc_aa_tube_par(iti)
12176 sc_bb_tube=sc_bb_tube_par(iti)
12177 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12178 & *sstube+enetube(i+nres)
12179 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12180 C now we calculate gradient
12181 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12182 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12183 C now direction of gg_tube vector
12185 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12186 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12188 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12189 &+ssgradtube*enetube(i+nres)/sstube
12190 gg_tube(3,i-1)= gg_tube(3,i-1)
12191 &+ssgradtube*enetube(i+nres)/sstube
12195 Etube=Etube+enetube(i)
12197 C print *,"ETUBE", etube
12200 C TO DO 1) add to total energy
12201 C 2) add to gradient summation
12202 C 3) add reading parameters (AND of course oppening of PARAM file)
12203 C 4) add reading the center of tube
12205 C 6) add to zerograd
12206 c----------------------------------------------------------------------------
12207 subroutine e_saxs(Esaxs_constr)
12209 include 'DIMENSIONS'
12212 include "COMMON.SETUP"
12215 include 'COMMON.SBRIDGE'
12216 include 'COMMON.CHAIN'
12217 include 'COMMON.GEO'
12218 include 'COMMON.DERIV'
12219 include 'COMMON.LOCAL'
12220 include 'COMMON.INTERACT'
12221 include 'COMMON.VAR'
12222 include 'COMMON.IOUNITS'
12223 include 'COMMON.MD'
12224 include 'COMMON.CONTROL'
12225 include 'COMMON.NAMES'
12226 include 'COMMON.TIME1'
12227 include 'COMMON.FFIELD'
12229 double precision Esaxs_constr
12230 integer i,iint,j,k,l
12231 double precision PgradC(maxSAXS,3,maxres),
12232 & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12234 double precision PgradC_(maxSAXS,3,maxres),
12235 & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12237 double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12238 & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12239 & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12240 & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12241 double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12242 double precision dist,mygauss,mygaussder
12244 integer llicz,lllicz
12245 double precision time01
12246 c SAXS restraint penalty function
12248 write(iout,*) "------- SAXS penalty function start -------"
12249 write (iout,*) "nsaxs",nsaxs
12250 write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12251 write (iout,*) "Psaxs"
12253 write (iout,'(i5,e15.5)') i, Psaxs(i)
12259 Esaxs_constr = 0.0d0
12264 PgradC(k,l,j)=0.0d0
12265 PgradX(k,l,j)=0.0d0
12270 do i=iatsc_s,iatsc_e
12271 if (itype(i).eq.ntyp1) cycle
12272 do iint=1,nint_gr(i)
12273 do j=istart(i,iint),iend(i,iint)
12274 if (itype(j).eq.ntyp1) cycle
12277 dijCASC=dist(i,j+nres)
12278 dijSCCA=dist(i+nres,j)
12279 dijSCSC=dist(i+nres,j+nres)
12280 sigma2CACA=2.0d0/(pstok**2)
12281 sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12282 sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12283 sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12286 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12287 if (itype(j).ne.10) then
12288 expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12292 if (itype(i).ne.10) then
12293 expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12297 if (itype(i).ne.10 .and. itype(j).ne.10) then
12298 expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12302 Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12304 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12306 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12307 CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12308 SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12309 SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12312 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12313 PgradC(k,l,i) = PgradC(k,l,i)-aux
12314 PgradC(k,l,j) = PgradC(k,l,j)+aux
12316 if (itype(j).ne.10) then
12317 aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12318 PgradC(k,l,i) = PgradC(k,l,i)-aux
12319 PgradC(k,l,j) = PgradC(k,l,j)+aux
12320 PgradX(k,l,j) = PgradX(k,l,j)+aux
12323 if (itype(i).ne.10) then
12324 aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12325 PgradX(k,l,i) = PgradX(k,l,i)-aux
12326 PgradC(k,l,i) = PgradC(k,l,i)-aux
12327 PgradC(k,l,j) = PgradC(k,l,j)+aux
12330 if (itype(i).ne.10 .and. itype(j).ne.10) then
12331 aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12332 PgradC(k,l,i) = PgradC(k,l,i)-aux
12333 PgradC(k,l,j) = PgradC(k,l,j)+aux
12334 PgradX(k,l,i) = PgradX(k,l,i)-aux
12335 PgradX(k,l,j) = PgradX(k,l,j)+aux
12341 sigma2CACA=scal_rad**2*0.25d0/
12342 & (restok(itype(j))**2+restok(itype(i))**2)
12343 c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12344 c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12346 sigmaCACA=dsqrt(sigma2CACA)
12347 threesig=3.0d0/sigmaCACA
12351 if (dabs(dijCACA-dk).ge.threesig) cycle
12354 aux = sigmaCACA*(dijCACA-dk)
12355 expCACA = mygauss(aux)
12356 c if (expcaca.eq.0.0d0) cycle
12357 Pcalc(k) = Pcalc(k)+expCACA
12358 CACAgrad = -sigmaCACA*mygaussder(aux)
12359 c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12361 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12362 PgradC(k,l,i) = PgradC(k,l,i)-aux
12363 PgradC(k,l,j) = PgradC(k,l,j)+aux
12366 c write (iout,*) "i",i," j",j," llicz",llicz
12368 IF (saxs_cutoff.eq.0) THEN
12371 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12372 Pcalc(k) = Pcalc(k)+expCACA
12373 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12375 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12376 PgradC(k,l,i) = PgradC(k,l,i)-aux
12377 PgradC(k,l,j) = PgradC(k,l,j)+aux
12381 rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12384 c write (2,*) "ijk",i,j,k
12385 sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12386 if (sss2.eq.0.0d0) cycle
12387 ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12388 if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12389 & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12390 & 1.0d0/dsqrt(sigma2CACA),rrr,dk,
12392 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
12393 Pcalc(k) = Pcalc(k)+expCACA
12395 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12397 CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
12398 & ssgrad2*expCACA/sss2
12401 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12402 PgradC(k,l,i) = PgradC(k,l,i)+aux
12403 PgradC(k,l,j) = PgradC(k,l,j)-aux
12413 c time_SAXS=time_SAXS+MPI_Wtime()-time01
12415 c write (iout,*) "lllicz",lllicz
12417 c time01=MPI_Wtime()
12420 if (nfgtasks.gt.1) then
12421 call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
12422 & MPI_SUM,FG_COMM,IERR)
12423 c if (fg_rank.eq.king) then
12425 Pcalc(k) = Pcalc_(k)
12428 c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
12429 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12430 c if (fg_rank.eq.king) then
12434 c PgradC(k,l,i) = PgradC_(k,l,i)
12440 c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
12441 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12442 c if (fg_rank.eq.king) then
12446 c PgradX(k,l,i) = PgradX_(k,l,i)
12456 Cnorm = Cnorm + Pcalc(k)
12459 if (fg_rank.eq.king) then
12461 Esaxs_constr = dlog(Cnorm)-wsaxs0
12463 if (Pcalc(k).gt.0.0d0)
12464 & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
12466 write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
12470 write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
12485 & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
12486 auxC1 = auxC1+PgradC(k,l,i)
12488 auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
12489 auxX1 = auxX1+PgradX(k,l,i)
12492 gsaxsC(l,i) = auxC - auxC1/Cnorm
12494 gsaxsX(l,i) = auxX - auxX1/Cnorm
12496 c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
12497 c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
12498 c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
12499 c * " gradX",wsaxs*gsaxsX(l,i)
12503 time_SAXS=time_SAXS+MPI_Wtime()-time01
12506 write (iout,*) "gsaxsc"
12508 write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
12516 c----------------------------------------------------------------------------
12517 subroutine e_saxsC(Esaxs_constr)
12519 include 'DIMENSIONS'
12522 include "COMMON.SETUP"
12525 include 'COMMON.SBRIDGE'
12526 include 'COMMON.CHAIN'
12527 include 'COMMON.GEO'
12528 include 'COMMON.DERIV'
12529 include 'COMMON.LOCAL'
12530 include 'COMMON.INTERACT'
12531 include 'COMMON.VAR'
12532 include 'COMMON.IOUNITS'
12533 include 'COMMON.MD'
12534 include 'COMMON.CONTROL'
12535 include 'COMMON.NAMES'
12536 include 'COMMON.TIME1'
12537 include 'COMMON.FFIELD'
12539 double precision Esaxs_constr
12540 integer i,iint,j,k,l
12541 double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
12543 double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
12545 double precision dk,dijCASPH,dijSCSPH,
12546 & sigma2CA,sigma2SC,expCASPH,expSCSPH,
12547 & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
12549 c SAXS restraint penalty function
12551 write(iout,*) "------- SAXS penalty function start -------"
12552 write (iout,*) "nsaxs",nsaxs
12555 print *,MyRank,"C",i,(C(j,i),j=1,3)
12558 print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
12561 Esaxs_constr = 0.0d0
12563 do j=isaxs_start,isaxs_end
12572 if (itype(i).eq.ntyp1) cycle
12576 dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
12578 if (itype(i).ne.10) then
12580 dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
12583 sigma2CA=2.0d0/pstok**2
12584 sigma2SC=4.0d0/restok(itype(i))**2
12585 expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
12586 expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
12587 Pcalc = Pcalc+expCASPH+expSCSPH
12589 write(*,*) "processor i j Pcalc",
12590 & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
12592 CASPHgrad = sigma2CA*expCASPH
12593 SCSPHgrad = sigma2SC*expSCSPH
12595 aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
12596 PgradX(l,i) = PgradX(l,i) + aux
12597 PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
12602 gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
12603 gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
12606 logPtot = logPtot - dlog(Pcalc)
12607 c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
12608 c & " logPtot",logPtot
12611 if (nfgtasks.gt.1) then
12612 c write (iout,*) "logPtot before reduction",logPtot
12613 call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
12614 & MPI_SUM,king,FG_COMM,IERR)
12616 c write (iout,*) "logPtot after reduction",logPtot
12617 call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
12618 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12619 if (fg_rank.eq.king) then
12622 gsaxsC(l,i) = gsaxsC_(l,i)
12626 call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
12627 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12628 if (fg_rank.eq.king) then
12631 gsaxsX(l,i) = gsaxsX_(l,i)
12637 Esaxs_constr = logPtot
12640 c----------------------------------------------------------------------------
12641 double precision function sscale2(r,r_cut,r0,rlamb)
12643 double precision r,gamm,r_cut,r0,rlamb,rr
12645 c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
12646 c write (2,*) "rr",rr
12647 if(rr.lt.r_cut-rlamb) then
12649 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
12650 gamm=(rr-(r_cut-rlamb))/rlamb
12651 sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12657 C-----------------------------------------------------------------------
12658 double precision function sscalgrad2(r,r_cut,r0,rlamb)
12660 double precision r,gamm,r_cut,r0,rlamb,rr
12662 if(rr.lt.r_cut-rlamb) then
12664 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
12665 gamm=(rr-(r_cut-rlamb))/rlamb
12667 sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
12669 sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb