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'
29 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
30 c & " nfgtasks",nfgtasks
31 if (nfgtasks.gt.1) then
33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
34 if (fg_rank.eq.0) then
35 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
36 c print *,"Processor",myrank," BROADCAST iorder"
37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
38 C FG slaves as WEIGHTS array.
58 C FG Master broadcasts the WEIGHTS_ array
59 call MPI_Bcast(weights_(1),n_ene,
60 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
62 C FG slaves receive the WEIGHTS array
63 call MPI_Bcast(weights(1),n_ene,
64 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
85 time_Bcast=time_Bcast+MPI_Wtime()-time00
86 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
87 c call chainbuild_cart
89 c print *,'Processor',myrank,' calling etotal ipot=',ipot
90 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
92 c if (modecalc.eq.12.or.modecalc.eq.14) then
93 c call int_from_cart1(.false.)
100 C Compute the side-chain and electrostatic interaction energy
103 goto (101,102,103,104,105,106) ipot
104 C Lennard-Jones potential.
106 cd print '(a)','Exit ELJ'
108 C Lennard-Jones-Kihara potential (shifted).
111 C Berne-Pechukas potential (dilated LJ, angular dependence).
114 C Gay-Berne potential (shifted LJ, angular dependence).
116 C print *,"bylem w egb"
118 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
121 C Soft-sphere potential
122 106 call e_softsphere(evdw)
124 C Calculate electrostatic (H-bonding) energy of the main chain.
128 cmc Sep-06: egb takes care of dynamic ss bonds too
130 c if (dyn_ss) call dyn_set_nss
132 c print *,"Processor",myrank," computed USCSC"
138 time_vec=time_vec+MPI_Wtime()-time01
140 C Introduction of shielding effect first for each peptide group
141 C the shielding factor is set this factor is describing how each
142 C peptide group is shielded by side-chains
143 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
144 C write (iout,*) "shield_mode",shield_mode
145 if (shield_mode.eq.1) then
147 else if (shield_mode.eq.2) then
150 c print *,"Processor",myrank," left VEC_AND_DERIV"
153 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
154 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
155 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
156 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
158 if (welec.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 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
172 write (iout,*) "Soft-spheer ELEC potential"
173 c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
176 c print *,"Processor",myrank," computed UELEC"
178 C Calculate excluded-volume interaction energy between peptide groups
183 call escp(evdw2,evdw2_14)
189 c write (iout,*) "Soft-sphere SCP potential"
190 call escp_soft_sphere(evdw2,evdw2_14)
193 c Calculate the bond-stretching energy
197 C Calculate the disulfide-bridge and other energy and the contributions
198 C from other distance constraints.
199 cd print *,'Calling EHPB'
201 cd print *,'EHPB exitted succesfully.'
203 C Calculate the virtual-bond-angle energy.
205 if (wang.gt.0d0) then
206 if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
207 call ebend(ebe,ethetacnstr)
209 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
211 if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
212 call ebend_kcc(ebe,ethetacnstr)
218 c print *,"Processor",myrank," computed UB"
220 C Calculate the SC local energy.
222 C print *,"TU DOCHODZE?"
224 c print *,"Processor",myrank," computed USC"
226 C Calculate the virtual-bond torsional energy.
228 cd print *,'nterm=',nterm
229 C print *,"tor",tor_mode
231 if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
232 call etor(etors,edihcnstr)
234 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
236 if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
237 call etor_kcc(etors,edihcnstr)
243 c print *,"Processor",myrank," computed Utor"
245 C 6/23/01 Calculate double-torsional energy
247 if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
252 c print *,"Processor",myrank," computed Utord"
254 C 21/5/07 Calculate local sicdechain correlation energy
256 if (wsccor.gt.0.0d0) then
257 call eback_sc_corr(esccor)
261 C print *,"PRZED MULIt"
262 c print *,"Processor",myrank," computed Usccorr"
264 C 12/1/95 Multi-body terms
268 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
269 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
270 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
271 cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
272 cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
279 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
280 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
281 cd write (iout,*) "multibody_hb ecorr",ecorr
283 c print *,"Processor",myrank," computed Ucorr"
285 C If performing constraint dynamics, call the constraint energy
286 C after the equilibration time
287 if(usampl.and.totT.gt.eq_time) then
294 C 01/27/2015 added by adasko
295 C the energy component below is energy transfer into lipid environment
296 C based on partition function
297 C print *,"przed lipidami"
298 if (wliptran.gt.0) then
299 call Eliptransfer(eliptran)
301 C print *,"za lipidami"
302 if (AFMlog.gt.0) then
303 call AFMforce(Eafmforce)
304 else if (selfguide.gt.0) then
305 call AFMvel(Eafmforce)
308 time_enecalc=time_enecalc+MPI_Wtime()-time00
310 c print *,"Processor",myrank," computed Uconstr"
319 energia(2)=evdw2-evdw2_14
336 energia(8)=eello_turn3
337 energia(9)=eello_turn4
344 energia(19)=edihcnstr
346 energia(20)=Uconst+Uconst_back
349 energia(23)=Eafmforce
350 energia(24)=ethetacnstr
351 c Here are the energies showed per procesor if the are more processors
352 c per molecule then we sum it up in sum_energy subroutine
353 c print *," Processor",myrank," calls SUM_ENERGY"
354 call sum_energy(energia,.true.)
355 if (dyn_ss) call dyn_set_nss
356 c print *," Processor",myrank," left SUM_ENERGY"
358 time_sumene=time_sumene+MPI_Wtime()-time00
362 c-------------------------------------------------------------------------------
363 subroutine sum_energy(energia,reduce)
364 implicit real*8 (a-h,o-z)
369 cMS$ATTRIBUTES C :: proc_proc
375 include 'COMMON.SETUP'
376 include 'COMMON.IOUNITS'
377 double precision energia(0:n_ene),enebuff(0:n_ene+1)
378 include 'COMMON.FFIELD'
379 include 'COMMON.DERIV'
380 include 'COMMON.INTERACT'
381 include 'COMMON.SBRIDGE'
382 include 'COMMON.CHAIN'
384 include 'COMMON.CONTROL'
385 include 'COMMON.TIME1'
388 if (nfgtasks.gt.1 .and. reduce) then
390 write (iout,*) "energies before REDUCE"
391 call enerprint(energia)
395 enebuff(i)=energia(i)
398 call MPI_Barrier(FG_COMM,IERR)
399 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
401 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
402 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
404 write (iout,*) "energies after REDUCE"
405 call enerprint(energia)
408 time_Reduce=time_Reduce+MPI_Wtime()-time00
410 if (fg_rank.eq.0) then
414 evdw2=energia(2)+energia(18)
430 eello_turn3=energia(8)
431 eello_turn4=energia(9)
438 edihcnstr=energia(19)
443 Eafmforce=energia(23)
444 ethetacnstr=energia(24)
446 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
447 & +wang*ebe+wtor*etors+wscloc*escloc
448 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
449 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
450 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
451 & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
454 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
455 & +wang*ebe+wtor*etors+wscloc*escloc
456 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
457 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
458 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
459 & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
467 if (isnan(etot).ne.0) energia(0)=1.0d+99
469 if (isnan(etot)) energia(0)=1.0d+99
474 idumm=proc_proc(etot,i)
476 call proc_proc(etot,i)
478 if(i.eq.1)energia(0)=1.0d+99
485 c-------------------------------------------------------------------------------
486 subroutine sum_gradient
487 implicit real*8 (a-h,o-z)
492 cMS$ATTRIBUTES C :: proc_proc
498 double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
499 & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
500 & ,gloc_scbuf(3,-1:maxres)
501 include 'COMMON.SETUP'
502 include 'COMMON.IOUNITS'
503 include 'COMMON.FFIELD'
504 include 'COMMON.DERIV'
505 include 'COMMON.INTERACT'
506 include 'COMMON.SBRIDGE'
507 include 'COMMON.CHAIN'
509 include 'COMMON.CONTROL'
510 include 'COMMON.TIME1'
511 include 'COMMON.MAXGRAD'
512 include 'COMMON.SCCOR'
517 write (iout,*) "sum_gradient gvdwc, gvdwx"
519 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
520 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
525 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
526 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
527 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
530 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
531 C in virtual-bond-vector coordinates
534 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
536 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
537 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
539 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
541 c write (iout,'(i5,3f10.5,2x,f10.5)')
542 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
544 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
546 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
547 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
555 gradbufc(j,i)=wsc*gvdwc(j,i)+
556 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
557 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
558 & wel_loc*gel_loc_long(j,i)+
559 & wcorr*gradcorr_long(j,i)+
560 & wcorr5*gradcorr5_long(j,i)+
561 & wcorr6*gradcorr6_long(j,i)+
562 & wturn6*gcorr6_turn_long(j,i)+
564 & +wliptran*gliptranc(j,i)
566 & +welec*gshieldc(j,i)
567 & +wcorr*gshieldc_ec(j,i)
568 & +wturn3*gshieldc_t3(j,i)
569 & +wturn4*gshieldc_t4(j,i)
570 & +wel_loc*gshieldc_ll(j,i)
578 gradbufc(j,i)=wsc*gvdwc(j,i)+
579 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
580 & welec*gelc_long(j,i)+
582 & wel_loc*gel_loc_long(j,i)+
583 & wcorr*gradcorr_long(j,i)+
584 & wcorr5*gradcorr5_long(j,i)+
585 & wcorr6*gradcorr6_long(j,i)+
586 & wturn6*gcorr6_turn_long(j,i)+
588 & +wliptran*gliptranc(j,i)
590 & +welec*gshieldc(j,i)
591 & +wcorr*gshieldc_ec(j,i)
592 & +wturn4*gshieldc_t4(j,i)
593 & +wel_loc*gshieldc_ll(j,i)
600 if (nfgtasks.gt.1) then
603 write (iout,*) "gradbufc before allreduce"
605 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
611 gradbufc_sum(j,i)=gradbufc(j,i)
614 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
615 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
616 c time_reduce=time_reduce+MPI_Wtime()-time00
618 c write (iout,*) "gradbufc_sum after allreduce"
620 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
625 c time_allreduce=time_allreduce+MPI_Wtime()-time00
633 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
634 write (iout,*) (i," jgrad_start",jgrad_start(i),
635 & " jgrad_end ",jgrad_end(i),
636 & i=igrad_start,igrad_end)
639 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
640 c do not parallelize this part.
642 c do i=igrad_start,igrad_end
643 c do j=jgrad_start(i),jgrad_end(i)
645 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
650 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
654 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
658 write (iout,*) "gradbufc after summing"
660 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
667 write (iout,*) "gradbufc"
669 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
675 gradbufc_sum(j,i)=gradbufc(j,i)
680 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
684 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
689 c gradbufc(k,i)=0.0d0
693 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
698 write (iout,*) "gradbufc after summing"
700 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
708 gradbufc(k,nres)=0.0d0
713 C print *,gradbufc(1,13)
714 C print *,welec*gelc(1,13)
715 C print *,wel_loc*gel_loc(1,13)
716 C print *,0.5d0*(wscp*gvdwc_scpp(1,13))
717 C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
718 C print *,wel_loc*gel_loc_long(1,13)
719 C print *,gradafm(1,13),"AFM"
720 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
721 & wel_loc*gel_loc(j,i)+
722 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
723 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
724 & wel_loc*gel_loc_long(j,i)+
725 & wcorr*gradcorr_long(j,i)+
726 & wcorr5*gradcorr5_long(j,i)+
727 & wcorr6*gradcorr6_long(j,i)+
728 & wturn6*gcorr6_turn_long(j,i))+
730 & wcorr*gradcorr(j,i)+
731 & wturn3*gcorr3_turn(j,i)+
732 & wturn4*gcorr4_turn(j,i)+
733 & wcorr5*gradcorr5(j,i)+
734 & wcorr6*gradcorr6(j,i)+
735 & wturn6*gcorr6_turn(j,i)+
736 & wsccor*gsccorc(j,i)
737 & +wscloc*gscloc(j,i)
738 & +wliptran*gliptranc(j,i)
740 & +welec*gshieldc(j,i)
741 & +welec*gshieldc_loc(j,i)
742 & +wcorr*gshieldc_ec(j,i)
743 & +wcorr*gshieldc_loc_ec(j,i)
744 & +wturn3*gshieldc_t3(j,i)
745 & +wturn3*gshieldc_loc_t3(j,i)
746 & +wturn4*gshieldc_t4(j,i)
747 & +wturn4*gshieldc_loc_t4(j,i)
748 & +wel_loc*gshieldc_ll(j,i)
749 & +wel_loc*gshieldc_loc_ll(j,i)
757 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
758 & wel_loc*gel_loc(j,i)+
759 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
760 & welec*gelc_long(j,i)+
761 & wel_loc*gel_loc_long(j,i)+
762 & wcorr*gcorr_long(j,i)+
763 & wcorr5*gradcorr5_long(j,i)+
764 & wcorr6*gradcorr6_long(j,i)+
765 & wturn6*gcorr6_turn_long(j,i))+
767 & wcorr*gradcorr(j,i)+
768 & wturn3*gcorr3_turn(j,i)+
769 & wturn4*gcorr4_turn(j,i)+
770 & wcorr5*gradcorr5(j,i)+
771 & wcorr6*gradcorr6(j,i)+
772 & wturn6*gcorr6_turn(j,i)+
773 & wsccor*gsccorc(j,i)
774 & +wscloc*gscloc(j,i)
775 & +wliptran*gliptranc(j,i)
777 & +welec*gshieldc(j,i)
778 & +welec*gshieldc_loc(j,i)
779 & +wcorr*gshieldc_ec(j,i)
780 & +wcorr*gshieldc_loc_ec(j,i)
781 & +wturn3*gshieldc_t3(j,i)
782 & +wturn3*gshieldc_loc_t3(j,i)
783 & +wturn4*gshieldc_t4(j,i)
784 & +wturn4*gshieldc_loc_t4(j,i)
785 & +wel_loc*gshieldc_ll(j,i)
786 & +wel_loc*gshieldc_loc_ll(j,i)
793 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
795 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
796 & wsccor*gsccorx(j,i)
797 & +wscloc*gsclocx(j,i)
798 & +wliptran*gliptranx(j,i)
799 & +welec*gshieldx(j,i)
800 & +wcorr*gshieldx_ec(j,i)
801 & +wturn3*gshieldx_t3(j,i)
802 & +wturn4*gshieldx_t4(j,i)
803 & +wel_loc*gshieldx_ll(j,i)
810 write (iout,*) "gloc before adding corr"
812 write (iout,*) i,gloc(i,icg)
816 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
817 & +wcorr5*g_corr5_loc(i)
818 & +wcorr6*g_corr6_loc(i)
819 & +wturn4*gel_loc_turn4(i)
820 & +wturn3*gel_loc_turn3(i)
821 & +wturn6*gel_loc_turn6(i)
822 & +wel_loc*gel_loc_loc(i)
825 write (iout,*) "gloc after adding corr"
827 write (iout,*) i,gloc(i,icg)
831 if (nfgtasks.gt.1) then
834 gradbufc(j,i)=gradc(j,i,icg)
835 gradbufx(j,i)=gradx(j,i,icg)
839 glocbuf(i)=gloc(i,icg)
843 write (iout,*) "gloc_sc before reduce"
846 write (iout,*) i,j,gloc_sc(j,i,icg)
853 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
857 call MPI_Barrier(FG_COMM,IERR)
858 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
860 call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
861 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
862 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
863 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
864 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
865 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
866 time_reduce=time_reduce+MPI_Wtime()-time00
867 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
868 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
869 time_reduce=time_reduce+MPI_Wtime()-time00
872 write (iout,*) "gloc_sc after reduce"
875 write (iout,*) i,j,gloc_sc(j,i,icg)
881 write (iout,*) "gloc after reduce"
883 write (iout,*) i,gloc(i,icg)
888 if (gnorm_check) then
890 c Compute the maximum elements of the gradient
900 gcorr3_turn_max=0.0d0
901 gcorr4_turn_max=0.0d0
904 gcorr6_turn_max=0.0d0
914 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
915 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
916 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
917 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
918 & gvdwc_scp_max=gvdwc_scp_norm
919 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
920 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
921 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
922 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
923 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
924 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
925 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
926 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
927 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
928 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
929 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
930 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
931 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
933 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
934 & gcorr3_turn_max=gcorr3_turn_norm
935 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
937 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
938 & gcorr4_turn_max=gcorr4_turn_norm
939 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
940 if (gradcorr5_norm.gt.gradcorr5_max)
941 & gradcorr5_max=gradcorr5_norm
942 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
943 if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
944 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
946 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
947 & gcorr6_turn_max=gcorr6_turn_norm
948 gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
949 if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
950 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
951 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
952 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
953 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
954 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
955 if (gradx_scp_norm.gt.gradx_scp_max)
956 & gradx_scp_max=gradx_scp_norm
957 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
958 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
959 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
960 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
961 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
962 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
963 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
964 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
968 open(istat,file=statname,position="append")
970 open(istat,file=statname,access="append")
972 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
973 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
974 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
975 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
976 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
977 & gsccorx_max,gsclocx_max
979 if (gvdwc_max.gt.1.0d4) then
980 write (iout,*) "gvdwc gvdwx gradb gradbx"
982 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
983 & gradb(j,i),gradbx(j,i),j=1,3)
985 call pdbout(0.0d0,'cipiszcze',iout)
991 write (iout,*) "gradc gradx gloc"
993 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
994 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
998 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1002 c-------------------------------------------------------------------------------
1003 subroutine rescale_weights(t_bath)
1004 implicit real*8 (a-h,o-z)
1005 include 'DIMENSIONS'
1006 include 'COMMON.IOUNITS'
1007 include 'COMMON.FFIELD'
1008 include 'COMMON.SBRIDGE'
1009 double precision kfac /2.4d0/
1010 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1012 c facT=2*temp0/(t_bath+temp0)
1013 if (rescale_mode.eq.0) then
1019 else if (rescale_mode.eq.1) then
1020 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1021 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1022 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1023 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1024 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1025 else if (rescale_mode.eq.2) then
1031 facT=licznik/dlog(dexp(x)+dexp(-x))
1032 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1033 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1034 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1035 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1037 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1038 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1040 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1044 welec=weights(3)*fact
1045 wcorr=weights(4)*fact3
1046 wcorr5=weights(5)*fact4
1047 wcorr6=weights(6)*fact5
1048 wel_loc=weights(7)*fact2
1049 wturn3=weights(8)*fact2
1050 wturn4=weights(9)*fact3
1051 wturn6=weights(10)*fact5
1052 wtor=weights(13)*fact
1053 wtor_d=weights(14)*fact2
1054 wsccor=weights(21)*fact
1058 C------------------------------------------------------------------------
1059 subroutine enerprint(energia)
1060 implicit real*8 (a-h,o-z)
1061 include 'DIMENSIONS'
1062 include 'COMMON.IOUNITS'
1063 include 'COMMON.FFIELD'
1064 include 'COMMON.SBRIDGE'
1066 double precision energia(0:n_ene)
1071 evdw2=energia(2)+energia(18)
1083 eello_turn3=energia(8)
1084 eello_turn4=energia(9)
1085 eello_turn6=energia(10)
1091 edihcnstr=energia(19)
1095 eliptran=energia(22)
1096 Eafmforce=energia(23)
1097 ethetacnstr=energia(24)
1099 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1100 & estr,wbond,ebe,wang,
1101 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1103 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1104 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1105 & ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1107 10 format (/'Virtual-chain energies:'//
1108 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1109 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1110 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1111 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1112 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1113 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1114 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1115 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1116 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1117 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
1118 & ' (SS bridges & dist. cnstr.)'/
1119 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1120 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1121 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1122 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1123 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1124 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1125 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1126 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1127 & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1128 & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1129 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1130 & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1131 & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1132 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1133 & 'ETOT= ',1pE16.6,' (total)')
1136 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1137 & estr,wbond,ebe,wang,
1138 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1140 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1141 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1142 & ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1144 10 format (/'Virtual-chain energies:'//
1145 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1146 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1147 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1148 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1149 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1150 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1151 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1152 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1153 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
1154 & ' (SS bridges & dist. cnstr.)'/
1155 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1156 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1157 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1158 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1159 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1160 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1161 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1162 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1163 & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1164 & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1165 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1166 & 'UCONST=',1pE16.6,' (Constraint energy)'/
1167 & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1168 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1169 & 'ETOT= ',1pE16.6,' (total)')
1173 C-----------------------------------------------------------------------
1174 subroutine elj(evdw)
1176 C This subroutine calculates the interaction energy of nonbonded side chains
1177 C assuming the LJ potential of interaction.
1179 implicit real*8 (a-h,o-z)
1180 include 'DIMENSIONS'
1181 parameter (accur=1.0d-10)
1182 include 'COMMON.GEO'
1183 include 'COMMON.VAR'
1184 include 'COMMON.LOCAL'
1185 include 'COMMON.CHAIN'
1186 include 'COMMON.DERIV'
1187 include 'COMMON.INTERACT'
1188 include 'COMMON.TORSION'
1189 include 'COMMON.SBRIDGE'
1190 include 'COMMON.NAMES'
1191 include 'COMMON.IOUNITS'
1192 include 'COMMON.CONTACTS'
1194 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1196 do i=iatsc_s,iatsc_e
1197 itypi=iabs(itype(i))
1198 if (itypi.eq.ntyp1) cycle
1199 itypi1=iabs(itype(i+1))
1206 C Calculate SC interaction energy.
1208 do iint=1,nint_gr(i)
1209 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1210 cd & 'iend=',iend(i,iint)
1211 do j=istart(i,iint),iend(i,iint)
1212 itypj=iabs(itype(j))
1213 if (itypj.eq.ntyp1) cycle
1217 C Change 12/1/95 to calculate four-body interactions
1218 rij=xj*xj+yj*yj+zj*zj
1220 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1221 eps0ij=eps(itypi,itypj)
1223 C have you changed here?
1227 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1228 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1229 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1230 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1231 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1232 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1235 C Calculate the components of the gradient in DC and X
1237 fac=-rrij*(e1+evdwij)
1242 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1243 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1244 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1245 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1249 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1253 C 12/1/95, revised on 5/20/97
1255 C Calculate the contact function. The ith column of the array JCONT will
1256 C contain the numbers of atoms that make contacts with the atom I (of numbers
1257 C greater than I). The arrays FACONT and GACONT will contain the values of
1258 C the contact function and its derivative.
1260 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1261 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1262 C Uncomment next line, if the correlation interactions are contact function only
1263 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1265 sigij=sigma(itypi,itypj)
1266 r0ij=rs0(itypi,itypj)
1268 C Check whether the SC's are not too far to make a contact.
1271 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1272 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1274 if (fcont.gt.0.0D0) then
1275 C If the SC-SC distance if close to sigma, apply spline.
1276 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1277 cAdam & fcont1,fprimcont1)
1278 cAdam fcont1=1.0d0-fcont1
1279 cAdam if (fcont1.gt.0.0d0) then
1280 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1281 cAdam fcont=fcont*fcont1
1283 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1284 cga eps0ij=1.0d0/dsqrt(eps0ij)
1286 cga gg(k)=gg(k)*eps0ij
1288 cga eps0ij=-evdwij*eps0ij
1289 C Uncomment for AL's type of SC correlation interactions.
1290 cadam eps0ij=-evdwij
1291 num_conti=num_conti+1
1292 jcont(num_conti,i)=j
1293 facont(num_conti,i)=fcont*eps0ij
1294 fprimcont=eps0ij*fprimcont/rij
1296 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1297 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1298 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1299 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1300 gacont(1,num_conti,i)=-fprimcont*xj
1301 gacont(2,num_conti,i)=-fprimcont*yj
1302 gacont(3,num_conti,i)=-fprimcont*zj
1303 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1304 cd write (iout,'(2i3,3f10.5)')
1305 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1311 num_cont(i)=num_conti
1315 gvdwc(j,i)=expon*gvdwc(j,i)
1316 gvdwx(j,i)=expon*gvdwx(j,i)
1319 C******************************************************************************
1323 C To save time, the factor of EXPON has been extracted from ALL components
1324 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1327 C******************************************************************************
1330 C-----------------------------------------------------------------------------
1331 subroutine eljk(evdw)
1333 C This subroutine calculates the interaction energy of nonbonded side chains
1334 C assuming the LJK potential of interaction.
1336 implicit real*8 (a-h,o-z)
1337 include 'DIMENSIONS'
1338 include 'COMMON.GEO'
1339 include 'COMMON.VAR'
1340 include 'COMMON.LOCAL'
1341 include 'COMMON.CHAIN'
1342 include 'COMMON.DERIV'
1343 include 'COMMON.INTERACT'
1344 include 'COMMON.IOUNITS'
1345 include 'COMMON.NAMES'
1348 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1350 do i=iatsc_s,iatsc_e
1351 itypi=iabs(itype(i))
1352 if (itypi.eq.ntyp1) cycle
1353 itypi1=iabs(itype(i+1))
1358 C Calculate SC interaction energy.
1360 do iint=1,nint_gr(i)
1361 do j=istart(i,iint),iend(i,iint)
1362 itypj=iabs(itype(j))
1363 if (itypj.eq.ntyp1) cycle
1367 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1368 fac_augm=rrij**expon
1369 e_augm=augm(itypi,itypj)*fac_augm
1370 r_inv_ij=dsqrt(rrij)
1372 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1373 fac=r_shift_inv**expon
1374 C have you changed here?
1378 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1379 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1380 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1381 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1382 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1383 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1384 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1387 C Calculate the components of the gradient in DC and X
1389 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1394 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1395 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1396 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1397 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1401 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1409 gvdwc(j,i)=expon*gvdwc(j,i)
1410 gvdwx(j,i)=expon*gvdwx(j,i)
1415 C-----------------------------------------------------------------------------
1416 subroutine ebp(evdw)
1418 C This subroutine calculates the interaction energy of nonbonded side chains
1419 C assuming the Berne-Pechukas potential of interaction.
1421 implicit real*8 (a-h,o-z)
1422 include 'DIMENSIONS'
1423 include 'COMMON.GEO'
1424 include 'COMMON.VAR'
1425 include 'COMMON.LOCAL'
1426 include 'COMMON.CHAIN'
1427 include 'COMMON.DERIV'
1428 include 'COMMON.NAMES'
1429 include 'COMMON.INTERACT'
1430 include 'COMMON.IOUNITS'
1431 include 'COMMON.CALC'
1432 common /srutu/ icall
1433 c double precision rrsave(maxdim)
1436 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1438 c if (icall.eq.0) then
1444 do i=iatsc_s,iatsc_e
1445 itypi=iabs(itype(i))
1446 if (itypi.eq.ntyp1) cycle
1447 itypi1=iabs(itype(i+1))
1451 dxi=dc_norm(1,nres+i)
1452 dyi=dc_norm(2,nres+i)
1453 dzi=dc_norm(3,nres+i)
1454 c dsci_inv=dsc_inv(itypi)
1455 dsci_inv=vbld_inv(i+nres)
1457 C Calculate SC interaction energy.
1459 do iint=1,nint_gr(i)
1460 do j=istart(i,iint),iend(i,iint)
1462 itypj=iabs(itype(j))
1463 if (itypj.eq.ntyp1) cycle
1464 c dscj_inv=dsc_inv(itypj)
1465 dscj_inv=vbld_inv(j+nres)
1466 chi1=chi(itypi,itypj)
1467 chi2=chi(itypj,itypi)
1474 alf12=0.5D0*(alf1+alf2)
1475 C For diagnostics only!!!
1488 dxj=dc_norm(1,nres+j)
1489 dyj=dc_norm(2,nres+j)
1490 dzj=dc_norm(3,nres+j)
1491 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1492 cd if (icall.eq.0) then
1498 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1500 C Calculate whole angle-dependent part of epsilon and contributions
1501 C to its derivatives
1502 C have you changed here?
1503 fac=(rrij*sigsq)**expon2
1506 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1507 eps2der=evdwij*eps3rt
1508 eps3der=evdwij*eps2rt
1509 evdwij=evdwij*eps2rt*eps3rt
1512 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1514 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1515 cd & restyp(itypi),i,restyp(itypj),j,
1516 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1517 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1518 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1521 C Calculate gradient components.
1522 e1=e1*eps1*eps2rt**2*eps3rt**2
1523 fac=-expon*(e1+evdwij)
1526 C Calculate radial part of the gradient
1530 C Calculate the angular part of the gradient and sum add the contributions
1531 C to the appropriate components of the Cartesian gradient.
1539 C-----------------------------------------------------------------------------
1540 subroutine egb(evdw)
1542 C This subroutine calculates the interaction energy of nonbonded side chains
1543 C assuming the Gay-Berne potential of interaction.
1545 implicit real*8 (a-h,o-z)
1546 include 'DIMENSIONS'
1547 include 'COMMON.GEO'
1548 include 'COMMON.VAR'
1549 include 'COMMON.LOCAL'
1550 include 'COMMON.CHAIN'
1551 include 'COMMON.DERIV'
1552 include 'COMMON.NAMES'
1553 include 'COMMON.INTERACT'
1554 include 'COMMON.IOUNITS'
1555 include 'COMMON.CALC'
1556 include 'COMMON.CONTROL'
1557 include 'COMMON.SPLITELE'
1558 include 'COMMON.SBRIDGE'
1560 integer xshift,yshift,zshift
1563 ccccc energy_dec=.false.
1564 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1567 c if (icall.eq.0) lprn=.false.
1569 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1570 C we have the original box)
1574 do i=iatsc_s,iatsc_e
1575 itypi=iabs(itype(i))
1576 if (itypi.eq.ntyp1) cycle
1577 itypi1=iabs(itype(i+1))
1581 C Return atom into box, boxxsize is size of box in x dimension
1583 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1584 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1585 C Condition for being inside the proper box
1586 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1587 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
1591 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1592 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1593 C Condition for being inside the proper box
1594 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1595 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
1599 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1600 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1601 C Condition for being inside the proper box
1602 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1603 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
1607 if (xi.lt.0) xi=xi+boxxsize
1609 if (yi.lt.0) yi=yi+boxysize
1611 if (zi.lt.0) zi=zi+boxzsize
1612 C define scaling factor for lipids
1614 C if (positi.le.0) positi=positi+boxzsize
1616 C first for peptide groups
1617 c for each residue check if it is in lipid or lipid water border area
1618 if ((zi.gt.bordlipbot)
1619 &.and.(zi.lt.bordliptop)) then
1620 C the energy transfer exist
1621 if (zi.lt.buflipbot) then
1622 C what fraction I am in
1624 & ((zi-bordlipbot)/lipbufthick)
1625 C lipbufthick is thickenes of lipid buffore
1626 sslipi=sscalelip(fracinbuf)
1627 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1628 elseif (zi.gt.bufliptop) then
1629 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1630 sslipi=sscalelip(fracinbuf)
1631 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1641 C xi=xi+xshift*boxxsize
1642 C yi=yi+yshift*boxysize
1643 C zi=zi+zshift*boxzsize
1645 dxi=dc_norm(1,nres+i)
1646 dyi=dc_norm(2,nres+i)
1647 dzi=dc_norm(3,nres+i)
1648 c dsci_inv=dsc_inv(itypi)
1649 dsci_inv=vbld_inv(i+nres)
1650 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1651 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1653 C Calculate SC interaction energy.
1655 do iint=1,nint_gr(i)
1656 do j=istart(i,iint),iend(i,iint)
1657 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1659 c write(iout,*) "PRZED ZWYKLE", evdwij
1660 call dyn_ssbond_ene(i,j,evdwij)
1661 c write(iout,*) "PO ZWYKLE", evdwij
1664 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1665 & 'evdw',i,j,evdwij,' ss'
1666 C triple bond artifac removal
1667 do k=j+1,iend(i,iint)
1668 C search over all next residues
1669 if (dyn_ss_mask(k)) then
1670 C check if they are cysteins
1671 C write(iout,*) 'k=',k
1673 c write(iout,*) "PRZED TRI", evdwij
1674 evdwij_przed_tri=evdwij
1675 call triple_ssbond_ene(i,j,k,evdwij)
1676 c if(evdwij_przed_tri.ne.evdwij) then
1677 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1680 c write(iout,*) "PO TRI", evdwij
1681 C call the energy function that removes the artifical triple disulfide
1682 C bond the soubroutine is located in ssMD.F
1684 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1685 & 'evdw',i,j,evdwij,'tss'
1686 endif!dyn_ss_mask(k)
1690 itypj=iabs(itype(j))
1691 if (itypj.eq.ntyp1) cycle
1692 c dscj_inv=dsc_inv(itypj)
1693 dscj_inv=vbld_inv(j+nres)
1694 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1695 c & 1.0d0/vbld(j+nres)
1696 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1697 sig0ij=sigma(itypi,itypj)
1698 chi1=chi(itypi,itypj)
1699 chi2=chi(itypj,itypi)
1706 alf12=0.5D0*(alf1+alf2)
1707 C For diagnostics only!!!
1720 C Return atom J into box the original box
1722 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1723 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1724 C Condition for being inside the proper box
1725 c if ((xj.gt.((0.5d0)*boxxsize)).or.
1726 c & (xj.lt.((-0.5d0)*boxxsize))) then
1730 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1731 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1732 C Condition for being inside the proper box
1733 c if ((yj.gt.((0.5d0)*boxysize)).or.
1734 c & (yj.lt.((-0.5d0)*boxysize))) then
1738 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1739 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1740 C Condition for being inside the proper box
1741 c if ((zj.gt.((0.5d0)*boxzsize)).or.
1742 c & (zj.lt.((-0.5d0)*boxzsize))) then
1746 if (xj.lt.0) xj=xj+boxxsize
1748 if (yj.lt.0) yj=yj+boxysize
1750 if (zj.lt.0) zj=zj+boxzsize
1751 if ((zj.gt.bordlipbot)
1752 &.and.(zj.lt.bordliptop)) then
1753 C the energy transfer exist
1754 if (zj.lt.buflipbot) then
1755 C what fraction I am in
1757 & ((zj-bordlipbot)/lipbufthick)
1758 C lipbufthick is thickenes of lipid buffore
1759 sslipj=sscalelip(fracinbuf)
1760 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1761 elseif (zj.gt.bufliptop) then
1762 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1763 sslipj=sscalelip(fracinbuf)
1764 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1773 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1774 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1775 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1776 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1777 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1778 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1779 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1780 C print *,sslipi,sslipj,bordlipbot,zi,zj
1781 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1789 xj=xj_safe+xshift*boxxsize
1790 yj=yj_safe+yshift*boxysize
1791 zj=zj_safe+zshift*boxzsize
1792 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1793 if(dist_temp.lt.dist_init) then
1803 if (subchap.eq.1) then
1812 dxj=dc_norm(1,nres+j)
1813 dyj=dc_norm(2,nres+j)
1814 dzj=dc_norm(3,nres+j)
1818 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1819 c write (iout,*) "j",j," dc_norm",
1820 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1821 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1823 sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1824 sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1826 c write (iout,'(a7,4f8.3)')
1827 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1828 if (sss.gt.0.0d0) then
1829 C Calculate angle-dependent terms of energy and contributions to their
1833 sig=sig0ij*dsqrt(sigsq)
1834 rij_shift=1.0D0/rij-sig+sig0ij
1835 c for diagnostics; uncomment
1836 c rij_shift=1.2*sig0ij
1837 C I hate to put IF's in the loops, but here don't have another choice!!!!
1838 if (rij_shift.le.0.0D0) then
1840 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1841 cd & restyp(itypi),i,restyp(itypj),j,
1842 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1846 c---------------------------------------------------------------
1847 rij_shift=1.0D0/rij_shift
1848 fac=rij_shift**expon
1849 C here to start with
1854 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1855 eps2der=evdwij*eps3rt
1856 eps3der=evdwij*eps2rt
1857 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1858 C &((sslipi+sslipj)/2.0d0+
1859 C &(2.0d0-sslipi-sslipj)/2.0d0)
1860 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1861 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1862 evdwij=evdwij*eps2rt*eps3rt
1863 evdw=evdw+evdwij*sss
1865 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1867 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1868 & restyp(itypi),i,restyp(itypj),j,
1869 & epsi,sigm,chi1,chi2,chip1,chip2,
1870 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1871 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1875 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1878 C Calculate gradient components.
1879 e1=e1*eps1*eps2rt**2*eps3rt**2
1880 fac=-expon*(e1+evdwij)*rij_shift
1883 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
1884 c & evdwij,fac,sigma(itypi,itypj),expon
1885 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1887 C Calculate the radial part of the gradient
1888 gg_lipi(3)=eps1*(eps2rt*eps2rt)
1889 &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1890 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1891 &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1892 gg_lipj(3)=ssgradlipj*gg_lipi(3)
1893 gg_lipi(3)=gg_lipi(3)*ssgradlipi
1899 C Calculate angular part of the gradient.
1909 c write (iout,*) "Number of loop steps in EGB:",ind
1910 cccc energy_dec=.false.
1913 C-----------------------------------------------------------------------------
1914 subroutine egbv(evdw)
1916 C This subroutine calculates the interaction energy of nonbonded side chains
1917 C assuming the Gay-Berne-Vorobjev potential of interaction.
1919 implicit real*8 (a-h,o-z)
1920 include 'DIMENSIONS'
1921 include 'COMMON.GEO'
1922 include 'COMMON.VAR'
1923 include 'COMMON.LOCAL'
1924 include 'COMMON.CHAIN'
1925 include 'COMMON.DERIV'
1926 include 'COMMON.NAMES'
1927 include 'COMMON.INTERACT'
1928 include 'COMMON.IOUNITS'
1929 include 'COMMON.CALC'
1930 common /srutu/ icall
1933 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1936 c if (icall.eq.0) lprn=.true.
1938 do i=iatsc_s,iatsc_e
1939 itypi=iabs(itype(i))
1940 if (itypi.eq.ntyp1) cycle
1941 itypi1=iabs(itype(i+1))
1946 if (xi.lt.0) xi=xi+boxxsize
1948 if (yi.lt.0) yi=yi+boxysize
1950 if (zi.lt.0) zi=zi+boxzsize
1951 C define scaling factor for lipids
1953 C if (positi.le.0) positi=positi+boxzsize
1955 C first for peptide groups
1956 c for each residue check if it is in lipid or lipid water border area
1957 if ((zi.gt.bordlipbot)
1958 &.and.(zi.lt.bordliptop)) then
1959 C the energy transfer exist
1960 if (zi.lt.buflipbot) then
1961 C what fraction I am in
1963 & ((zi-bordlipbot)/lipbufthick)
1964 C lipbufthick is thickenes of lipid buffore
1965 sslipi=sscalelip(fracinbuf)
1966 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1967 elseif (zi.gt.bufliptop) then
1968 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1969 sslipi=sscalelip(fracinbuf)
1970 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1980 dxi=dc_norm(1,nres+i)
1981 dyi=dc_norm(2,nres+i)
1982 dzi=dc_norm(3,nres+i)
1983 c dsci_inv=dsc_inv(itypi)
1984 dsci_inv=vbld_inv(i+nres)
1986 C Calculate SC interaction energy.
1988 do iint=1,nint_gr(i)
1989 do j=istart(i,iint),iend(i,iint)
1991 itypj=iabs(itype(j))
1992 if (itypj.eq.ntyp1) cycle
1993 c dscj_inv=dsc_inv(itypj)
1994 dscj_inv=vbld_inv(j+nres)
1995 sig0ij=sigma(itypi,itypj)
1996 r0ij=r0(itypi,itypj)
1997 chi1=chi(itypi,itypj)
1998 chi2=chi(itypj,itypi)
2005 alf12=0.5D0*(alf1+alf2)
2006 C For diagnostics only!!!
2020 if (xj.lt.0) xj=xj+boxxsize
2022 if (yj.lt.0) yj=yj+boxysize
2024 if (zj.lt.0) zj=zj+boxzsize
2025 if ((zj.gt.bordlipbot)
2026 &.and.(zj.lt.bordliptop)) then
2027 C the energy transfer exist
2028 if (zj.lt.buflipbot) then
2029 C what fraction I am in
2031 & ((zj-bordlipbot)/lipbufthick)
2032 C lipbufthick is thickenes of lipid buffore
2033 sslipj=sscalelip(fracinbuf)
2034 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2035 elseif (zj.gt.bufliptop) then
2036 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2037 sslipj=sscalelip(fracinbuf)
2038 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2047 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2048 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2049 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2050 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2051 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2052 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2053 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2061 xj=xj_safe+xshift*boxxsize
2062 yj=yj_safe+yshift*boxysize
2063 zj=zj_safe+zshift*boxzsize
2064 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2065 if(dist_temp.lt.dist_init) then
2075 if (subchap.eq.1) then
2084 dxj=dc_norm(1,nres+j)
2085 dyj=dc_norm(2,nres+j)
2086 dzj=dc_norm(3,nres+j)
2087 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2089 C Calculate angle-dependent terms of energy and contributions to their
2093 sig=sig0ij*dsqrt(sigsq)
2094 rij_shift=1.0D0/rij-sig+r0ij
2095 C I hate to put IF's in the loops, but here don't have another choice!!!!
2096 if (rij_shift.le.0.0D0) then
2101 c---------------------------------------------------------------
2102 rij_shift=1.0D0/rij_shift
2103 fac=rij_shift**expon
2106 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2107 eps2der=evdwij*eps3rt
2108 eps3der=evdwij*eps2rt
2109 fac_augm=rrij**expon
2110 e_augm=augm(itypi,itypj)*fac_augm
2111 evdwij=evdwij*eps2rt*eps3rt
2112 evdw=evdw+evdwij+e_augm
2114 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2116 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2117 & restyp(itypi),i,restyp(itypj),j,
2118 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2119 & chi1,chi2,chip1,chip2,
2120 & eps1,eps2rt**2,eps3rt**2,
2121 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2124 C Calculate gradient components.
2125 e1=e1*eps1*eps2rt**2*eps3rt**2
2126 fac=-expon*(e1+evdwij)*rij_shift
2128 fac=rij*fac-2*expon*rrij*e_augm
2129 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2130 C Calculate the radial part of the gradient
2134 C Calculate angular part of the gradient.
2140 C-----------------------------------------------------------------------------
2141 subroutine sc_angular
2142 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2143 C om12. Called by ebp, egb, and egbv.
2145 include 'COMMON.CALC'
2146 include 'COMMON.IOUNITS'
2150 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2151 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2152 om12=dxi*dxj+dyi*dyj+dzi*dzj
2154 C Calculate eps1(om12) and its derivative in om12
2155 faceps1=1.0D0-om12*chiom12
2156 faceps1_inv=1.0D0/faceps1
2157 eps1=dsqrt(faceps1_inv)
2158 C Following variable is eps1*deps1/dom12
2159 eps1_om12=faceps1_inv*chiom12
2164 c write (iout,*) "om12",om12," eps1",eps1
2165 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2170 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2171 sigsq=1.0D0-facsig*faceps1_inv
2172 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2173 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2174 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2180 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2181 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2183 C Calculate eps2 and its derivatives in om1, om2, and om12.
2186 chipom12=chip12*om12
2187 facp=1.0D0-om12*chipom12
2189 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2190 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2191 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2192 C Following variable is the square root of eps2
2193 eps2rt=1.0D0-facp1*facp_inv
2194 C Following three variables are the derivatives of the square root of eps
2195 C in om1, om2, and om12.
2196 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2197 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2198 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2199 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2200 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2201 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2202 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2203 c & " eps2rt_om12",eps2rt_om12
2204 C Calculate whole angle-dependent part of epsilon and contributions
2205 C to its derivatives
2208 C----------------------------------------------------------------------------
2210 implicit real*8 (a-h,o-z)
2211 include 'DIMENSIONS'
2212 include 'COMMON.CHAIN'
2213 include 'COMMON.DERIV'
2214 include 'COMMON.CALC'
2215 include 'COMMON.IOUNITS'
2216 double precision dcosom1(3),dcosom2(3)
2217 cc print *,'sss=',sss
2218 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2219 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2220 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2221 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2225 c eom12=evdwij*eps1_om12
2227 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2228 c & " sigder",sigder
2229 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2230 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2232 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2233 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2236 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2238 c write (iout,*) "gg",(gg(k),k=1,3)
2240 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2241 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2242 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2243 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2244 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2245 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2246 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2247 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2248 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2249 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2252 C Calculate the components of the gradient in DC and X
2256 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2260 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2261 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2265 C-----------------------------------------------------------------------
2266 subroutine e_softsphere(evdw)
2268 C This subroutine calculates the interaction energy of nonbonded side chains
2269 C assuming the LJ potential of interaction.
2271 implicit real*8 (a-h,o-z)
2272 include 'DIMENSIONS'
2273 parameter (accur=1.0d-10)
2274 include 'COMMON.GEO'
2275 include 'COMMON.VAR'
2276 include 'COMMON.LOCAL'
2277 include 'COMMON.CHAIN'
2278 include 'COMMON.DERIV'
2279 include 'COMMON.INTERACT'
2280 include 'COMMON.TORSION'
2281 include 'COMMON.SBRIDGE'
2282 include 'COMMON.NAMES'
2283 include 'COMMON.IOUNITS'
2284 include 'COMMON.CONTACTS'
2286 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2288 do i=iatsc_s,iatsc_e
2289 itypi=iabs(itype(i))
2290 if (itypi.eq.ntyp1) cycle
2291 itypi1=iabs(itype(i+1))
2296 C Calculate SC interaction energy.
2298 do iint=1,nint_gr(i)
2299 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2300 cd & 'iend=',iend(i,iint)
2301 do j=istart(i,iint),iend(i,iint)
2302 itypj=iabs(itype(j))
2303 if (itypj.eq.ntyp1) cycle
2307 rij=xj*xj+yj*yj+zj*zj
2308 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2309 r0ij=r0(itypi,itypj)
2311 c print *,i,j,r0ij,dsqrt(rij)
2312 if (rij.lt.r0ijsq) then
2313 evdwij=0.25d0*(rij-r0ijsq)**2
2321 C Calculate the components of the gradient in DC and X
2327 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2328 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2329 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2330 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2334 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2342 C--------------------------------------------------------------------------
2343 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2346 C Soft-sphere potential of p-p interaction
2348 implicit real*8 (a-h,o-z)
2349 include 'DIMENSIONS'
2350 include 'COMMON.CONTROL'
2351 include 'COMMON.IOUNITS'
2352 include 'COMMON.GEO'
2353 include 'COMMON.VAR'
2354 include 'COMMON.LOCAL'
2355 include 'COMMON.CHAIN'
2356 include 'COMMON.DERIV'
2357 include 'COMMON.INTERACT'
2358 include 'COMMON.CONTACTS'
2359 include 'COMMON.TORSION'
2360 include 'COMMON.VECTORS'
2361 include 'COMMON.FFIELD'
2363 C write(iout,*) 'In EELEC_soft_sphere'
2370 do i=iatel_s,iatel_e
2371 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2375 xmedi=c(1,i)+0.5d0*dxi
2376 ymedi=c(2,i)+0.5d0*dyi
2377 zmedi=c(3,i)+0.5d0*dzi
2378 xmedi=mod(xmedi,boxxsize)
2379 if (xmedi.lt.0) xmedi=xmedi+boxxsize
2380 ymedi=mod(ymedi,boxysize)
2381 if (ymedi.lt.0) ymedi=ymedi+boxysize
2382 zmedi=mod(zmedi,boxzsize)
2383 if (zmedi.lt.0) zmedi=zmedi+boxzsize
2385 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2386 do j=ielstart(i),ielend(i)
2387 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2391 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2392 r0ij=rpp(iteli,itelj)
2401 if (xj.lt.0) xj=xj+boxxsize
2403 if (yj.lt.0) yj=yj+boxysize
2405 if (zj.lt.0) zj=zj+boxzsize
2406 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2414 xj=xj_safe+xshift*boxxsize
2415 yj=yj_safe+yshift*boxysize
2416 zj=zj_safe+zshift*boxzsize
2417 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2418 if(dist_temp.lt.dist_init) then
2428 if (isubchap.eq.1) then
2437 rij=xj*xj+yj*yj+zj*zj
2438 sss=sscale(sqrt(rij))
2439 sssgrad=sscagrad(sqrt(rij))
2440 if (rij.lt.r0ijsq) then
2441 evdw1ij=0.25d0*(rij-r0ijsq)**2
2447 evdw1=evdw1+evdw1ij*sss
2449 C Calculate contributions to the Cartesian gradient.
2451 ggg(1)=fac*xj*sssgrad
2452 ggg(2)=fac*yj*sssgrad
2453 ggg(3)=fac*zj*sssgrad
2455 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2456 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2459 * Loop over residues i+1 thru j-1.
2463 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2468 cgrad do i=nnt,nct-1
2470 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2472 cgrad do j=i+1,nct-1
2474 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2480 c------------------------------------------------------------------------------
2481 subroutine vec_and_deriv
2482 implicit real*8 (a-h,o-z)
2483 include 'DIMENSIONS'
2487 include 'COMMON.IOUNITS'
2488 include 'COMMON.GEO'
2489 include 'COMMON.VAR'
2490 include 'COMMON.LOCAL'
2491 include 'COMMON.CHAIN'
2492 include 'COMMON.VECTORS'
2493 include 'COMMON.SETUP'
2494 include 'COMMON.TIME1'
2495 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2496 C Compute the local reference systems. For reference system (i), the
2497 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2498 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2500 do i=ivec_start,ivec_end
2504 if (i.eq.nres-1) then
2505 C Case of the last full residue
2506 C Compute the Z-axis
2507 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2508 costh=dcos(pi-theta(nres))
2509 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2513 C Compute the derivatives of uz
2515 uzder(2,1,1)=-dc_norm(3,i-1)
2516 uzder(3,1,1)= dc_norm(2,i-1)
2517 uzder(1,2,1)= dc_norm(3,i-1)
2519 uzder(3,2,1)=-dc_norm(1,i-1)
2520 uzder(1,3,1)=-dc_norm(2,i-1)
2521 uzder(2,3,1)= dc_norm(1,i-1)
2524 uzder(2,1,2)= dc_norm(3,i)
2525 uzder(3,1,2)=-dc_norm(2,i)
2526 uzder(1,2,2)=-dc_norm(3,i)
2528 uzder(3,2,2)= dc_norm(1,i)
2529 uzder(1,3,2)= dc_norm(2,i)
2530 uzder(2,3,2)=-dc_norm(1,i)
2532 C Compute the Y-axis
2535 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2537 C Compute the derivatives of uy
2540 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2541 & -dc_norm(k,i)*dc_norm(j,i-1)
2542 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2544 uyder(j,j,1)=uyder(j,j,1)-costh
2545 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2550 uygrad(l,k,j,i)=uyder(l,k,j)
2551 uzgrad(l,k,j,i)=uzder(l,k,j)
2555 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2556 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2557 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2558 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2561 C Compute the Z-axis
2562 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2563 costh=dcos(pi-theta(i+2))
2564 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2568 C Compute the derivatives of uz
2570 uzder(2,1,1)=-dc_norm(3,i+1)
2571 uzder(3,1,1)= dc_norm(2,i+1)
2572 uzder(1,2,1)= dc_norm(3,i+1)
2574 uzder(3,2,1)=-dc_norm(1,i+1)
2575 uzder(1,3,1)=-dc_norm(2,i+1)
2576 uzder(2,3,1)= dc_norm(1,i+1)
2579 uzder(2,1,2)= dc_norm(3,i)
2580 uzder(3,1,2)=-dc_norm(2,i)
2581 uzder(1,2,2)=-dc_norm(3,i)
2583 uzder(3,2,2)= dc_norm(1,i)
2584 uzder(1,3,2)= dc_norm(2,i)
2585 uzder(2,3,2)=-dc_norm(1,i)
2587 C Compute the Y-axis
2590 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2592 C Compute the derivatives of uy
2595 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2596 & -dc_norm(k,i)*dc_norm(j,i+1)
2597 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2599 uyder(j,j,1)=uyder(j,j,1)-costh
2600 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2605 uygrad(l,k,j,i)=uyder(l,k,j)
2606 uzgrad(l,k,j,i)=uzder(l,k,j)
2610 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2611 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2612 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2613 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2617 vbld_inv_temp(1)=vbld_inv(i+1)
2618 if (i.lt.nres-1) then
2619 vbld_inv_temp(2)=vbld_inv(i+2)
2621 vbld_inv_temp(2)=vbld_inv(i)
2626 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2627 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2632 #if defined(PARVEC) && defined(MPI)
2633 if (nfgtasks1.gt.1) then
2635 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2636 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2637 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2638 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2639 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2641 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2642 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2644 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2645 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2646 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2647 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2648 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2649 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2650 time_gather=time_gather+MPI_Wtime()-time00
2652 c if (fg_rank.eq.0) then
2653 c write (iout,*) "Arrays UY and UZ"
2655 c write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2662 C-----------------------------------------------------------------------------
2663 subroutine check_vecgrad
2664 implicit real*8 (a-h,o-z)
2665 include 'DIMENSIONS'
2666 include 'COMMON.IOUNITS'
2667 include 'COMMON.GEO'
2668 include 'COMMON.VAR'
2669 include 'COMMON.LOCAL'
2670 include 'COMMON.CHAIN'
2671 include 'COMMON.VECTORS'
2672 dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2673 dimension uyt(3,maxres),uzt(3,maxres)
2674 dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2675 double precision delta /1.0d-7/
2678 crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2679 crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2680 crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2681 cd write(iout,'(2i5,2(3f10.5,5x))') i,1,
2682 cd & (dc_norm(if90,i),if90=1,3)
2683 cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2684 cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2685 cd write(iout,'(a)')
2691 uygradt(l,k,j,i)=uygrad(l,k,j,i)
2692 uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2705 cd write (iout,*) 'i=',i
2707 erij(k)=dc_norm(k,i)
2711 dc_norm(k,i)=erij(k)
2713 dc_norm(j,i)=dc_norm(j,i)+delta
2714 c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2716 c dc_norm(k,i)=dc_norm(k,i)/fac
2718 c write (iout,*) (dc_norm(k,i),k=1,3)
2719 c write (iout,*) (erij(k),k=1,3)
2722 uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2723 uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2724 uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2725 uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2727 c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2728 c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2729 c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2732 dc_norm(k,i)=erij(k)
2735 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2736 cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2737 cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2738 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2739 cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2740 cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2741 cd write (iout,'(a)')
2746 C--------------------------------------------------------------------------
2747 subroutine set_matrices
2748 implicit real*8 (a-h,o-z)
2749 include 'DIMENSIONS'
2752 include "COMMON.SETUP"
2754 integer status(MPI_STATUS_SIZE)
2756 include 'COMMON.IOUNITS'
2757 include 'COMMON.GEO'
2758 include 'COMMON.VAR'
2759 include 'COMMON.LOCAL'
2760 include 'COMMON.CHAIN'
2761 include 'COMMON.DERIV'
2762 include 'COMMON.INTERACT'
2763 include 'COMMON.CONTACTS'
2764 include 'COMMON.TORSION'
2765 include 'COMMON.VECTORS'
2766 include 'COMMON.FFIELD'
2767 double precision auxvec(2),auxmat(2,2)
2769 C Compute the virtual-bond-torsional-angle dependent quantities needed
2770 C to calculate the el-loc multibody terms of various order.
2772 c write(iout,*) 'nphi=',nphi,nres
2774 do i=ivec_start+2,ivec_end+2
2779 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2780 iti = itortyp(itype(i-2))
2784 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2785 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2786 iti1 = itortyp(itype(i-1))
2791 b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0)
2792 & +bnew1(2,1,iti)*dsin(theta(i-1))
2793 & +bnew1(3,1,iti)*dcos(theta(i-1)/2.0)
2794 gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2795 & +bnew1(2,1,iti)*dcos(theta(i-1))
2796 & -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2797 c & +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2798 c &*(cos(theta(i)/2.0)
2799 b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0)
2800 & +bnew2(2,1,iti)*dsin(theta(i-1))
2801 & +bnew2(3,1,iti)*dcos(theta(i-1)/2.0)
2802 c & +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2803 c &*(cos(theta(i)/2.0)
2804 gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2805 & +bnew2(2,1,iti)*dcos(theta(i-1))
2806 & -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2807 c if (ggb1(1,i).eq.0.0d0) then
2808 c write(iout,*) 'i=',i,ggb1(1,i),
2809 c &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2810 c &bnew1(2,1,iti)*cos(theta(i)),
2811 c &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2813 b1(2,i-2)=bnew1(1,2,iti)
2815 b2(2,i-2)=bnew2(1,2,iti)
2817 EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2818 EE(1,2,i-2)=eeold(1,2,iti)
2819 EE(2,1,i-2)=eeold(2,1,iti)
2820 EE(2,2,i-2)=eeold(2,2,iti)
2821 gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2826 c EE(1,2,iti)=0.5d0*eenew(1,iti)
2827 c EE(2,1,iti)=0.5d0*eenew(1,iti)
2828 c b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2829 c b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2830 b1tilde(1,i-2)=b1(1,i-2)
2831 b1tilde(2,i-2)=-b1(2,i-2)
2832 b2tilde(1,i-2)=b2(1,i-2)
2833 b2tilde(2,i-2)=-b2(2,i-2)
2834 c write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2835 c write(iout,*) 'b1=',b1(1,i-2)
2836 c write (iout,*) 'theta=', theta(i-1)
2839 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2840 iti = itortyp(itype(i-2))
2844 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2845 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2846 iti1 = itortyp(itype(i-1))
2854 b1tilde(1,i-2)=b1(1,i-2)
2855 b1tilde(2,i-2)=-b1(2,i-2)
2856 b2tilde(1,i-2)=b2(1,i-2)
2857 b2tilde(2,i-2)=-b2(2,i-2)
2858 EE(1,2,i-2)=eeold(1,2,iti)
2859 EE(2,1,i-2)=eeold(2,1,iti)
2860 EE(2,2,i-2)=eeold(2,2,iti)
2861 EE(1,1,i-2)=eeold(1,1,iti)
2865 do i=ivec_start+2,ivec_end+2
2869 if (i .lt. nres+1) then
2906 if (i .gt. 3 .and. i .lt. nres+1) then
2907 obrot_der(1,i-2)=-sin1
2908 obrot_der(2,i-2)= cos1
2909 Ugder(1,1,i-2)= sin1
2910 Ugder(1,2,i-2)=-cos1
2911 Ugder(2,1,i-2)=-cos1
2912 Ugder(2,2,i-2)=-sin1
2915 obrot2_der(1,i-2)=-dwasin2
2916 obrot2_der(2,i-2)= dwacos2
2917 Ug2der(1,1,i-2)= dwasin2
2918 Ug2der(1,2,i-2)=-dwacos2
2919 Ug2der(2,1,i-2)=-dwacos2
2920 Ug2der(2,2,i-2)=-dwasin2
2922 obrot_der(1,i-2)=0.0d0
2923 obrot_der(2,i-2)=0.0d0
2924 Ugder(1,1,i-2)=0.0d0
2925 Ugder(1,2,i-2)=0.0d0
2926 Ugder(2,1,i-2)=0.0d0
2927 Ugder(2,2,i-2)=0.0d0
2928 obrot2_der(1,i-2)=0.0d0
2929 obrot2_der(2,i-2)=0.0d0
2930 Ug2der(1,1,i-2)=0.0d0
2931 Ug2der(1,2,i-2)=0.0d0
2932 Ug2der(2,1,i-2)=0.0d0
2933 Ug2der(2,2,i-2)=0.0d0
2935 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2936 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2937 iti = itortyp(itype(i-2))
2941 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2942 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2943 iti1 = itortyp(itype(i-1))
2947 cd write (iout,*) '*******i',i,' iti1',iti
2948 cd write (iout,*) 'b1',b1(:,iti)
2949 cd write (iout,*) 'b2',b2(:,iti)
2950 cd write (iout,*) 'Ug',Ug(:,:,i-2)
2951 c if (i .gt. iatel_s+2) then
2952 if (i .gt. nnt+2) then
2953 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
2955 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
2956 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
2958 c write(iout,*) "co jest kurwa", iti, EE(1,1,iti),EE(2,1,iti),
2959 c & EE(1,2,iti),EE(2,2,iti)
2960 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
2961 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
2962 c write(iout,*) "Macierz EUG",
2963 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
2965 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2967 call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2968 call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2969 call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2970 call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2971 call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2982 DtUg2(l,k,i-2)=0.0d0
2986 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
2987 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
2989 muder(k,i-2)=Ub2der(k,i-2)
2991 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2992 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2993 if (itype(i-1).le.ntyp) then
2994 iti1 = itortyp(itype(i-1))
3002 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3004 C write (iout,*) 'mumu',i,b1(1,i-1),Ub2(1,i-2)
3005 c write (iout,*) 'mu ',mu(:,i-2),i-2
3006 cd write (iout,*) 'mu1',mu1(:,i-2)
3007 cd write (iout,*) 'mu2',mu2(:,i-2)
3008 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3010 call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3011 call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3012 call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3013 call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3014 call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3015 C Vectors and matrices dependent on a single virtual-bond dihedral.
3016 call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3017 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3018 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3019 call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3020 call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3021 call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3022 call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3023 call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3024 call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3027 C Matrices dependent on two consecutive virtual-bond dihedrals.
3028 C The order of matrices is from left to right.
3029 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3031 c do i=max0(ivec_start,2),ivec_end
3033 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3034 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3035 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3036 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3037 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3038 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3039 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3040 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3043 #if defined(MPI) && defined(PARMAT)
3045 c if (fg_rank.eq.0) then
3046 write (iout,*) "Arrays UG and UGDER before GATHER"
3048 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3049 & ((ug(l,k,i),l=1,2),k=1,2),
3050 & ((ugder(l,k,i),l=1,2),k=1,2)
3052 write (iout,*) "Arrays UG2 and UG2DER"
3054 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3055 & ((ug2(l,k,i),l=1,2),k=1,2),
3056 & ((ug2der(l,k,i),l=1,2),k=1,2)
3058 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3060 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3061 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3062 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3064 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3066 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3067 & costab(i),sintab(i),costab2(i),sintab2(i)
3069 write (iout,*) "Array MUDER"
3071 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3075 if (nfgtasks.gt.1) then
3077 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3078 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3079 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3081 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3082 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3084 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3085 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3087 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3088 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3090 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3091 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3093 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3094 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3096 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3097 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3099 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3100 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3101 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3102 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3103 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3104 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3105 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3106 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3107 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3108 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3109 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3110 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3111 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3113 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3114 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3116 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3117 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3119 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3120 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3122 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3123 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3125 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3126 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3128 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3129 & ivec_count(fg_rank1),
3130 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3132 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3133 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3135 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3136 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3138 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3139 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3141 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3142 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3144 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3145 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3147 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3148 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3150 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3151 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3153 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3154 & ivec_count(fg_rank1),
3155 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3157 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3158 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3160 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3161 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3163 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3164 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3166 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3167 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3169 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3170 & ivec_count(fg_rank1),
3171 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3173 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3174 & ivec_count(fg_rank1),
3175 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3177 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3178 & ivec_count(fg_rank1),
3179 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3180 & MPI_MAT2,FG_COMM1,IERR)
3181 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3182 & ivec_count(fg_rank1),
3183 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3184 & MPI_MAT2,FG_COMM1,IERR)
3187 c Passes matrix info through the ring
3190 if (irecv.lt.0) irecv=nfgtasks1-1
3193 if (inext.ge.nfgtasks1) inext=0
3195 c write (iout,*) "isend",isend," irecv",irecv
3197 lensend=lentyp(isend)
3198 lenrecv=lentyp(irecv)
3199 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3200 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3201 c & MPI_ROTAT1(lensend),inext,2200+isend,
3202 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3203 c & iprev,2200+irecv,FG_COMM,status,IERR)
3204 c write (iout,*) "Gather ROTAT1"
3206 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3207 c & MPI_ROTAT2(lensend),inext,3300+isend,
3208 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3209 c & iprev,3300+irecv,FG_COMM,status,IERR)
3210 c write (iout,*) "Gather ROTAT2"
3212 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3213 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3214 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3215 & iprev,4400+irecv,FG_COMM,status,IERR)
3216 c write (iout,*) "Gather ROTAT_OLD"
3218 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3219 & MPI_PRECOMP11(lensend),inext,5500+isend,
3220 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3221 & iprev,5500+irecv,FG_COMM,status,IERR)
3222 c write (iout,*) "Gather PRECOMP11"
3224 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3225 & MPI_PRECOMP12(lensend),inext,6600+isend,
3226 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3227 & iprev,6600+irecv,FG_COMM,status,IERR)
3228 c write (iout,*) "Gather PRECOMP12"
3230 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3232 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3233 & MPI_ROTAT2(lensend),inext,7700+isend,
3234 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3235 & iprev,7700+irecv,FG_COMM,status,IERR)
3236 c write (iout,*) "Gather PRECOMP21"
3238 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3239 & MPI_PRECOMP22(lensend),inext,8800+isend,
3240 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3241 & iprev,8800+irecv,FG_COMM,status,IERR)
3242 c write (iout,*) "Gather PRECOMP22"
3244 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3245 & MPI_PRECOMP23(lensend),inext,9900+isend,
3246 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3247 & MPI_PRECOMP23(lenrecv),
3248 & iprev,9900+irecv,FG_COMM,status,IERR)
3249 c write (iout,*) "Gather PRECOMP23"
3254 if (irecv.lt.0) irecv=nfgtasks1-1
3257 time_gather=time_gather+MPI_Wtime()-time00
3260 c if (fg_rank.eq.0) then
3261 write (iout,*) "Arrays UG and UGDER"
3263 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3264 & ((ug(l,k,i),l=1,2),k=1,2),
3265 & ((ugder(l,k,i),l=1,2),k=1,2)
3267 write (iout,*) "Arrays UG2 and UG2DER"
3269 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3270 & ((ug2(l,k,i),l=1,2),k=1,2),
3271 & ((ug2der(l,k,i),l=1,2),k=1,2)
3273 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3275 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3276 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3277 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3279 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3281 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3282 & costab(i),sintab(i),costab2(i),sintab2(i)
3284 write (iout,*) "Array MUDER"
3286 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3292 cd iti = itortyp(itype(i))
3295 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3296 cd & (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3301 C--------------------------------------------------------------------------
3302 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3304 C This subroutine calculates the average interaction energy and its gradient
3305 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3306 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3307 C The potential depends both on the distance of peptide-group centers and on
3308 C the orientation of the CA-CA virtual bonds.
3310 implicit real*8 (a-h,o-z)
3314 include 'DIMENSIONS'
3315 include 'COMMON.CONTROL'
3316 include 'COMMON.SETUP'
3317 include 'COMMON.IOUNITS'
3318 include 'COMMON.GEO'
3319 include 'COMMON.VAR'
3320 include 'COMMON.LOCAL'
3321 include 'COMMON.CHAIN'
3322 include 'COMMON.DERIV'
3323 include 'COMMON.INTERACT'
3324 include 'COMMON.CONTACTS'
3325 include 'COMMON.TORSION'
3326 include 'COMMON.VECTORS'
3327 include 'COMMON.FFIELD'
3328 include 'COMMON.TIME1'
3329 include 'COMMON.SPLITELE'
3330 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3331 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3332 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3333 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3334 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3335 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3337 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3339 double precision scal_el /1.0d0/
3341 double precision scal_el /0.5d0/
3344 C 13-go grudnia roku pamietnego...
3345 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3346 & 0.0d0,1.0d0,0.0d0,
3347 & 0.0d0,0.0d0,1.0d0/
3348 cd write(iout,*) 'In EELEC'
3350 cd write(iout,*) 'Type',i
3351 cd write(iout,*) 'B1',B1(:,i)
3352 cd write(iout,*) 'B2',B2(:,i)
3353 cd write(iout,*) 'CC',CC(:,:,i)
3354 cd write(iout,*) 'DD',DD(:,:,i)
3355 cd write(iout,*) 'EE',EE(:,:,i)
3357 cd call check_vecgrad
3359 if (icheckgrad.eq.1) then
3361 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3363 dc_norm(k,i)=dc(k,i)*fac
3365 c write (iout,*) 'i',i,' fac',fac
3368 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3369 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3370 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3371 c call vec_and_deriv
3377 time_mat=time_mat+MPI_Wtime()-time01
3381 cd write (iout,*) 'i=',i
3383 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3386 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3387 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3400 cd print '(a)','Enter EELEC'
3401 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3403 gel_loc_loc(i)=0.0d0
3408 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3410 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3412 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3413 do i=iturn3_start,iturn3_end
3415 C write(iout,*) "tu jest i",i
3416 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3417 C changes suggested by Ana to avoid out of bounds
3418 & .or.((i+4).gt.nres)
3420 C end of changes by Ana
3421 & .or. itype(i+2).eq.ntyp1
3422 & .or. itype(i+3).eq.ntyp1) cycle
3424 if(itype(i-1).eq.ntyp1)cycle
3427 if (itype(i+4).eq.ntyp1) cycle
3432 dx_normi=dc_norm(1,i)
3433 dy_normi=dc_norm(2,i)
3434 dz_normi=dc_norm(3,i)
3435 xmedi=c(1,i)+0.5d0*dxi
3436 ymedi=c(2,i)+0.5d0*dyi
3437 zmedi=c(3,i)+0.5d0*dzi
3438 xmedi=mod(xmedi,boxxsize)
3439 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3440 ymedi=mod(ymedi,boxysize)
3441 if (ymedi.lt.0) ymedi=ymedi+boxysize
3442 zmedi=mod(zmedi,boxzsize)
3443 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3445 call eelecij(i,i+2,ees,evdw1,eel_loc)
3446 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3447 num_cont_hb(i)=num_conti
3449 do i=iturn4_start,iturn4_end
3451 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3452 C changes suggested by Ana to avoid out of bounds
3453 & .or.((i+5).gt.nres)
3455 C end of changes suggested by Ana
3456 & .or. itype(i+3).eq.ntyp1
3457 & .or. itype(i+4).eq.ntyp1
3458 & .or. itype(i+5).eq.ntyp1
3459 & .or. itype(i).eq.ntyp1
3460 & .or. itype(i-1).eq.ntyp1
3465 dx_normi=dc_norm(1,i)
3466 dy_normi=dc_norm(2,i)
3467 dz_normi=dc_norm(3,i)
3468 xmedi=c(1,i)+0.5d0*dxi
3469 ymedi=c(2,i)+0.5d0*dyi
3470 zmedi=c(3,i)+0.5d0*dzi
3471 C Return atom into box, boxxsize is size of box in x dimension
3473 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3474 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3475 C Condition for being inside the proper box
3476 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3477 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3481 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3482 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3483 C Condition for being inside the proper box
3484 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3485 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3489 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3490 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3491 C Condition for being inside the proper box
3492 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3493 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3496 xmedi=mod(xmedi,boxxsize)
3497 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3498 ymedi=mod(ymedi,boxysize)
3499 if (ymedi.lt.0) ymedi=ymedi+boxysize
3500 zmedi=mod(zmedi,boxzsize)
3501 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3503 num_conti=num_cont_hb(i)
3504 c write(iout,*) "JESTEM W PETLI"
3505 call eelecij(i,i+3,ees,evdw1,eel_loc)
3506 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3507 & call eturn4(i,eello_turn4)
3508 num_cont_hb(i)=num_conti
3510 C Loop over all neighbouring boxes
3515 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3518 do i=iatel_s,iatel_e
3521 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3522 C changes suggested by Ana to avoid out of bounds
3523 & .or.((i+2).gt.nres)
3525 C end of changes by Ana
3526 & .or. itype(i+2).eq.ntyp1
3527 & .or. itype(i-1).eq.ntyp1
3532 dx_normi=dc_norm(1,i)
3533 dy_normi=dc_norm(2,i)
3534 dz_normi=dc_norm(3,i)
3535 xmedi=c(1,i)+0.5d0*dxi
3536 ymedi=c(2,i)+0.5d0*dyi
3537 zmedi=c(3,i)+0.5d0*dzi
3538 xmedi=mod(xmedi,boxxsize)
3539 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3540 ymedi=mod(ymedi,boxysize)
3541 if (ymedi.lt.0) ymedi=ymedi+boxysize
3542 zmedi=mod(zmedi,boxzsize)
3543 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3544 C xmedi=xmedi+xshift*boxxsize
3545 C ymedi=ymedi+yshift*boxysize
3546 C zmedi=zmedi+zshift*boxzsize
3548 C Return tom into box, boxxsize is size of box in x dimension
3550 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3551 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3552 C Condition for being inside the proper box
3553 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3554 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3558 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3559 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3560 C Condition for being inside the proper box
3561 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3562 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3566 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3567 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3568 cC Condition for being inside the proper box
3569 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3570 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3574 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3575 num_conti=num_cont_hb(i)
3577 do j=ielstart(i),ielend(i)
3579 C write (iout,*) i,j
3581 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3582 C changes suggested by Ana to avoid out of bounds
3583 & .or.((j+2).gt.nres)
3585 C end of changes by Ana
3586 & .or.itype(j+2).eq.ntyp1
3587 & .or.itype(j-1).eq.ntyp1
3589 call eelecij(i,j,ees,evdw1,eel_loc)
3591 num_cont_hb(i)=num_conti
3597 c write (iout,*) "Number of loop steps in EELEC:",ind
3599 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3600 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3602 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3603 ccc eel_loc=eel_loc+eello_turn3
3604 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3607 C-------------------------------------------------------------------------------
3608 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3609 implicit real*8 (a-h,o-z)
3610 include 'DIMENSIONS'
3614 include 'COMMON.CONTROL'
3615 include 'COMMON.IOUNITS'
3616 include 'COMMON.GEO'
3617 include 'COMMON.VAR'
3618 include 'COMMON.LOCAL'
3619 include 'COMMON.CHAIN'
3620 include 'COMMON.DERIV'
3621 include 'COMMON.INTERACT'
3622 include 'COMMON.CONTACTS'
3623 include 'COMMON.TORSION'
3624 include 'COMMON.VECTORS'
3625 include 'COMMON.FFIELD'
3626 include 'COMMON.TIME1'
3627 include 'COMMON.SPLITELE'
3628 include 'COMMON.SHIELD'
3629 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3630 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3631 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3632 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3633 & gmuij2(4),gmuji2(4)
3634 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3635 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3637 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3639 double precision scal_el /1.0d0/
3641 double precision scal_el /0.5d0/
3644 C 13-go grudnia roku pamietnego...
3645 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3646 & 0.0d0,1.0d0,0.0d0,
3647 & 0.0d0,0.0d0,1.0d0/
3648 c time00=MPI_Wtime()
3649 cd write (iout,*) "eelecij",i,j
3653 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3654 aaa=app(iteli,itelj)
3655 bbb=bpp(iteli,itelj)
3656 ael6i=ael6(iteli,itelj)
3657 ael3i=ael3(iteli,itelj)
3661 dx_normj=dc_norm(1,j)
3662 dy_normj=dc_norm(2,j)
3663 dz_normj=dc_norm(3,j)
3664 C xj=c(1,j)+0.5D0*dxj-xmedi
3665 C yj=c(2,j)+0.5D0*dyj-ymedi
3666 C zj=c(3,j)+0.5D0*dzj-zmedi
3671 if (xj.lt.0) xj=xj+boxxsize
3673 if (yj.lt.0) yj=yj+boxysize
3675 if (zj.lt.0) zj=zj+boxzsize
3676 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3677 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3685 xj=xj_safe+xshift*boxxsize
3686 yj=yj_safe+yshift*boxysize
3687 zj=zj_safe+zshift*boxzsize
3688 dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3689 if(dist_temp.lt.dist_init) then
3699 if (isubchap.eq.1) then
3708 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3710 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3711 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3712 C Condition for being inside the proper box
3713 c if ((xj.gt.((0.5d0)*boxxsize)).or.
3714 c & (xj.lt.((-0.5d0)*boxxsize))) then
3718 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3719 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3720 C Condition for being inside the proper box
3721 c if ((yj.gt.((0.5d0)*boxysize)).or.
3722 c & (yj.lt.((-0.5d0)*boxysize))) then
3726 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3727 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3728 C Condition for being inside the proper box
3729 c if ((zj.gt.((0.5d0)*boxzsize)).or.
3730 c & (zj.lt.((-0.5d0)*boxzsize))) then
3733 C endif !endPBC condintion
3737 rij=xj*xj+yj*yj+zj*zj
3739 sss=sscale(sqrt(rij))
3740 sssgrad=sscagrad(sqrt(rij))
3741 c if (sss.gt.0.0d0) then
3747 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3748 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3749 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3750 fac=cosa-3.0D0*cosb*cosg
3752 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3753 if (j.eq.i+2) ev1=scal_el*ev1
3758 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3762 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3763 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3764 if (shield_mode.gt.0) then
3767 el1=el1*fac_shield(i)**2*fac_shield(j)**2
3768 el2=el2*fac_shield(i)**2*fac_shield(j)**2
3777 evdw1=evdw1+evdwij*sss
3778 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3779 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3780 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
3781 cd & xmedi,ymedi,zmedi,xj,yj,zj
3783 if (energy_dec) then
3784 write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3786 &,iteli,itelj,aaa,evdw1
3787 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3788 &fac_shield(i),fac_shield(j)
3792 C Calculate contributions to the Cartesian gradient.
3795 facvdw=-6*rrmij*(ev1+evdwij)*sss
3796 facel=-3*rrmij*(el1+eesij)
3803 * Radial derivatives. First process both termini of the fragment (i,j)
3808 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3809 & (shield_mode.gt.0)) then
3811 do ilist=1,ishield_list(i)
3812 iresshield=shield_list(ilist,i)
3814 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3816 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3818 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3819 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3820 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3821 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3822 C if (iresshield.gt.i) then
3823 C do ishi=i+1,iresshield-1
3824 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3825 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3829 C do ishi=iresshield,i
3830 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3831 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3837 do ilist=1,ishield_list(j)
3838 iresshield=shield_list(ilist,j)
3840 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3842 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3844 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3845 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3847 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3848 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3849 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3850 C if (iresshield.gt.j) then
3851 C do ishi=j+1,iresshield-1
3852 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3853 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3857 C do ishi=iresshield,j
3858 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3859 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3866 gshieldc(k,i)=gshieldc(k,i)+
3867 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
3868 gshieldc(k,j)=gshieldc(k,j)+
3869 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
3870 gshieldc(k,i-1)=gshieldc(k,i-1)+
3871 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
3872 gshieldc(k,j-1)=gshieldc(k,j-1)+
3873 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
3878 c ghalf=0.5D0*ggg(k)
3879 c gelc(k,i)=gelc(k,i)+ghalf
3880 c gelc(k,j)=gelc(k,j)+ghalf
3882 c 9/28/08 AL Gradient compotents will be summed only at the end
3883 C print *,"before", gelc_long(1,i), gelc_long(1,j)
3885 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3886 C & +grad_shield(k,j)*eesij/fac_shield(j)
3887 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3888 C & +grad_shield(k,i)*eesij/fac_shield(i)
3889 C gelc_long(k,i-1)=gelc_long(k,i-1)
3890 C & +grad_shield(k,i)*eesij/fac_shield(i)
3891 C gelc_long(k,j-1)=gelc_long(k,j-1)
3892 C & +grad_shield(k,j)*eesij/fac_shield(j)
3894 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3897 * Loop over residues i+1 thru j-1.
3901 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
3904 if (sss.gt.0.0) then
3905 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3906 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3907 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3914 c ghalf=0.5D0*ggg(k)
3915 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3916 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3918 c 9/28/08 AL Gradient compotents will be summed only at the end
3920 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3921 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3924 * Loop over residues i+1 thru j-1.
3928 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3933 facvdw=(ev1+evdwij)*sss
3936 fac=-3*rrmij*(facvdw+facvdw+facel)
3941 * Radial derivatives. First process both termini of the fragment (i,j)
3944 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
3946 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
3948 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
3950 c ghalf=0.5D0*ggg(k)
3951 c gelc(k,i)=gelc(k,i)+ghalf
3952 c gelc(k,j)=gelc(k,j)+ghalf
3954 c 9/28/08 AL Gradient compotents will be summed only at the end
3956 gelc_long(k,j)=gelc(k,j)+ggg(k)
3957 gelc_long(k,i)=gelc(k,i)-ggg(k)
3960 * Loop over residues i+1 thru j-1.
3964 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
3967 c 9/28/08 AL Gradient compotents will be summed only at the end
3968 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
3969 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
3970 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
3972 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3973 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3979 ecosa=2.0D0*fac3*fac1+fac4
3982 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3983 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3985 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3986 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3988 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3989 cd & (dcosg(k),k=1,3)
3991 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
3992 & fac_shield(i)**2*fac_shield(j)**2
3995 c ghalf=0.5D0*ggg(k)
3996 c gelc(k,i)=gelc(k,i)+ghalf
3997 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3998 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3999 c gelc(k,j)=gelc(k,j)+ghalf
4000 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4001 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4005 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4008 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4011 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4012 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4013 & *fac_shield(i)**2*fac_shield(j)**2
4015 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4016 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4017 & *fac_shield(i)**2*fac_shield(j)**2
4018 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4019 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4021 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4025 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4026 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4027 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4029 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4030 C energy of a peptide unit is assumed in the form of a second-order
4031 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4032 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4033 C are computed for EVERY pair of non-contiguous peptide groups.
4036 if (j.lt.nres-1) then
4048 muij(kkk)=mu(k,i)*mu(l,j)
4049 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4051 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4052 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4053 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4054 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4055 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4056 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4060 cd write (iout,*) 'EELEC: i',i,' j',j
4061 cd write (iout,*) 'j',j,' j1',j1,' j2',j2
4062 cd write(iout,*) 'muij',muij
4063 ury=scalar(uy(1,i),erij)
4064 urz=scalar(uz(1,i),erij)
4065 vry=scalar(uy(1,j),erij)
4066 vrz=scalar(uz(1,j),erij)
4067 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4068 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4069 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4070 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4071 fac=dsqrt(-ael6i)*r3ij
4076 cd write (iout,'(4i5,4f10.5)')
4077 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4078 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4079 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4080 cd & uy(:,j),uz(:,j)
4081 cd write (iout,'(4f10.5)')
4082 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4083 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4084 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4085 cd write (iout,'(9f10.5/)')
4086 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4087 C Derivatives of the elements of A in virtual-bond vectors
4088 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4090 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4091 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4092 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4093 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4094 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4095 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4096 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4097 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4098 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4099 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4100 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4101 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4103 C Compute radial contributions to the gradient
4121 C Add the contributions coming from er
4124 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4125 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4126 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4127 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4130 C Derivatives in DC(i)
4131 cgrad ghalf1=0.5d0*agg(k,1)
4132 cgrad ghalf2=0.5d0*agg(k,2)
4133 cgrad ghalf3=0.5d0*agg(k,3)
4134 cgrad ghalf4=0.5d0*agg(k,4)
4135 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4136 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4137 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4138 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4139 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4140 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4141 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4142 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4143 C Derivatives in DC(i+1)
4144 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4145 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4146 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4147 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4148 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4149 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4150 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4151 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4152 C Derivatives in DC(j)
4153 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4154 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4155 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4156 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4157 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4158 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4159 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4160 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4161 C Derivatives in DC(j+1) or DC(nres-1)
4162 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4163 & -3.0d0*vryg(k,3)*ury)
4164 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4165 & -3.0d0*vrzg(k,3)*ury)
4166 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4167 & -3.0d0*vryg(k,3)*urz)
4168 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4169 & -3.0d0*vrzg(k,3)*urz)
4170 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4172 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4185 aggi(k,l)=-aggi(k,l)
4186 aggi1(k,l)=-aggi1(k,l)
4187 aggj(k,l)=-aggj(k,l)
4188 aggj1(k,l)=-aggj1(k,l)
4191 if (j.lt.nres-1) then
4197 aggi(k,l)=-aggi(k,l)
4198 aggi1(k,l)=-aggi1(k,l)
4199 aggj(k,l)=-aggj(k,l)
4200 aggj1(k,l)=-aggj1(k,l)
4211 aggi(k,l)=-aggi(k,l)
4212 aggi1(k,l)=-aggi1(k,l)
4213 aggj(k,l)=-aggj(k,l)
4214 aggj1(k,l)=-aggj1(k,l)
4219 IF (wel_loc.gt.0.0d0) THEN
4220 C Contribution to the local-electrostatic energy coming from the i-j pair
4221 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4223 if (shield_mode.eq.0) then
4230 eel_loc_ij=eel_loc_ij
4231 & *fac_shield(i)*fac_shield(j)
4232 C Now derivative over eel_loc
4233 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4234 & (shield_mode.gt.0)) then
4237 do ilist=1,ishield_list(i)
4238 iresshield=shield_list(ilist,i)
4240 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4243 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4245 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4246 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4250 do ilist=1,ishield_list(j)
4251 iresshield=shield_list(ilist,j)
4253 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4256 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4258 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4259 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4266 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4267 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4268 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4269 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4270 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4271 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4272 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4273 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4278 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4279 c & ' eel_loc_ij',eel_loc_ij
4280 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4281 C Calculate patrial derivative for theta angle
4283 geel_loc_ij=(a22*gmuij1(1)
4287 & *fac_shield(i)*fac_shield(j)
4288 c write(iout,*) "derivative over thatai"
4289 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4291 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4292 & geel_loc_ij*wel_loc
4293 c write(iout,*) "derivative over thatai-1"
4294 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4301 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4302 & geel_loc_ij*wel_loc
4303 & *fac_shield(i)*fac_shield(j)
4305 c Derivative over j residue
4306 geel_loc_ji=a22*gmuji1(1)
4310 c write(iout,*) "derivative over thataj"
4311 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4314 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4315 & geel_loc_ji*wel_loc
4316 & *fac_shield(i)*fac_shield(j)
4323 c write(iout,*) "derivative over thataj-1"
4324 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4326 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4327 & geel_loc_ji*wel_loc
4328 & *fac_shield(i)*fac_shield(j)
4330 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4332 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4333 & 'eelloc',i,j,eel_loc_ij
4334 c if (eel_loc_ij.ne.0)
4335 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4336 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4338 eel_loc=eel_loc+eel_loc_ij
4339 C Partial derivatives in virtual-bond dihedral angles gamma
4341 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4342 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4343 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4344 & *fac_shield(i)*fac_shield(j)
4346 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4347 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4348 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4349 & *fac_shield(i)*fac_shield(j)
4350 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4352 ggg(l)=(agg(l,1)*muij(1)+
4353 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4354 & *fac_shield(i)*fac_shield(j)
4355 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4356 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4357 cgrad ghalf=0.5d0*ggg(l)
4358 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4359 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4363 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4366 C Remaining derivatives of eello
4368 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4369 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4370 & *fac_shield(i)*fac_shield(j)
4372 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4373 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4374 & *fac_shield(i)*fac_shield(j)
4376 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4377 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4378 & *fac_shield(i)*fac_shield(j)
4380 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4381 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4382 & *fac_shield(i)*fac_shield(j)
4386 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4387 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4388 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4389 & .and. num_conti.le.maxconts) then
4390 c write (iout,*) i,j," entered corr"
4392 C Calculate the contact function. The ith column of the array JCONT will
4393 C contain the numbers of atoms that make contacts with the atom I (of numbers
4394 C greater than I). The arrays FACONT and GACONT will contain the values of
4395 C the contact function and its derivative.
4396 c r0ij=1.02D0*rpp(iteli,itelj)
4397 c r0ij=1.11D0*rpp(iteli,itelj)
4398 r0ij=2.20D0*rpp(iteli,itelj)
4399 c r0ij=1.55D0*rpp(iteli,itelj)
4400 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4401 if (fcont.gt.0.0D0) then
4402 num_conti=num_conti+1
4403 if (num_conti.gt.maxconts) then
4404 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4405 & ' will skip next contacts for this conf.'
4407 jcont_hb(num_conti,i)=j
4408 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4409 cd & " jcont_hb",jcont_hb(num_conti,i)
4410 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4411 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4412 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4414 d_cont(num_conti,i)=rij
4415 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4416 C --- Electrostatic-interaction matrix ---
4417 a_chuj(1,1,num_conti,i)=a22
4418 a_chuj(1,2,num_conti,i)=a23
4419 a_chuj(2,1,num_conti,i)=a32
4420 a_chuj(2,2,num_conti,i)=a33
4421 C --- Gradient of rij
4423 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4430 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4431 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4432 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4433 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4434 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4439 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4440 C Calculate contact energies
4442 wij=cosa-3.0D0*cosb*cosg
4445 c fac3=dsqrt(-ael6i)/r0ij**3
4446 fac3=dsqrt(-ael6i)*r3ij
4447 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4448 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4449 if (ees0tmp.gt.0) then
4450 ees0pij=dsqrt(ees0tmp)
4454 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4455 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4456 if (ees0tmp.gt.0) then
4457 ees0mij=dsqrt(ees0tmp)
4462 if (shield_mode.eq.0) then
4466 ees0plist(num_conti,i)=j
4467 C fac_shield(i)=0.4d0
4468 C fac_shield(j)=0.6d0
4470 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4471 & *fac_shield(i)*fac_shield(j)
4472 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4473 & *fac_shield(i)*fac_shield(j)
4474 C Diagnostics. Comment out or remove after debugging!
4475 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4476 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4477 c ees0m(num_conti,i)=0.0D0
4479 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4480 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4481 C Angular derivatives of the contact function
4482 ees0pij1=fac3/ees0pij
4483 ees0mij1=fac3/ees0mij
4484 fac3p=-3.0D0*fac3*rrmij
4485 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4486 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4488 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4489 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4490 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4491 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4492 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4493 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4494 ecosap=ecosa1+ecosa2
4495 ecosbp=ecosb1+ecosb2
4496 ecosgp=ecosg1+ecosg2
4497 ecosam=ecosa1-ecosa2
4498 ecosbm=ecosb1-ecosb2
4499 ecosgm=ecosg1-ecosg2
4508 facont_hb(num_conti,i)=fcont
4509 fprimcont=fprimcont/rij
4510 cd facont_hb(num_conti,i)=1.0D0
4511 C Following line is for diagnostics.
4514 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4515 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4518 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4519 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4521 gggp(1)=gggp(1)+ees0pijp*xj
4522 gggp(2)=gggp(2)+ees0pijp*yj
4523 gggp(3)=gggp(3)+ees0pijp*zj
4524 gggm(1)=gggm(1)+ees0mijp*xj
4525 gggm(2)=gggm(2)+ees0mijp*yj
4526 gggm(3)=gggm(3)+ees0mijp*zj
4527 C Derivatives due to the contact function
4528 gacont_hbr(1,num_conti,i)=fprimcont*xj
4529 gacont_hbr(2,num_conti,i)=fprimcont*yj
4530 gacont_hbr(3,num_conti,i)=fprimcont*zj
4533 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4534 c following the change of gradient-summation algorithm.
4536 cgrad ghalfp=0.5D0*gggp(k)
4537 cgrad ghalfm=0.5D0*gggm(k)
4538 gacontp_hb1(k,num_conti,i)=!ghalfp
4539 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4540 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4541 & *fac_shield(i)*fac_shield(j)
4543 gacontp_hb2(k,num_conti,i)=!ghalfp
4544 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4545 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4546 & *fac_shield(i)*fac_shield(j)
4548 gacontp_hb3(k,num_conti,i)=gggp(k)
4549 & *fac_shield(i)*fac_shield(j)
4551 gacontm_hb1(k,num_conti,i)=!ghalfm
4552 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4553 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4554 & *fac_shield(i)*fac_shield(j)
4556 gacontm_hb2(k,num_conti,i)=!ghalfm
4557 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4558 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4559 & *fac_shield(i)*fac_shield(j)
4561 gacontm_hb3(k,num_conti,i)=gggm(k)
4562 & *fac_shield(i)*fac_shield(j)
4565 C Diagnostics. Comment out or remove after debugging!
4567 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4568 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4569 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4570 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4571 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4572 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4575 endif ! num_conti.le.maxconts
4578 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4581 ghalf=0.5d0*agg(l,k)
4582 aggi(l,k)=aggi(l,k)+ghalf
4583 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4584 aggj(l,k)=aggj(l,k)+ghalf
4587 if (j.eq.nres-1 .and. i.lt.j-2) then
4590 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4595 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4598 C-----------------------------------------------------------------------------
4599 subroutine eturn3(i,eello_turn3)
4600 C Third- and fourth-order contributions from turns
4601 implicit real*8 (a-h,o-z)
4602 include 'DIMENSIONS'
4603 include 'COMMON.IOUNITS'
4604 include 'COMMON.GEO'
4605 include 'COMMON.VAR'
4606 include 'COMMON.LOCAL'
4607 include 'COMMON.CHAIN'
4608 include 'COMMON.DERIV'
4609 include 'COMMON.INTERACT'
4610 include 'COMMON.CONTACTS'
4611 include 'COMMON.TORSION'
4612 include 'COMMON.VECTORS'
4613 include 'COMMON.FFIELD'
4614 include 'COMMON.CONTROL'
4615 include 'COMMON.SHIELD'
4617 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4618 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4619 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4620 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4621 & auxgmat2(2,2),auxgmatt2(2,2)
4622 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4623 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4624 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4625 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4628 c write (iout,*) "eturn3",i,j,j1,j2
4633 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4635 C Third-order contributions
4642 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4643 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4644 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4645 c auxalary matices for theta gradient
4646 c auxalary matrix for i+1 and constant i+2
4647 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4648 c auxalary matrix for i+2 and constant i+1
4649 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4650 call transpose2(auxmat(1,1),auxmat1(1,1))
4651 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4652 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4653 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4654 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4655 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4656 if (shield_mode.eq.0) then
4663 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4664 & *fac_shield(i)*fac_shield(j)
4665 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4666 & *fac_shield(i)*fac_shield(j)
4667 C Derivatives in theta
4668 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4669 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4670 & *fac_shield(i)*fac_shield(j)
4671 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4672 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4673 & *fac_shield(i)*fac_shield(j)
4676 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4677 C Derivatives in shield mode
4678 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4679 & (shield_mode.gt.0)) then
4682 do ilist=1,ishield_list(i)
4683 iresshield=shield_list(ilist,i)
4685 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4687 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4689 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4690 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4694 do ilist=1,ishield_list(j)
4695 iresshield=shield_list(ilist,j)
4697 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4699 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4701 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4702 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4709 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4710 & grad_shield(k,i)*eello_t3/fac_shield(i)
4711 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4712 & grad_shield(k,j)*eello_t3/fac_shield(j)
4713 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4714 & grad_shield(k,i)*eello_t3/fac_shield(i)
4715 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4716 & grad_shield(k,j)*eello_t3/fac_shield(j)
4720 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4721 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
4722 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
4723 cd & ' eello_turn3_num',4*eello_turn3_num
4724 C Derivatives in gamma(i)
4725 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4726 call transpose2(auxmat2(1,1),auxmat3(1,1))
4727 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4728 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4729 & *fac_shield(i)*fac_shield(j)
4730 C Derivatives in gamma(i+1)
4731 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4732 call transpose2(auxmat2(1,1),auxmat3(1,1))
4733 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4734 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4735 & +0.5d0*(pizda(1,1)+pizda(2,2))
4736 & *fac_shield(i)*fac_shield(j)
4737 C Cartesian derivatives
4739 c ghalf1=0.5d0*agg(l,1)
4740 c ghalf2=0.5d0*agg(l,2)
4741 c ghalf3=0.5d0*agg(l,3)
4742 c ghalf4=0.5d0*agg(l,4)
4743 a_temp(1,1)=aggi(l,1)!+ghalf1
4744 a_temp(1,2)=aggi(l,2)!+ghalf2
4745 a_temp(2,1)=aggi(l,3)!+ghalf3
4746 a_temp(2,2)=aggi(l,4)!+ghalf4
4747 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4748 gcorr3_turn(l,i)=gcorr3_turn(l,i)
4749 & +0.5d0*(pizda(1,1)+pizda(2,2))
4750 & *fac_shield(i)*fac_shield(j)
4752 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4753 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4754 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4755 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4756 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4757 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4758 & +0.5d0*(pizda(1,1)+pizda(2,2))
4759 & *fac_shield(i)*fac_shield(j)
4760 a_temp(1,1)=aggj(l,1)!+ghalf1
4761 a_temp(1,2)=aggj(l,2)!+ghalf2
4762 a_temp(2,1)=aggj(l,3)!+ghalf3
4763 a_temp(2,2)=aggj(l,4)!+ghalf4
4764 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4765 gcorr3_turn(l,j)=gcorr3_turn(l,j)
4766 & +0.5d0*(pizda(1,1)+pizda(2,2))
4767 & *fac_shield(i)*fac_shield(j)
4768 a_temp(1,1)=aggj1(l,1)
4769 a_temp(1,2)=aggj1(l,2)
4770 a_temp(2,1)=aggj1(l,3)
4771 a_temp(2,2)=aggj1(l,4)
4772 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4773 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4774 & +0.5d0*(pizda(1,1)+pizda(2,2))
4775 & *fac_shield(i)*fac_shield(j)
4779 C-------------------------------------------------------------------------------
4780 subroutine eturn4(i,eello_turn4)
4781 C Third- and fourth-order contributions from turns
4782 implicit real*8 (a-h,o-z)
4783 include 'DIMENSIONS'
4784 include 'COMMON.IOUNITS'
4785 include 'COMMON.GEO'
4786 include 'COMMON.VAR'
4787 include 'COMMON.LOCAL'
4788 include 'COMMON.CHAIN'
4789 include 'COMMON.DERIV'
4790 include 'COMMON.INTERACT'
4791 include 'COMMON.CONTACTS'
4792 include 'COMMON.TORSION'
4793 include 'COMMON.VECTORS'
4794 include 'COMMON.FFIELD'
4795 include 'COMMON.CONTROL'
4796 include 'COMMON.SHIELD'
4798 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4799 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4800 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4801 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4802 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
4803 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4804 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4805 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4806 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4807 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4808 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4811 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4813 C Fourth-order contributions
4821 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4822 cd call checkint_turn4(i,a_temp,eello_turn4_num)
4823 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4824 c write(iout,*)"WCHODZE W PROGRAM"
4829 iti1=itortyp(itype(i+1))
4830 iti2=itortyp(itype(i+2))
4831 iti3=itortyp(itype(i+3))
4832 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4833 call transpose2(EUg(1,1,i+1),e1t(1,1))
4834 call transpose2(Eug(1,1,i+2),e2t(1,1))
4835 call transpose2(Eug(1,1,i+3),e3t(1,1))
4836 C Ematrix derivative in theta
4837 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4838 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4839 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4840 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4841 c eta1 in derivative theta
4842 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4843 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4844 c auxgvec is derivative of Ub2 so i+3 theta
4845 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4846 c auxalary matrix of E i+1
4847 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4850 s1=scalar2(b1(1,i+2),auxvec(1))
4851 c derivative of theta i+2 with constant i+3
4852 gs23=scalar2(gtb1(1,i+2),auxvec(1))
4853 c derivative of theta i+2 with constant i+2
4854 gs32=scalar2(b1(1,i+2),auxgvec(1))
4855 c derivative of E matix in theta of i+1
4856 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4858 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4859 c ea31 in derivative theta
4860 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4861 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4862 c auxilary matrix auxgvec of Ub2 with constant E matirx
4863 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4864 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4865 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4869 s2=scalar2(b1(1,i+1),auxvec(1))
4870 c derivative of theta i+1 with constant i+3
4871 gs13=scalar2(gtb1(1,i+1),auxvec(1))
4872 c derivative of theta i+2 with constant i+1
4873 gs21=scalar2(b1(1,i+1),auxgvec(1))
4874 c derivative of theta i+3 with constant i+1
4875 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4876 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4878 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4879 c two derivatives over diffetent matrices
4880 c gtae3e2 is derivative over i+3
4881 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4882 c ae3gte2 is derivative over i+2
4883 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4884 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4885 c three possible derivative over theta E matices
4887 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4889 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4891 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4892 s3=0.5d0*(pizda(1,1)+pizda(2,2))
4894 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4895 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4896 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4897 if (shield_mode.eq.0) then
4904 eello_turn4=eello_turn4-(s1+s2+s3)
4905 & *fac_shield(i)*fac_shield(j)
4906 eello_t4=-(s1+s2+s3)
4907 & *fac_shield(i)*fac_shield(j)
4908 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
4909 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
4910 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
4911 C Now derivative over shield:
4912 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4913 & (shield_mode.gt.0)) then
4916 do ilist=1,ishield_list(i)
4917 iresshield=shield_list(ilist,i)
4919 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4921 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4923 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4924 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4928 do ilist=1,ishield_list(j)
4929 iresshield=shield_list(ilist,j)
4931 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4933 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
4935 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4936 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
4943 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
4944 & grad_shield(k,i)*eello_t4/fac_shield(i)
4945 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
4946 & grad_shield(k,j)*eello_t4/fac_shield(j)
4947 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
4948 & grad_shield(k,i)*eello_t4/fac_shield(i)
4949 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
4950 & grad_shield(k,j)*eello_t4/fac_shield(j)
4959 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4960 cd & ' eello_turn4_num',8*eello_turn4_num
4962 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4963 & -(gs13+gsE13+gsEE1)*wturn4
4964 & *fac_shield(i)*fac_shield(j)
4965 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
4966 & -(gs23+gs21+gsEE2)*wturn4
4967 & *fac_shield(i)*fac_shield(j)
4969 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
4970 & -(gs32+gsE31+gsEE3)*wturn4
4971 & *fac_shield(i)*fac_shield(j)
4973 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
4976 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4977 & 'eturn4',i,j,-(s1+s2+s3)
4978 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4979 c & ' eello_turn4_num',8*eello_turn4_num
4980 C Derivatives in gamma(i)
4981 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4982 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4983 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4984 s1=scalar2(b1(1,i+2),auxvec(1))
4985 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4986 s3=0.5d0*(pizda(1,1)+pizda(2,2))
4987 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4988 & *fac_shield(i)*fac_shield(j)
4989 C Derivatives in gamma(i+1)
4990 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4991 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4992 s2=scalar2(b1(1,i+1),auxvec(1))
4993 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4994 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4995 s3=0.5d0*(pizda(1,1)+pizda(2,2))
4996 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4997 & *fac_shield(i)*fac_shield(j)
4998 C Derivatives in gamma(i+2)
4999 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5000 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5001 s1=scalar2(b1(1,i+2),auxvec(1))
5002 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5003 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5004 s2=scalar2(b1(1,i+1),auxvec(1))
5005 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5006 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5007 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5008 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5009 & *fac_shield(i)*fac_shield(j)
5010 C Cartesian derivatives
5011 C Derivatives of this turn contributions in DC(i+2)
5012 if (j.lt.nres-1) then
5014 a_temp(1,1)=agg(l,1)
5015 a_temp(1,2)=agg(l,2)
5016 a_temp(2,1)=agg(l,3)
5017 a_temp(2,2)=agg(l,4)
5018 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5019 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5020 s1=scalar2(b1(1,i+2),auxvec(1))
5021 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5022 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5023 s2=scalar2(b1(1,i+1),auxvec(1))
5024 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5025 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5026 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5028 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5029 & *fac_shield(i)*fac_shield(j)
5032 C Remaining derivatives of this turn contribution
5034 a_temp(1,1)=aggi(l,1)
5035 a_temp(1,2)=aggi(l,2)
5036 a_temp(2,1)=aggi(l,3)
5037 a_temp(2,2)=aggi(l,4)
5038 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5039 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5040 s1=scalar2(b1(1,i+2),auxvec(1))
5041 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5042 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5043 s2=scalar2(b1(1,i+1),auxvec(1))
5044 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5045 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5046 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5047 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5048 & *fac_shield(i)*fac_shield(j)
5049 a_temp(1,1)=aggi1(l,1)
5050 a_temp(1,2)=aggi1(l,2)
5051 a_temp(2,1)=aggi1(l,3)
5052 a_temp(2,2)=aggi1(l,4)
5053 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5054 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5055 s1=scalar2(b1(1,i+2),auxvec(1))
5056 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5057 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5058 s2=scalar2(b1(1,i+1),auxvec(1))
5059 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5060 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5061 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5062 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5063 & *fac_shield(i)*fac_shield(j)
5064 a_temp(1,1)=aggj(l,1)
5065 a_temp(1,2)=aggj(l,2)
5066 a_temp(2,1)=aggj(l,3)
5067 a_temp(2,2)=aggj(l,4)
5068 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5069 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5070 s1=scalar2(b1(1,i+2),auxvec(1))
5071 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5072 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5073 s2=scalar2(b1(1,i+1),auxvec(1))
5074 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5075 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5076 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5077 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5078 & *fac_shield(i)*fac_shield(j)
5079 a_temp(1,1)=aggj1(l,1)
5080 a_temp(1,2)=aggj1(l,2)
5081 a_temp(2,1)=aggj1(l,3)
5082 a_temp(2,2)=aggj1(l,4)
5083 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5084 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5085 s1=scalar2(b1(1,i+2),auxvec(1))
5086 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5087 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5088 s2=scalar2(b1(1,i+1),auxvec(1))
5089 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5090 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5091 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5092 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5093 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5094 & *fac_shield(i)*fac_shield(j)
5098 C-----------------------------------------------------------------------------
5099 subroutine vecpr(u,v,w)
5100 implicit real*8(a-h,o-z)
5101 dimension u(3),v(3),w(3)
5102 w(1)=u(2)*v(3)-u(3)*v(2)
5103 w(2)=-u(1)*v(3)+u(3)*v(1)
5104 w(3)=u(1)*v(2)-u(2)*v(1)
5107 C-----------------------------------------------------------------------------
5108 subroutine unormderiv(u,ugrad,unorm,ungrad)
5109 C This subroutine computes the derivatives of a normalized vector u, given
5110 C the derivatives computed without normalization conditions, ugrad. Returns
5113 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5114 double precision vec(3)
5115 double precision scalar
5117 c write (2,*) 'ugrad',ugrad
5120 vec(i)=scalar(ugrad(1,i),u(1))
5122 c write (2,*) 'vec',vec
5125 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5128 c write (2,*) 'ungrad',ungrad
5131 C-----------------------------------------------------------------------------
5132 subroutine escp_soft_sphere(evdw2,evdw2_14)
5134 C This subroutine calculates the excluded-volume interaction energy between
5135 C peptide-group centers and side chains and its gradient in virtual-bond and
5136 C side-chain vectors.
5138 implicit real*8 (a-h,o-z)
5139 include 'DIMENSIONS'
5140 include 'COMMON.GEO'
5141 include 'COMMON.VAR'
5142 include 'COMMON.LOCAL'
5143 include 'COMMON.CHAIN'
5144 include 'COMMON.DERIV'
5145 include 'COMMON.INTERACT'
5146 include 'COMMON.FFIELD'
5147 include 'COMMON.IOUNITS'
5148 include 'COMMON.CONTROL'
5153 cd print '(a)','Enter ESCP'
5154 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5158 do i=iatscp_s,iatscp_e
5159 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5161 xi=0.5D0*(c(1,i)+c(1,i+1))
5162 yi=0.5D0*(c(2,i)+c(2,i+1))
5163 zi=0.5D0*(c(3,i)+c(3,i+1))
5164 C Return atom into box, boxxsize is size of box in x dimension
5166 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5167 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5168 C Condition for being inside the proper box
5169 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5170 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5174 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5175 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5176 C Condition for being inside the proper box
5177 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5178 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5182 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5183 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5184 cC Condition for being inside the proper box
5185 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5186 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5190 if (xi.lt.0) xi=xi+boxxsize
5192 if (yi.lt.0) yi=yi+boxysize
5194 if (zi.lt.0) zi=zi+boxzsize
5195 C xi=xi+xshift*boxxsize
5196 C yi=yi+yshift*boxysize
5197 C zi=zi+zshift*boxzsize
5198 do iint=1,nscp_gr(i)
5200 do j=iscpstart(i,iint),iscpend(i,iint)
5201 if (itype(j).eq.ntyp1) cycle
5202 itypj=iabs(itype(j))
5203 C Uncomment following three lines for SC-p interactions
5207 C Uncomment following three lines for Ca-p interactions
5212 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5213 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5214 C Condition for being inside the proper box
5215 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5216 c & (xj.lt.((-0.5d0)*boxxsize))) then
5220 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5221 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5222 cC Condition for being inside the proper box
5223 c if ((yj.gt.((0.5d0)*boxysize)).or.
5224 c & (yj.lt.((-0.5d0)*boxysize))) then
5228 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5229 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5230 C Condition for being inside the proper box
5231 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5232 c & (zj.lt.((-0.5d0)*boxzsize))) then
5235 if (xj.lt.0) xj=xj+boxxsize
5237 if (yj.lt.0) yj=yj+boxysize
5239 if (zj.lt.0) zj=zj+boxzsize
5240 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5248 xj=xj_safe+xshift*boxxsize
5249 yj=yj_safe+yshift*boxysize
5250 zj=zj_safe+zshift*boxzsize
5251 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5252 if(dist_temp.lt.dist_init) then
5262 if (subchap.eq.1) then
5275 rij=xj*xj+yj*yj+zj*zj
5279 if (rij.lt.r0ijsq) then
5280 evdwij=0.25d0*(rij-r0ijsq)**2
5288 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5293 cgrad if (j.lt.i) then
5294 cd write (iout,*) 'j<i'
5295 C Uncomment following three lines for SC-p interactions
5297 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5300 cd write (iout,*) 'j>i'
5302 cgrad ggg(k)=-ggg(k)
5303 C Uncomment following line for SC-p interactions
5304 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5308 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5310 cgrad kstart=min0(i+1,j)
5311 cgrad kend=max0(i-1,j-1)
5312 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5313 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5314 cgrad do k=kstart,kend
5316 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5320 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5321 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5332 C-----------------------------------------------------------------------------
5333 subroutine escp(evdw2,evdw2_14)
5335 C This subroutine calculates the excluded-volume interaction energy between
5336 C peptide-group centers and side chains and its gradient in virtual-bond and
5337 C side-chain vectors.
5339 implicit real*8 (a-h,o-z)
5340 include 'DIMENSIONS'
5341 include 'COMMON.GEO'
5342 include 'COMMON.VAR'
5343 include 'COMMON.LOCAL'
5344 include 'COMMON.CHAIN'
5345 include 'COMMON.DERIV'
5346 include 'COMMON.INTERACT'
5347 include 'COMMON.FFIELD'
5348 include 'COMMON.IOUNITS'
5349 include 'COMMON.CONTROL'
5350 include 'COMMON.SPLITELE'
5354 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5355 cd print '(a)','Enter ESCP'
5356 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5360 do i=iatscp_s,iatscp_e
5361 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5363 xi=0.5D0*(c(1,i)+c(1,i+1))
5364 yi=0.5D0*(c(2,i)+c(2,i+1))
5365 zi=0.5D0*(c(3,i)+c(3,i+1))
5367 if (xi.lt.0) xi=xi+boxxsize
5369 if (yi.lt.0) yi=yi+boxysize
5371 if (zi.lt.0) zi=zi+boxzsize
5372 c xi=xi+xshift*boxxsize
5373 c yi=yi+yshift*boxysize
5374 c zi=zi+zshift*boxzsize
5375 c print *,xi,yi,zi,'polozenie i'
5376 C Return atom into box, boxxsize is size of box in x dimension
5378 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5379 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5380 C Condition for being inside the proper box
5381 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5382 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5386 c print *,xi,boxxsize,"pierwszy"
5388 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5389 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5390 C Condition for being inside the proper box
5391 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5392 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5396 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5397 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5398 C Condition for being inside the proper box
5399 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5400 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5403 do iint=1,nscp_gr(i)
5405 do j=iscpstart(i,iint),iscpend(i,iint)
5406 itypj=iabs(itype(j))
5407 if (itypj.eq.ntyp1) cycle
5408 C Uncomment following three lines for SC-p interactions
5412 C Uncomment following three lines for Ca-p interactions
5417 if (xj.lt.0) xj=xj+boxxsize
5419 if (yj.lt.0) yj=yj+boxysize
5421 if (zj.lt.0) zj=zj+boxzsize
5423 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5424 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5425 C Condition for being inside the proper box
5426 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5427 c & (xj.lt.((-0.5d0)*boxxsize))) then
5431 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5432 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5433 cC Condition for being inside the proper box
5434 c if ((yj.gt.((0.5d0)*boxysize)).or.
5435 c & (yj.lt.((-0.5d0)*boxysize))) then
5439 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5440 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5441 C Condition for being inside the proper box
5442 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5443 c & (zj.lt.((-0.5d0)*boxzsize))) then
5446 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5447 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5455 xj=xj_safe+xshift*boxxsize
5456 yj=yj_safe+yshift*boxysize
5457 zj=zj_safe+zshift*boxzsize
5458 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5459 if(dist_temp.lt.dist_init) then
5469 if (subchap.eq.1) then
5478 c print *,xj,yj,zj,'polozenie j'
5479 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5481 sss=sscale(1.0d0/(dsqrt(rrij)))
5482 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5483 c if (sss.eq.0) print *,'czasem jest OK'
5484 if (sss.le.0.0d0) cycle
5485 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5487 e1=fac*fac*aad(itypj,iteli)
5488 e2=fac*bad(itypj,iteli)
5489 if (iabs(j-i) .le. 2) then
5492 evdw2_14=evdw2_14+(e1+e2)*sss
5495 evdw2=evdw2+evdwij*sss
5496 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5497 & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5500 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5502 fac=-(evdwij+e1)*rrij*sss
5503 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5507 cgrad if (j.lt.i) then
5508 cd write (iout,*) 'j<i'
5509 C Uncomment following three lines for SC-p interactions
5511 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5514 cd write (iout,*) 'j>i'
5516 cgrad ggg(k)=-ggg(k)
5517 C Uncomment following line for SC-p interactions
5518 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5519 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5523 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5525 cgrad kstart=min0(i+1,j)
5526 cgrad kend=max0(i-1,j-1)
5527 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5528 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5529 cgrad do k=kstart,kend
5531 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5535 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5536 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5538 c endif !endif for sscale cutoff
5548 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5549 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5550 gradx_scp(j,i)=expon*gradx_scp(j,i)
5553 C******************************************************************************
5557 C To save time the factor EXPON has been extracted from ALL components
5558 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5561 C******************************************************************************
5564 C--------------------------------------------------------------------------
5565 subroutine edis(ehpb)
5567 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5569 implicit real*8 (a-h,o-z)
5570 include 'DIMENSIONS'
5571 include 'COMMON.SBRIDGE'
5572 include 'COMMON.CHAIN'
5573 include 'COMMON.DERIV'
5574 include 'COMMON.VAR'
5575 include 'COMMON.INTERACT'
5576 include 'COMMON.IOUNITS'
5577 include 'COMMON.CONTROL'
5583 C write (iout,*) ,"link_end",link_end,constr_dist
5584 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5585 cd write(iout,*)'link_start=',link_start,' link_end=',link_end
5586 if (link_end.eq.0) return
5587 do i=link_start,link_end
5588 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5589 C CA-CA distance used in regularization of structure.
5592 C iii and jjj point to the residues for which the distance is assigned.
5593 if (ii.gt.nres) then
5600 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5601 c & dhpb(i),dhpb1(i),forcon(i)
5602 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5603 C distance and angle dependent SS bond potential.
5604 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5605 C & iabs(itype(jjj)).eq.1) then
5606 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5607 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5608 if (.not.dyn_ss .and. i.le.nss) then
5609 C 15/02/13 CC dynamic SSbond - additional check
5610 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5611 & iabs(itype(jjj)).eq.1) then
5612 call ssbond_ene(iii,jjj,eij)
5615 cd write (iout,*) "eij",eij
5616 cd & ' waga=',waga,' fac=',fac
5617 else if (ii.gt.nres .and. jj.gt.nres) then
5618 c Restraints from contact prediction
5620 if (constr_dist.eq.11) then
5621 ehpb=ehpb+fordepth(i)**4.0d0
5622 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5623 fac=fordepth(i)**4.0d0
5624 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5625 if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5626 & ehpb,fordepth(i),dd
5628 if (dhpb1(i).gt.0.0d0) then
5629 ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5630 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5631 c write (iout,*) "beta nmr",
5632 c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5636 C Get the force constant corresponding to this distance.
5638 C Calculate the contribution to energy.
5639 ehpb=ehpb+waga*rdis*rdis
5640 c write (iout,*) "beta reg",dd,waga*rdis*rdis
5642 C Evaluate gradient.
5648 ggg(j)=fac*(c(j,jj)-c(j,ii))
5651 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5652 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5655 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5656 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5659 C Calculate the distance between the two points and its difference from the
5662 if (constr_dist.eq.11) then
5663 ehpb=ehpb+fordepth(i)**4.0d0
5664 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5665 fac=fordepth(i)**4.0d0
5666 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5667 if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5668 & ehpb,fordepth(i),dd
5670 if (dhpb1(i).gt.0.0d0) then
5671 ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5672 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5673 c write (iout,*) "alph nmr",
5674 c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5677 C Get the force constant corresponding to this distance.
5679 C Calculate the contribution to energy.
5680 ehpb=ehpb+waga*rdis*rdis
5681 c write (iout,*) "alpha reg",dd,waga*rdis*rdis
5683 C Evaluate gradient.
5689 ggg(j)=fac*(c(j,jj)-c(j,ii))
5691 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5692 C If this is a SC-SC distance, we need to calculate the contributions to the
5693 C Cartesian gradient in the SC vectors (ghpbx).
5696 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5697 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5700 cgrad do j=iii,jjj-1
5702 cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5706 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5707 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5711 if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5714 C--------------------------------------------------------------------------
5715 subroutine ssbond_ene(i,j,eij)
5717 C Calculate the distance and angle dependent SS-bond potential energy
5718 C using a free-energy function derived based on RHF/6-31G** ab initio
5719 C calculations of diethyl disulfide.
5721 C A. Liwo and U. Kozlowska, 11/24/03
5723 implicit real*8 (a-h,o-z)
5724 include 'DIMENSIONS'
5725 include 'COMMON.SBRIDGE'
5726 include 'COMMON.CHAIN'
5727 include 'COMMON.DERIV'
5728 include 'COMMON.LOCAL'
5729 include 'COMMON.INTERACT'
5730 include 'COMMON.VAR'
5731 include 'COMMON.IOUNITS'
5732 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5733 itypi=iabs(itype(i))
5737 dxi=dc_norm(1,nres+i)
5738 dyi=dc_norm(2,nres+i)
5739 dzi=dc_norm(3,nres+i)
5740 c dsci_inv=dsc_inv(itypi)
5741 dsci_inv=vbld_inv(nres+i)
5742 itypj=iabs(itype(j))
5743 c dscj_inv=dsc_inv(itypj)
5744 dscj_inv=vbld_inv(nres+j)
5748 dxj=dc_norm(1,nres+j)
5749 dyj=dc_norm(2,nres+j)
5750 dzj=dc_norm(3,nres+j)
5751 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5756 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5757 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5758 om12=dxi*dxj+dyi*dyj+dzi*dzj
5760 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5761 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5767 deltat12=om2-om1+2.0d0
5769 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5770 & +akct*deltad*deltat12
5771 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5772 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5773 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5774 c & " deltat12",deltat12," eij",eij
5775 ed=2*akcm*deltad+akct*deltat12
5777 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5778 eom1=-2*akth*deltat1-pom1-om2*pom2
5779 eom2= 2*akth*deltat2+pom1-om1*pom2
5782 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5783 ghpbx(k,i)=ghpbx(k,i)-ggk
5784 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5785 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5786 ghpbx(k,j)=ghpbx(k,j)+ggk
5787 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5788 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5789 ghpbc(k,i)=ghpbc(k,i)-ggk
5790 ghpbc(k,j)=ghpbc(k,j)+ggk
5793 C Calculate the components of the gradient in DC and X
5797 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
5802 C--------------------------------------------------------------------------
5803 subroutine ebond(estr)
5805 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5807 implicit real*8 (a-h,o-z)
5808 include 'DIMENSIONS'
5809 include 'COMMON.LOCAL'
5810 include 'COMMON.GEO'
5811 include 'COMMON.INTERACT'
5812 include 'COMMON.DERIV'
5813 include 'COMMON.VAR'
5814 include 'COMMON.CHAIN'
5815 include 'COMMON.IOUNITS'
5816 include 'COMMON.NAMES'
5817 include 'COMMON.FFIELD'
5818 include 'COMMON.CONTROL'
5819 include 'COMMON.SETUP'
5820 double precision u(3),ud(3)
5823 do i=ibondp_start,ibondp_end
5824 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5825 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5827 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5828 c & *dc(j,i-1)/vbld(i)
5830 c if (energy_dec) write(iout,*)
5831 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5833 C Checking if it involves dummy (NH3+ or COO-) group
5834 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5835 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
5836 diff = vbld(i)-vbldpDUM
5838 C NO vbldp0 is the equlibrium lenght of spring for peptide group
5839 diff = vbld(i)-vbldp0
5841 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5842 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5845 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5847 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5850 estr=0.5d0*AKP*estr+estr1
5852 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5854 do i=ibond_start,ibond_end
5856 if (iti.ne.10 .and. iti.ne.ntyp1) then
5859 diff=vbld(i+nres)-vbldsc0(1,iti)
5860 if (energy_dec) write (iout,*)
5861 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5862 & AKSC(1,iti),AKSC(1,iti)*diff*diff
5863 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5865 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5869 diff=vbld(i+nres)-vbldsc0(j,iti)
5870 ud(j)=aksc(j,iti)*diff
5871 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5885 uprod2=uprod2*u(k)*u(k)
5889 usumsqder=usumsqder+ud(j)*uprod2
5891 estr=estr+uprod/usum
5893 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5901 C--------------------------------------------------------------------------
5902 subroutine ebend(etheta,ethetacnstr)
5904 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5905 C angles gamma and its derivatives in consecutive thetas and gammas.
5907 implicit real*8 (a-h,o-z)
5908 include 'DIMENSIONS'
5909 include 'COMMON.LOCAL'
5910 include 'COMMON.GEO'
5911 include 'COMMON.INTERACT'
5912 include 'COMMON.DERIV'
5913 include 'COMMON.VAR'
5914 include 'COMMON.CHAIN'
5915 include 'COMMON.IOUNITS'
5916 include 'COMMON.NAMES'
5917 include 'COMMON.FFIELD'
5918 include 'COMMON.CONTROL'
5919 include 'COMMON.TORCNSTR'
5920 common /calcthet/ term1,term2,termm,diffak,ratak,
5921 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5922 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5923 double precision y(2),z(2)
5925 c time11=dexp(-2*time)
5928 c write (*,'(a,i2)') 'EBEND ICG=',icg
5929 do i=ithet_start,ithet_end
5930 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5931 & .or.itype(i).eq.ntyp1) cycle
5932 C Zero the energy function and its derivative at 0 or pi.
5933 call splinthet(theta(i),0.5d0*delta,ss,ssd)
5935 ichir1=isign(1,itype(i-2))
5936 ichir2=isign(1,itype(i))
5937 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5938 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5939 if (itype(i-1).eq.10) then
5940 itype1=isign(10,itype(i-2))
5941 ichir11=isign(1,itype(i-2))
5942 ichir12=isign(1,itype(i-2))
5943 itype2=isign(10,itype(i))
5944 ichir21=isign(1,itype(i))
5945 ichir22=isign(1,itype(i))
5948 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5951 if (phii.ne.phii) phii=150.0
5961 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5964 if (phii1.ne.phii1) phii1=150.0
5976 C Calculate the "mean" value of theta from the part of the distribution
5977 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5978 C In following comments this theta will be referred to as t_c.
5979 thet_pred_mean=0.0d0
5981 athetk=athet(k,it,ichir1,ichir2)
5982 bthetk=bthet(k,it,ichir1,ichir2)
5984 athetk=athet(k,itype1,ichir11,ichir12)
5985 bthetk=bthet(k,itype2,ichir21,ichir22)
5987 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5988 c write(iout,*) 'chuj tu', y(k),z(k)
5990 dthett=thet_pred_mean*ssd
5991 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5992 C Derivatives of the "mean" values in gamma1 and gamma2.
5993 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5994 &+athet(2,it,ichir1,ichir2)*y(1))*ss
5995 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5996 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
5998 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5999 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6000 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6001 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6003 if (theta(i).gt.pi-delta) then
6004 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6006 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6007 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6008 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6010 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6012 else if (theta(i).lt.delta) then
6013 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6014 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6015 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6017 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6018 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6021 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6024 etheta=etheta+ethetai
6025 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6026 & 'ebend',i,ethetai,theta(i),itype(i)
6027 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6028 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6029 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6032 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
6033 do i=ithetaconstr_start,ithetaconstr_end
6034 itheta=itheta_constr(i)
6035 thetiii=theta(itheta)
6036 difi=pinorm(thetiii-theta_constr0(i))
6037 if (difi.gt.theta_drange(i)) then
6038 difi=difi-theta_drange(i)
6039 ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6040 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6041 & +for_thet_constr(i)*difi**3
6042 else if (difi.lt.-drange(i)) then
6044 ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6045 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6046 & +for_thet_constr(i)*difi**3
6050 if (energy_dec) then
6051 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6052 & i,itheta,rad2deg*thetiii,
6053 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
6054 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6055 & gloc(itheta+nphi-2,icg)
6059 C Ufff.... We've done all this!!!
6062 C---------------------------------------------------------------------------
6063 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6065 implicit real*8 (a-h,o-z)
6066 include 'DIMENSIONS'
6067 include 'COMMON.LOCAL'
6068 include 'COMMON.IOUNITS'
6069 common /calcthet/ term1,term2,termm,diffak,ratak,
6070 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6071 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6072 C Calculate the contributions to both Gaussian lobes.
6073 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6074 C The "polynomial part" of the "standard deviation" of this part of
6075 C the distributioni.
6076 ccc write (iout,*) thetai,thet_pred_mean
6079 sig=sig*thet_pred_mean+polthet(j,it)
6081 C Derivative of the "interior part" of the "standard deviation of the"
6082 C gamma-dependent Gaussian lobe in t_c.
6083 sigtc=3*polthet(3,it)
6085 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6088 C Set the parameters of both Gaussian lobes of the distribution.
6089 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6090 fac=sig*sig+sigc0(it)
6093 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6094 sigsqtc=-4.0D0*sigcsq*sigtc
6095 c print *,i,sig,sigtc,sigsqtc
6096 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6097 sigtc=-sigtc/(fac*fac)
6098 C Following variable is sigma(t_c)**(-2)
6099 sigcsq=sigcsq*sigcsq
6101 sig0inv=1.0D0/sig0i**2
6102 delthec=thetai-thet_pred_mean
6103 delthe0=thetai-theta0i
6104 term1=-0.5D0*sigcsq*delthec*delthec
6105 term2=-0.5D0*sig0inv*delthe0*delthe0
6106 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6107 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6108 C NaNs in taking the logarithm. We extract the largest exponent which is added
6109 C to the energy (this being the log of the distribution) at the end of energy
6110 C term evaluation for this virtual-bond angle.
6111 if (term1.gt.term2) then
6113 term2=dexp(term2-termm)
6117 term1=dexp(term1-termm)
6120 C The ratio between the gamma-independent and gamma-dependent lobes of
6121 C the distribution is a Gaussian function of thet_pred_mean too.
6122 diffak=gthet(2,it)-thet_pred_mean
6123 ratak=diffak/gthet(3,it)**2
6124 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6125 C Let's differentiate it in thet_pred_mean NOW.
6127 C Now put together the distribution terms to make complete distribution.
6128 termexp=term1+ak*term2
6129 termpre=sigc+ak*sig0i
6130 C Contribution of the bending energy from this theta is just the -log of
6131 C the sum of the contributions from the two lobes and the pre-exponential
6132 C factor. Simple enough, isn't it?
6133 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6134 C write (iout,*) 'termexp',termexp,termm,termpre,i
6135 C NOW the derivatives!!!
6136 C 6/6/97 Take into account the deformation.
6137 E_theta=(delthec*sigcsq*term1
6138 & +ak*delthe0*sig0inv*term2)/termexp
6139 E_tc=((sigtc+aktc*sig0i)/termpre
6140 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6141 & aktc*term2)/termexp)
6144 c-----------------------------------------------------------------------------
6145 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6146 implicit real*8 (a-h,o-z)
6147 include 'DIMENSIONS'
6148 include 'COMMON.LOCAL'
6149 include 'COMMON.IOUNITS'
6150 common /calcthet/ term1,term2,termm,diffak,ratak,
6151 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6152 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6153 delthec=thetai-thet_pred_mean
6154 delthe0=thetai-theta0i
6155 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6156 t3 = thetai-thet_pred_mean
6160 t14 = t12+t6*sigsqtc
6162 t21 = thetai-theta0i
6168 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6169 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6170 & *(-t12*t9-ak*sig0inv*t27)
6174 C--------------------------------------------------------------------------
6175 subroutine ebend(etheta,ethetacnstr)
6177 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6178 C angles gamma and its derivatives in consecutive thetas and gammas.
6179 C ab initio-derived potentials from
6180 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6182 implicit real*8 (a-h,o-z)
6183 include 'DIMENSIONS'
6184 include 'COMMON.LOCAL'
6185 include 'COMMON.GEO'
6186 include 'COMMON.INTERACT'
6187 include 'COMMON.DERIV'
6188 include 'COMMON.VAR'
6189 include 'COMMON.CHAIN'
6190 include 'COMMON.IOUNITS'
6191 include 'COMMON.NAMES'
6192 include 'COMMON.FFIELD'
6193 include 'COMMON.CONTROL'
6194 include 'COMMON.TORCNSTR'
6195 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6196 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6197 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6198 & sinph1ph2(maxdouble,maxdouble)
6199 logical lprn /.false./, lprn1 /.false./
6201 do i=ithet_start,ithet_end
6202 c print *,i,itype(i-1),itype(i),itype(i-2)
6203 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6204 & .or.itype(i).eq.ntyp1) cycle
6205 C print *,i,theta(i)
6206 if (iabs(itype(i+1)).eq.20) iblock=2
6207 if (iabs(itype(i+1)).ne.20) iblock=1
6211 theti2=0.5d0*theta(i)
6212 ityp2=ithetyp((itype(i-1)))
6214 coskt(k)=dcos(k*theti2)
6215 sinkt(k)=dsin(k*theti2)
6218 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6221 if (phii.ne.phii) phii=150.0
6225 ityp1=ithetyp((itype(i-2)))
6226 C propagation of chirality for glycine type
6228 cosph1(k)=dcos(k*phii)
6229 sinph1(k)=dsin(k*phii)
6234 ityp1=ithetyp((itype(i-2)))
6239 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6242 if (phii1.ne.phii1) phii1=150.0
6247 ityp3=ithetyp((itype(i)))
6249 cosph2(k)=dcos(k*phii1)
6250 sinph2(k)=dsin(k*phii1)
6254 ityp3=ithetyp((itype(i)))
6260 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6263 ccl=cosph1(l)*cosph2(k-l)
6264 ssl=sinph1(l)*sinph2(k-l)
6265 scl=sinph1(l)*cosph2(k-l)
6266 csl=cosph1(l)*sinph2(k-l)
6267 cosph1ph2(l,k)=ccl-ssl
6268 cosph1ph2(k,l)=ccl+ssl
6269 sinph1ph2(l,k)=scl+csl
6270 sinph1ph2(k,l)=scl-csl
6274 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6275 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6276 write (iout,*) "coskt and sinkt"
6278 write (iout,*) k,coskt(k),sinkt(k)
6282 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6283 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6286 & write (iout,*) "k",k,"
6287 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6288 & " ethetai",ethetai
6291 write (iout,*) "cosph and sinph"
6293 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6295 write (iout,*) "cosph1ph2 and sinph2ph2"
6298 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6299 & sinph1ph2(l,k),sinph1ph2(k,l)
6302 write(iout,*) "ethetai",ethetai
6307 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6308 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6309 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6310 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6311 ethetai=ethetai+sinkt(m)*aux
6312 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6313 dephii=dephii+k*sinkt(m)*(
6314 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6315 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6316 dephii1=dephii1+k*sinkt(m)*(
6317 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6318 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6320 & write (iout,*) "m",m," k",k," bbthet",
6321 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6322 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6323 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6324 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6325 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6328 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6329 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6330 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6331 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6333 & write(iout,*) "ethetai",ethetai
6334 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6338 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6339 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6340 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6341 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6342 ethetai=ethetai+sinkt(m)*aux
6343 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6344 dephii=dephii+l*sinkt(m)*(
6345 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6346 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6347 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6348 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6349 dephii1=dephii1+(k-l)*sinkt(m)*(
6350 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6351 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6352 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6353 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6355 write (iout,*) "m",m," k",k," l",l," ffthet",
6356 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6357 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6358 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6359 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6360 & " ethetai",ethetai
6361 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6362 & cosph1ph2(k,l)*sinkt(m),
6363 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6372 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6373 & i,theta(i)*rad2deg,phii*rad2deg,
6374 & phii1*rad2deg,ethetai
6376 etheta=etheta+ethetai
6377 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6378 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6379 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6383 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
6384 do i=ithetaconstr_start,ithetaconstr_end
6385 itheta=itheta_constr(i)
6386 thetiii=theta(itheta)
6387 difi=pinorm(thetiii-theta_constr0(i))
6388 if (difi.gt.theta_drange(i)) then
6389 difi=difi-theta_drange(i)
6390 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6391 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6392 & +for_thet_constr(i)*difi**3
6393 else if (difi.lt.-drange(i)) then
6395 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6396 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6397 & +for_thet_constr(i)*difi**3
6401 if (energy_dec) then
6402 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6403 & i,itheta,rad2deg*thetiii,
6404 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
6405 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6406 & gloc(itheta+nphi-2,icg)
6414 c-----------------------------------------------------------------------------
6415 subroutine esc(escloc)
6416 C Calculate the local energy of a side chain and its derivatives in the
6417 C corresponding virtual-bond valence angles THETA and the spherical angles
6419 implicit real*8 (a-h,o-z)
6420 include 'DIMENSIONS'
6421 include 'COMMON.GEO'
6422 include 'COMMON.LOCAL'
6423 include 'COMMON.VAR'
6424 include 'COMMON.INTERACT'
6425 include 'COMMON.DERIV'
6426 include 'COMMON.CHAIN'
6427 include 'COMMON.IOUNITS'
6428 include 'COMMON.NAMES'
6429 include 'COMMON.FFIELD'
6430 include 'COMMON.CONTROL'
6431 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6432 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6433 common /sccalc/ time11,time12,time112,theti,it,nlobit
6436 c write (iout,'(a)') 'ESC'
6437 do i=loc_start,loc_end
6439 if (it.eq.ntyp1) cycle
6440 if (it.eq.10) goto 1
6441 nlobit=nlob(iabs(it))
6442 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6443 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6444 theti=theta(i+1)-pipol
6449 if (x(2).gt.pi-delta) then
6453 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6455 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6456 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6458 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6459 & ddersc0(1),dersc(1))
6460 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6461 & ddersc0(3),dersc(3))
6463 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6465 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6466 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6467 & dersc0(2),esclocbi,dersc02)
6468 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6470 call splinthet(x(2),0.5d0*delta,ss,ssd)
6475 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6477 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6478 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6480 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6482 c write (iout,*) escloci
6483 else if (x(2).lt.delta) then
6487 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6489 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6490 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6492 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6493 & ddersc0(1),dersc(1))
6494 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6495 & ddersc0(3),dersc(3))
6497 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6499 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6500 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6501 & dersc0(2),esclocbi,dersc02)
6502 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6507 call splinthet(x(2),0.5d0*delta,ss,ssd)
6509 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6511 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6512 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6514 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6515 c write (iout,*) escloci
6517 call enesc(x,escloci,dersc,ddummy,.false.)
6520 escloc=escloc+escloci
6521 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6522 & 'escloc',i,escloci
6523 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6525 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6527 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6528 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6533 C---------------------------------------------------------------------------
6534 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6535 implicit real*8 (a-h,o-z)
6536 include 'DIMENSIONS'
6537 include 'COMMON.GEO'
6538 include 'COMMON.LOCAL'
6539 include 'COMMON.IOUNITS'
6540 common /sccalc/ time11,time12,time112,theti,it,nlobit
6541 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6542 double precision contr(maxlob,-1:1)
6544 c write (iout,*) 'it=',it,' nlobit=',nlobit
6548 if (mixed) ddersc(j)=0.0d0
6552 C Because of periodicity of the dependence of the SC energy in omega we have
6553 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6554 C To avoid underflows, first compute & store the exponents.
6562 z(k)=x(k)-censc(k,j,it)
6567 Axk=Axk+gaussc(l,k,j,it)*z(l)
6573 expfac=expfac+Ax(k,j,iii)*z(k)
6581 C As in the case of ebend, we want to avoid underflows in exponentiation and
6582 C subsequent NaNs and INFs in energy calculation.
6583 C Find the largest exponent
6587 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6591 cd print *,'it=',it,' emin=',emin
6593 C Compute the contribution to SC energy and derivatives
6598 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6599 if(adexp.ne.adexp) adexp=1.0
6602 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6604 cd print *,'j=',j,' expfac=',expfac
6605 escloc_i=escloc_i+expfac
6607 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6611 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6612 & +gaussc(k,2,j,it))*expfac
6619 dersc(1)=dersc(1)/cos(theti)**2
6620 ddersc(1)=ddersc(1)/cos(theti)**2
6623 escloci=-(dlog(escloc_i)-emin)
6625 dersc(j)=dersc(j)/escloc_i
6629 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6634 C------------------------------------------------------------------------------
6635 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6636 implicit real*8 (a-h,o-z)
6637 include 'DIMENSIONS'
6638 include 'COMMON.GEO'
6639 include 'COMMON.LOCAL'
6640 include 'COMMON.IOUNITS'
6641 common /sccalc/ time11,time12,time112,theti,it,nlobit
6642 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6643 double precision contr(maxlob)
6654 z(k)=x(k)-censc(k,j,it)
6660 Axk=Axk+gaussc(l,k,j,it)*z(l)
6666 expfac=expfac+Ax(k,j)*z(k)
6671 C As in the case of ebend, we want to avoid underflows in exponentiation and
6672 C subsequent NaNs and INFs in energy calculation.
6673 C Find the largest exponent
6676 if (emin.gt.contr(j)) emin=contr(j)
6680 C Compute the contribution to SC energy and derivatives
6684 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6685 escloc_i=escloc_i+expfac
6687 dersc(k)=dersc(k)+Ax(k,j)*expfac
6689 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6690 & +gaussc(1,2,j,it))*expfac
6694 dersc(1)=dersc(1)/cos(theti)**2
6695 dersc12=dersc12/cos(theti)**2
6696 escloci=-(dlog(escloc_i)-emin)
6698 dersc(j)=dersc(j)/escloc_i
6700 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6704 c----------------------------------------------------------------------------------
6705 subroutine esc(escloc)
6706 C Calculate the local energy of a side chain and its derivatives in the
6707 C corresponding virtual-bond valence angles THETA and the spherical angles
6708 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6709 C added by Urszula Kozlowska. 07/11/2007
6711 implicit real*8 (a-h,o-z)
6712 include 'DIMENSIONS'
6713 include 'COMMON.GEO'
6714 include 'COMMON.LOCAL'
6715 include 'COMMON.VAR'
6716 include 'COMMON.SCROT'
6717 include 'COMMON.INTERACT'
6718 include 'COMMON.DERIV'
6719 include 'COMMON.CHAIN'
6720 include 'COMMON.IOUNITS'
6721 include 'COMMON.NAMES'
6722 include 'COMMON.FFIELD'
6723 include 'COMMON.CONTROL'
6724 include 'COMMON.VECTORS'
6725 double precision x_prime(3),y_prime(3),z_prime(3)
6726 & , sumene,dsc_i,dp2_i,x(65),
6727 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6728 & de_dxx,de_dyy,de_dzz,de_dt
6729 double precision s1_t,s1_6_t,s2_t,s2_6_t
6731 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6732 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6733 & dt_dCi(3),dt_dCi1(3)
6734 common /sccalc/ time11,time12,time112,theti,it,nlobit
6737 do i=loc_start,loc_end
6738 if (itype(i).eq.ntyp1) cycle
6739 costtab(i+1) =dcos(theta(i+1))
6740 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6741 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6742 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6743 cosfac2=0.5d0/(1.0d0+costtab(i+1))
6744 cosfac=dsqrt(cosfac2)
6745 sinfac2=0.5d0/(1.0d0-costtab(i+1))
6746 sinfac=dsqrt(sinfac2)
6748 if (it.eq.10) goto 1
6750 C Compute the axes of tghe local cartesian coordinates system; store in
6751 c x_prime, y_prime and z_prime
6758 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6759 C & dc_norm(3,i+nres)
6761 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6762 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6765 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6768 c write (2,*) "x_prime",(x_prime(j),j=1,3)
6769 c write (2,*) "y_prime",(y_prime(j),j=1,3)
6770 c write (2,*) "z_prime",(z_prime(j),j=1,3)
6771 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6772 c & " xy",scalar(x_prime(1),y_prime(1)),
6773 c & " xz",scalar(x_prime(1),z_prime(1)),
6774 c & " yy",scalar(y_prime(1),y_prime(1)),
6775 c & " yz",scalar(y_prime(1),z_prime(1)),
6776 c & " zz",scalar(z_prime(1),z_prime(1))
6778 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6779 C to local coordinate system. Store in xx, yy, zz.
6785 xx = xx + x_prime(j)*dc_norm(j,i+nres)
6786 yy = yy + y_prime(j)*dc_norm(j,i+nres)
6787 zz = zz + z_prime(j)*dc_norm(j,i+nres)
6794 C Compute the energy of the ith side cbain
6796 c write (2,*) "xx",xx," yy",yy," zz",zz
6799 x(j) = sc_parmin(j,it)
6802 Cc diagnostics - remove later
6804 yy1 = dsin(alph(2))*dcos(omeg(2))
6805 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6806 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6807 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6809 C," --- ", xx_w,yy_w,zz_w
6812 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
6813 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
6815 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6816 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6818 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6819 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6820 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6821 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6822 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6824 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6825 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6826 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6827 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6828 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6830 dsc_i = 0.743d0+x(61)
6832 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6833 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6834 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6835 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6836 s1=(1+x(63))/(0.1d0 + dscp1)
6837 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6838 s2=(1+x(65))/(0.1d0 + dscp2)
6839 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6840 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6841 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6842 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6844 c & dscp1,dscp2,sumene
6845 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6846 escloc = escloc + sumene
6847 c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6852 C This section to check the numerical derivatives of the energy of ith side
6853 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6854 C #define DEBUG in the code to turn it on.
6856 write (2,*) "sumene =",sumene
6860 write (2,*) xx,yy,zz
6861 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6862 de_dxx_num=(sumenep-sumene)/aincr
6864 write (2,*) "xx+ sumene from enesc=",sumenep
6867 write (2,*) xx,yy,zz
6868 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6869 de_dyy_num=(sumenep-sumene)/aincr
6871 write (2,*) "yy+ sumene from enesc=",sumenep
6874 write (2,*) xx,yy,zz
6875 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6876 de_dzz_num=(sumenep-sumene)/aincr
6878 write (2,*) "zz+ sumene from enesc=",sumenep
6879 costsave=cost2tab(i+1)
6880 sintsave=sint2tab(i+1)
6881 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6882 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6883 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6884 de_dt_num=(sumenep-sumene)/aincr
6885 write (2,*) " t+ sumene from enesc=",sumenep
6886 cost2tab(i+1)=costsave
6887 sint2tab(i+1)=sintsave
6888 C End of diagnostics section.
6891 C Compute the gradient of esc
6893 c zz=zz*dsign(1.0,dfloat(itype(i)))
6894 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6895 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6896 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6897 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6898 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6899 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6900 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6901 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6902 pom1=(sumene3*sint2tab(i+1)+sumene1)
6903 & *(pom_s1/dscp1+pom_s16*dscp1**4)
6904 pom2=(sumene4*cost2tab(i+1)+sumene2)
6905 & *(pom_s2/dscp2+pom_s26*dscp2**4)
6906 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6907 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6908 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6910 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6911 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6912 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6914 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6915 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6916 & +(pom1+pom2)*pom_dx
6918 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
6921 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6922 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6923 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6925 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6926 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6927 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6928 & +x(59)*zz**2 +x(60)*xx*zz
6929 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6930 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6931 & +(pom1-pom2)*pom_dy
6933 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
6936 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6937 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6938 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6939 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
6940 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
6941 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6942 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6943 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
6945 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
6948 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6949 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6950 & +pom1*pom_dt1+pom2*pom_dt2
6952 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
6957 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6958 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6959 cosfac2xx=cosfac2*xx
6960 sinfac2yy=sinfac2*yy
6962 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6964 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6966 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6967 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6968 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6969 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6970 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6971 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6972 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6973 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6974 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6975 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6979 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6980 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6981 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6982 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6985 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6986 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6987 dZZ_XYZ(k)=vbld_inv(i+nres)*
6988 & (z_prime(k)-zz*dC_norm(k,i+nres))
6990 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6991 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6995 dXX_Ctab(k,i)=dXX_Ci(k)
6996 dXX_C1tab(k,i)=dXX_Ci1(k)
6997 dYY_Ctab(k,i)=dYY_Ci(k)
6998 dYY_C1tab(k,i)=dYY_Ci1(k)
6999 dZZ_Ctab(k,i)=dZZ_Ci(k)
7000 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7001 dXX_XYZtab(k,i)=dXX_XYZ(k)
7002 dYY_XYZtab(k,i)=dYY_XYZ(k)
7003 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7007 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7008 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7009 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7010 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7011 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7013 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7014 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7015 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7016 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7017 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7018 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7019 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7020 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7022 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7023 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7025 C to check gradient call subroutine check_grad
7031 c------------------------------------------------------------------------------
7032 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7034 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7035 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7036 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7037 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7039 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7040 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7042 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7043 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7044 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7045 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7046 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7048 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7049 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7050 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7051 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7052 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7054 dsc_i = 0.743d0+x(61)
7056 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7057 & *(xx*cost2+yy*sint2))
7058 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7059 & *(xx*cost2-yy*sint2))
7060 s1=(1+x(63))/(0.1d0 + dscp1)
7061 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7062 s2=(1+x(65))/(0.1d0 + dscp2)
7063 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7064 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7065 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7070 c------------------------------------------------------------------------------
7071 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7073 C This procedure calculates two-body contact function g(rij) and its derivative:
7076 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7079 C where x=(rij-r0ij)/delta
7081 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7084 double precision rij,r0ij,eps0ij,fcont,fprimcont
7085 double precision x,x2,x4,delta
7089 if (x.lt.-1.0D0) then
7092 else if (x.le.1.0D0) then
7095 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7096 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7103 c------------------------------------------------------------------------------
7104 subroutine splinthet(theti,delta,ss,ssder)
7105 implicit real*8 (a-h,o-z)
7106 include 'DIMENSIONS'
7107 include 'COMMON.VAR'
7108 include 'COMMON.GEO'
7111 if (theti.gt.pipol) then
7112 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7114 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7119 c------------------------------------------------------------------------------
7120 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7122 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7123 double precision ksi,ksi2,ksi3,a1,a2,a3
7124 a1=fprim0*delta/(f1-f0)
7130 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7131 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7134 c------------------------------------------------------------------------------
7135 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7137 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7138 double precision ksi,ksi2,ksi3,a1,a2,a3
7143 a2=3*(f1x-f0x)-2*fprim0x*delta
7144 a3=fprim0x*delta-2*(f1x-f0x)
7145 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7148 C-----------------------------------------------------------------------------
7150 C-----------------------------------------------------------------------------
7151 subroutine etor(etors,edihcnstr)
7152 implicit real*8 (a-h,o-z)
7153 include 'DIMENSIONS'
7154 include 'COMMON.VAR'
7155 include 'COMMON.GEO'
7156 include 'COMMON.LOCAL'
7157 include 'COMMON.TORSION'
7158 include 'COMMON.INTERACT'
7159 include 'COMMON.DERIV'
7160 include 'COMMON.CHAIN'
7161 include 'COMMON.NAMES'
7162 include 'COMMON.IOUNITS'
7163 include 'COMMON.FFIELD'
7164 include 'COMMON.TORCNSTR'
7165 include 'COMMON.CONTROL'
7167 C Set lprn=.true. for debugging
7171 do i=iphi_start,iphi_end
7173 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7174 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7175 itori=itortyp(itype(i-2))
7176 itori1=itortyp(itype(i-1))
7179 C Proline-Proline pair is a special case...
7180 if (itori.eq.3 .and. itori1.eq.3) then
7181 if (phii.gt.-dwapi3) then
7183 fac=1.0D0/(1.0D0-cosphi)
7184 etorsi=v1(1,3,3)*fac
7185 etorsi=etorsi+etorsi
7186 etors=etors+etorsi-v1(1,3,3)
7187 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7188 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7191 v1ij=v1(j+1,itori,itori1)
7192 v2ij=v2(j+1,itori,itori1)
7195 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7196 if (energy_dec) etors_ii=etors_ii+
7197 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7198 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7202 v1ij=v1(j,itori,itori1)
7203 v2ij=v2(j,itori,itori1)
7206 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7207 if (energy_dec) etors_ii=etors_ii+
7208 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7209 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7212 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7215 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7216 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7217 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7218 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7219 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7221 ! 6/20/98 - dihedral angle constraints
7224 itori=idih_constr(i)
7227 if (difi.gt.drange(i)) then
7229 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7230 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7231 else if (difi.lt.-drange(i)) then
7233 edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7234 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7236 ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7237 ! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7239 ! write (iout,*) 'edihcnstr',edihcnstr
7242 c------------------------------------------------------------------------------
7243 subroutine etor_d(etors_d)
7247 c----------------------------------------------------------------------------
7249 subroutine etor(etors,edihcnstr)
7250 implicit real*8 (a-h,o-z)
7251 include 'DIMENSIONS'
7252 include 'COMMON.VAR'
7253 include 'COMMON.GEO'
7254 include 'COMMON.LOCAL'
7255 include 'COMMON.TORSION'
7256 include 'COMMON.INTERACT'
7257 include 'COMMON.DERIV'
7258 include 'COMMON.CHAIN'
7259 include 'COMMON.NAMES'
7260 include 'COMMON.IOUNITS'
7261 include 'COMMON.FFIELD'
7262 include 'COMMON.TORCNSTR'
7263 include 'COMMON.CONTROL'
7265 C Set lprn=.true. for debugging
7269 do i=iphi_start,iphi_end
7270 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7271 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7272 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7273 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7274 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7275 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7276 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7277 C For introducing the NH3+ and COO- group please check the etor_d for reference
7280 if (iabs(itype(i)).eq.20) then
7285 itori=itortyp(itype(i-2))
7286 itori1=itortyp(itype(i-1))
7289 C Regular cosine and sine terms
7290 do j=1,nterm(itori,itori1,iblock)
7291 v1ij=v1(j,itori,itori1,iblock)
7292 v2ij=v2(j,itori,itori1,iblock)
7295 etors=etors+v1ij*cosphi+v2ij*sinphi
7296 if (energy_dec) etors_ii=etors_ii+
7297 & v1ij*cosphi+v2ij*sinphi
7298 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7302 C E = SUM ----------------------------------- - v1
7303 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7305 cosphi=dcos(0.5d0*phii)
7306 sinphi=dsin(0.5d0*phii)
7307 do j=1,nlor(itori,itori1,iblock)
7308 vl1ij=vlor1(j,itori,itori1)
7309 vl2ij=vlor2(j,itori,itori1)
7310 vl3ij=vlor3(j,itori,itori1)
7311 pom=vl2ij*cosphi+vl3ij*sinphi
7312 pom1=1.0d0/(pom*pom+1.0d0)
7313 etors=etors+vl1ij*pom1
7314 if (energy_dec) etors_ii=etors_ii+
7317 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7319 C Subtract the constant term
7320 etors=etors-v0(itori,itori1,iblock)
7321 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7322 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7324 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7325 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7326 & (v1(j,itori,itori1,iblock),j=1,6),
7327 & (v2(j,itori,itori1,iblock),j=1,6)
7328 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7329 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7331 ! 6/20/98 - dihedral angle constraints
7333 c do i=1,ndih_constr
7334 do i=idihconstr_start,idihconstr_end
7335 itori=idih_constr(i)
7337 difi=pinorm(phii-phi0(i))
7338 if (difi.gt.drange(i)) then
7340 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7341 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7342 else if (difi.lt.-drange(i)) then
7344 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7345 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7349 if (energy_dec) then
7350 write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7351 & i,itori,rad2deg*phii,
7352 & rad2deg*phi0(i), rad2deg*drange(i),
7353 & rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7356 cd write (iout,*) 'edihcnstr',edihcnstr
7359 c----------------------------------------------------------------------------
7360 subroutine etor_d(etors_d)
7361 C 6/23/01 Compute double torsional energy
7362 implicit real*8 (a-h,o-z)
7363 include 'DIMENSIONS'
7364 include 'COMMON.VAR'
7365 include 'COMMON.GEO'
7366 include 'COMMON.LOCAL'
7367 include 'COMMON.TORSION'
7368 include 'COMMON.INTERACT'
7369 include 'COMMON.DERIV'
7370 include 'COMMON.CHAIN'
7371 include 'COMMON.NAMES'
7372 include 'COMMON.IOUNITS'
7373 include 'COMMON.FFIELD'
7374 include 'COMMON.TORCNSTR'
7376 C Set lprn=.true. for debugging
7380 c write(iout,*) "a tu??"
7381 do i=iphid_start,iphid_end
7382 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7383 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7384 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7385 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7386 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7387 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7388 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7389 & (itype(i+1).eq.ntyp1)) cycle
7390 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7391 itori=itortyp(itype(i-2))
7392 itori1=itortyp(itype(i-1))
7393 itori2=itortyp(itype(i))
7399 if (iabs(itype(i+1)).eq.20) iblock=2
7400 C Iblock=2 Proline type
7401 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7402 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7403 C if (itype(i+1).eq.ntyp1) iblock=3
7404 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7405 C IS or IS NOT need for this
7406 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7407 C is (itype(i-3).eq.ntyp1) ntblock=2
7408 C ntblock is N-terminal blocking group
7410 C Regular cosine and sine terms
7411 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7412 C Example of changes for NH3+ blocking group
7413 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7414 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7415 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7416 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7417 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7418 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7419 cosphi1=dcos(j*phii)
7420 sinphi1=dsin(j*phii)
7421 cosphi2=dcos(j*phii1)
7422 sinphi2=dsin(j*phii1)
7423 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7424 & v2cij*cosphi2+v2sij*sinphi2
7425 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7426 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7428 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7430 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7431 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7432 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7433 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7434 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7435 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7436 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7437 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7438 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7439 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7440 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7441 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7442 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7443 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7446 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7447 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7452 C----------------------------------------------------------------------------------
7453 C The rigorous attempt to derive energy function
7454 subroutine etor_kcc(etors,edihcnstr)
7455 implicit real*8 (a-h,o-z)
7456 include 'DIMENSIONS'
7457 include 'COMMON.VAR'
7458 include 'COMMON.GEO'
7459 include 'COMMON.LOCAL'
7460 include 'COMMON.TORSION'
7461 include 'COMMON.INTERACT'
7462 include 'COMMON.DERIV'
7463 include 'COMMON.CHAIN'
7464 include 'COMMON.NAMES'
7465 include 'COMMON.IOUNITS'
7466 include 'COMMON.FFIELD'
7467 include 'COMMON.TORCNSTR'
7468 include 'COMMON.CONTROL'
7470 double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7471 C Set lprn=.true. for debugging
7474 C print *,"wchodze kcc"
7475 if (tor_mode.ne.2) then
7478 do i=iphi_start,iphi_end
7479 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7480 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7481 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7482 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7483 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7484 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7485 itori=itortyp_kcc(itype(i-2))
7486 itori1=itortyp_kcc(itype(i-1))
7491 sumnonchebyshev=0.0d0
7493 C to avoid multiple devision by 2
7494 theti22=0.5d0*theta(i)
7495 C theta 12 is the theta_1 /2
7496 C theta 22 is theta_2 /2
7497 theti12=0.5d0*theta(i-1)
7498 C and appropriate sinus function
7499 sinthet2=dsin(theta(i))
7500 sinthet1=dsin(theta(i-1))
7501 costhet1=dcos(theta(i-1))
7502 costhet2=dcos(theta(i))
7503 C to speed up lets store its mutliplication
7504 sint1t2=sinthet2*sinthet1
7505 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7506 C +d_n*sin(n*gamma)) *
7507 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7508 C we have two sum 1) Non-Chebyshev which is with n and gamma
7509 do j=1,nterm_kcc(itori,itori1)
7511 v1ij=v1_kcc(j,itori,itori1)
7512 v2ij=v2_kcc(j,itori,itori1)
7513 C v1ij is c_n and d_n in euation above
7518 & sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7519 actval=sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7520 C etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7521 C if (energy_dec) etors_ii=etors_ii+
7522 C & v1ij*cosphi+v2ij*sinphi
7523 C glocig is the gradient local i site in gamma
7524 glocig=j*(v2ij*cosphi-v1ij*sinphi)*sint1t2n
7525 C now gradient over theta_1
7526 glocit1=actval/sinthet1*j*costhet1
7527 glocit2=actval/sinthet2*j*costhet2
7529 C now the Czebyshev polinominal sum
7530 do k=1,nterm_kcc_Tb(itori,itori1)
7531 thybt1(k)=v1_chyb(k,j,itori,itori1)
7532 thybt2(k)=v2_chyb(k,j,itori,itori1)
7536 sumth1thyb=tschebyshev
7537 & (1,nterm_kcc_Tb(itori,itori1),thybt1(1),dcos(theti12)**2)
7538 gradthybt1=gradtschebyshev
7539 & (0,nterm_kcc_Tb(itori,itori1)-1,thybt1(1),
7541 & *dcos(theti12)*(-dsin(theti12))
7542 sumth2thyb=tschebyshev
7543 & (1,nterm_kcc_Tb(itori,itori1),thybt2(1),dcos(theti22)**2)
7544 gradthybt2=gradtschebyshev
7545 & (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7547 & *dcos(theti22)*(-dsin(theti22))
7548 C print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7550 C & (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7551 C & dcos(theti22)**2),
7554 C now overal sumation
7555 etors=etors+(1.0d0+sumth1thyb+sumth2thyb)*sumnonchebyshev
7556 C print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7557 C derivative over gamma
7558 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7559 & *(1.0d0+sumth1thyb+sumth2thyb)
7560 C derivative over theta1
7561 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*
7562 & (glocit1*(1.0d0+sumth1thyb+sumth2thyb)+
7563 & sumnonchebyshev*gradthybt1)
7564 C now derivative over theta2
7565 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*
7566 & (glocit2*(1.0d0+sumth1thyb+sumth2thyb)+
7567 & sumnonchebyshev*gradthybt2)
7571 C gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7572 ! 6/20/98 - dihedral angle constraints
7573 if (tor_mode.ne.2) then
7575 c do i=1,ndih_constr
7576 do i=idihconstr_start,idihconstr_end
7577 itori=idih_constr(i)
7579 difi=pinorm(phii-phi0(i))
7580 if (difi.gt.drange(i)) then
7582 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7583 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7584 else if (difi.lt.-drange(i)) then
7586 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7587 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7596 C The rigorous attempt to derive energy function
7597 subroutine ebend_kcc(etheta,ethetacnstr)
7599 implicit real*8 (a-h,o-z)
7600 include 'DIMENSIONS'
7601 include 'COMMON.VAR'
7602 include 'COMMON.GEO'
7603 include 'COMMON.LOCAL'
7604 include 'COMMON.TORSION'
7605 include 'COMMON.INTERACT'
7606 include 'COMMON.DERIV'
7607 include 'COMMON.CHAIN'
7608 include 'COMMON.NAMES'
7609 include 'COMMON.IOUNITS'
7610 include 'COMMON.FFIELD'
7611 include 'COMMON.TORCNSTR'
7612 include 'COMMON.CONTROL'
7614 double precision thybt1(maxtermkcc)
7615 C Set lprn=.true. for debugging
7618 C print *,"wchodze kcc"
7619 if (tormode.ne.2) etheta=0.0D0
7620 do i=ithet_start,ithet_end
7621 c print *,i,itype(i-1),itype(i),itype(i-2)
7622 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7623 & .or.itype(i).eq.ntyp1) cycle
7624 iti=itortyp_kcc(itype(i-1))
7625 sinthet=dsin(theta(i)/2.0d0)
7626 costhet=dcos(theta(i)/2.0d0)
7627 do j=1,nbend_kcc_Tb(iti)
7628 thybt1(j)=v1bend_chyb(j,iti)
7630 sumth1thyb=tschebyshev
7631 & (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7632 ihelp=nbend_kcc_Tb(iti)-1
7633 gradthybt1=gradtschebyshev
7634 & (0,ihelp,thybt1(1),costhet)
7635 etheta=etheta+sumth1thyb
7636 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7637 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
7638 & gradthybt1*sinthet*(-0.5d0)
7640 if (tormode.ne.2) then
7642 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
7643 do i=ithetaconstr_start,ithetaconstr_end
7644 itheta=itheta_constr(i)
7645 thetiii=theta(itheta)
7646 difi=pinorm(thetiii-theta_constr0(i))
7647 if (difi.gt.theta_drange(i)) then
7648 difi=difi-theta_drange(i)
7649 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7650 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7651 & +for_thet_constr(i)*difi**3
7652 else if (difi.lt.-drange(i)) then
7654 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7655 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7656 & +for_thet_constr(i)*difi**3
7660 if (energy_dec) then
7661 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7662 & i,itheta,rad2deg*thetiii,
7663 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
7664 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7665 & gloc(itheta+nphi-2,icg)
7671 c------------------------------------------------------------------------------
7672 subroutine eback_sc_corr(esccor)
7673 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7674 c conformational states; temporarily implemented as differences
7675 c between UNRES torsional potentials (dependent on three types of
7676 c residues) and the torsional potentials dependent on all 20 types
7677 c of residues computed from AM1 energy surfaces of terminally-blocked
7678 c amino-acid residues.
7679 implicit real*8 (a-h,o-z)
7680 include 'DIMENSIONS'
7681 include 'COMMON.VAR'
7682 include 'COMMON.GEO'
7683 include 'COMMON.LOCAL'
7684 include 'COMMON.TORSION'
7685 include 'COMMON.SCCOR'
7686 include 'COMMON.INTERACT'
7687 include 'COMMON.DERIV'
7688 include 'COMMON.CHAIN'
7689 include 'COMMON.NAMES'
7690 include 'COMMON.IOUNITS'
7691 include 'COMMON.FFIELD'
7692 include 'COMMON.CONTROL'
7694 C Set lprn=.true. for debugging
7697 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7699 do i=itau_start,itau_end
7700 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7702 isccori=isccortyp(itype(i-2))
7703 isccori1=isccortyp(itype(i-1))
7704 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7706 do intertyp=1,3 !intertyp
7707 cc Added 09 May 2012 (Adasko)
7708 cc Intertyp means interaction type of backbone mainchain correlation:
7709 c 1 = SC...Ca...Ca...Ca
7710 c 2 = Ca...Ca...Ca...SC
7711 c 3 = SC...Ca...Ca...SCi
7713 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7714 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7715 & (itype(i-1).eq.ntyp1)))
7716 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7717 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7718 & .or.(itype(i).eq.ntyp1)))
7719 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7720 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7721 & (itype(i-3).eq.ntyp1)))) cycle
7722 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7723 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7725 do j=1,nterm_sccor(isccori,isccori1)
7726 v1ij=v1sccor(j,intertyp,isccori,isccori1)
7727 v2ij=v2sccor(j,intertyp,isccori,isccori1)
7728 cosphi=dcos(j*tauangle(intertyp,i))
7729 sinphi=dsin(j*tauangle(intertyp,i))
7730 esccor=esccor+v1ij*cosphi+v2ij*sinphi
7731 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7733 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7734 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7736 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7737 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7738 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7739 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7740 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7746 c----------------------------------------------------------------------------
7747 subroutine multibody(ecorr)
7748 C This subroutine calculates multi-body contributions to energy following
7749 C the idea of Skolnick et al. If side chains I and J make a contact and
7750 C at the same time side chains I+1 and J+1 make a contact, an extra
7751 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7752 implicit real*8 (a-h,o-z)
7753 include 'DIMENSIONS'
7754 include 'COMMON.IOUNITS'
7755 include 'COMMON.DERIV'
7756 include 'COMMON.INTERACT'
7757 include 'COMMON.CONTACTS'
7758 double precision gx(3),gx1(3)
7761 C Set lprn=.true. for debugging
7765 write (iout,'(a)') 'Contact function values:'
7767 write (iout,'(i2,20(1x,i2,f10.5))')
7768 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7783 num_conti=num_cont(i)
7784 num_conti1=num_cont(i1)
7789 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7790 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7791 cd & ' ishift=',ishift
7792 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7793 C The system gains extra energy.
7794 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7795 endif ! j1==j+-ishift
7804 c------------------------------------------------------------------------------
7805 double precision function esccorr(i,j,k,l,jj,kk)
7806 implicit real*8 (a-h,o-z)
7807 include 'DIMENSIONS'
7808 include 'COMMON.IOUNITS'
7809 include 'COMMON.DERIV'
7810 include 'COMMON.INTERACT'
7811 include 'COMMON.CONTACTS'
7812 include 'COMMON.SHIELD'
7813 double precision gx(3),gx1(3)
7818 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7819 C Calculate the multi-body contribution to energy.
7820 C Calculate multi-body contributions to the gradient.
7821 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7822 cd & k,l,(gacont(m,kk,k),m=1,3)
7824 gx(m) =ekl*gacont(m,jj,i)
7825 gx1(m)=eij*gacont(m,kk,k)
7826 gradxorr(m,i)=gradxorr(m,i)-gx(m)
7827 gradxorr(m,j)=gradxorr(m,j)+gx(m)
7828 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7829 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7833 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7838 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7844 c------------------------------------------------------------------------------
7845 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7846 C This subroutine calculates multi-body contributions to hydrogen-bonding
7847 implicit real*8 (a-h,o-z)
7848 include 'DIMENSIONS'
7849 include 'COMMON.IOUNITS'
7852 parameter (max_cont=maxconts)
7853 parameter (max_dim=26)
7854 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7855 double precision zapas(max_dim,maxconts,max_fg_procs),
7856 & zapas_recv(max_dim,maxconts,max_fg_procs)
7857 common /przechowalnia/ zapas
7858 integer status(MPI_STATUS_SIZE),req(maxconts*2),
7859 & status_array(MPI_STATUS_SIZE,maxconts*2)
7861 include 'COMMON.SETUP'
7862 include 'COMMON.FFIELD'
7863 include 'COMMON.DERIV'
7864 include 'COMMON.INTERACT'
7865 include 'COMMON.CONTACTS'
7866 include 'COMMON.CONTROL'
7867 include 'COMMON.LOCAL'
7868 double precision gx(3),gx1(3),time00
7871 C Set lprn=.true. for debugging
7876 if (nfgtasks.le.1) goto 30
7878 write (iout,'(a)') 'Contact function values before RECEIVE:'
7880 write (iout,'(2i3,50(1x,i2,f5.2))')
7881 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7882 & j=1,num_cont_hb(i))
7886 do i=1,ntask_cont_from
7889 do i=1,ntask_cont_to
7892 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7894 C Make the list of contacts to send to send to other procesors
7895 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7897 do i=iturn3_start,iturn3_end
7898 c write (iout,*) "make contact list turn3",i," num_cont",
7900 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7902 do i=iturn4_start,iturn4_end
7903 c write (iout,*) "make contact list turn4",i," num_cont",
7905 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7909 c write (iout,*) "make contact list longrange",i,ii," num_cont",
7911 do j=1,num_cont_hb(i)
7914 iproc=iint_sent_local(k,jjc,ii)
7915 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7916 if (iproc.gt.0) then
7917 ncont_sent(iproc)=ncont_sent(iproc)+1
7918 nn=ncont_sent(iproc)
7920 zapas(2,nn,iproc)=jjc
7921 zapas(3,nn,iproc)=facont_hb(j,i)
7922 zapas(4,nn,iproc)=ees0p(j,i)
7923 zapas(5,nn,iproc)=ees0m(j,i)
7924 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7925 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7926 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7927 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7928 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7929 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7930 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7931 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7932 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7933 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7934 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7935 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7936 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7937 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7938 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7939 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7940 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7941 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7942 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7943 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7944 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7951 & "Numbers of contacts to be sent to other processors",
7952 & (ncont_sent(i),i=1,ntask_cont_to)
7953 write (iout,*) "Contacts sent"
7954 do ii=1,ntask_cont_to
7956 iproc=itask_cont_to(ii)
7957 write (iout,*) nn," contacts to processor",iproc,
7958 & " of CONT_TO_COMM group"
7960 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7968 CorrelID1=nfgtasks+fg_rank+1
7970 C Receive the numbers of needed contacts from other processors
7971 do ii=1,ntask_cont_from
7972 iproc=itask_cont_from(ii)
7974 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7975 & FG_COMM,req(ireq),IERR)
7977 c write (iout,*) "IRECV ended"
7979 C Send the number of contacts needed by other processors
7980 do ii=1,ntask_cont_to
7981 iproc=itask_cont_to(ii)
7983 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7984 & FG_COMM,req(ireq),IERR)
7986 c write (iout,*) "ISEND ended"
7987 c write (iout,*) "number of requests (nn)",ireq
7990 & call MPI_Waitall(ireq,req,status_array,ierr)
7992 c & "Numbers of contacts to be received from other processors",
7993 c & (ncont_recv(i),i=1,ntask_cont_from)
7997 do ii=1,ntask_cont_from
7998 iproc=itask_cont_from(ii)
8000 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8001 c & " of CONT_TO_COMM group"
8005 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8006 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8007 c write (iout,*) "ireq,req",ireq,req(ireq)
8010 C Send the contacts to processors that need them
8011 do ii=1,ntask_cont_to
8012 iproc=itask_cont_to(ii)
8014 c write (iout,*) nn," contacts to processor",iproc,
8015 c & " of CONT_TO_COMM group"
8018 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8019 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8020 c write (iout,*) "ireq,req",ireq,req(ireq)
8022 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8026 c write (iout,*) "number of requests (contacts)",ireq
8027 c write (iout,*) "req",(req(i),i=1,4)
8030 & call MPI_Waitall(ireq,req,status_array,ierr)
8031 do iii=1,ntask_cont_from
8032 iproc=itask_cont_from(iii)
8035 write (iout,*) "Received",nn," contacts from processor",iproc,
8036 & " of CONT_FROM_COMM group"
8039 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8044 ii=zapas_recv(1,i,iii)
8045 c Flag the received contacts to prevent double-counting
8046 jj=-zapas_recv(2,i,iii)
8047 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8049 nnn=num_cont_hb(ii)+1
8052 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8053 ees0p(nnn,ii)=zapas_recv(4,i,iii)
8054 ees0m(nnn,ii)=zapas_recv(5,i,iii)
8055 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8056 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8057 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8058 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8059 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8060 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8061 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8062 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8063 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8064 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8065 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8066 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8067 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8068 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8069 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8070 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8071 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8072 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8073 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8074 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8075 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8080 write (iout,'(a)') 'Contact function values after receive:'
8082 write (iout,'(2i3,50(1x,i3,f5.2))')
8083 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8084 & j=1,num_cont_hb(i))
8091 write (iout,'(a)') 'Contact function values:'
8093 write (iout,'(2i3,50(1x,i3,f5.2))')
8094 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8095 & j=1,num_cont_hb(i))
8099 C Remove the loop below after debugging !!!
8106 C Calculate the local-electrostatic correlation terms
8107 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8109 num_conti=num_cont_hb(i)
8110 num_conti1=num_cont_hb(i+1)
8117 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8118 c & ' jj=',jj,' kk=',kk
8119 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8120 & .or. j.lt.0 .and. j1.gt.0) .and.
8121 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8122 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8123 C The system gains extra energy.
8124 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8125 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8126 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8128 else if (j1.eq.j) then
8129 C Contacts I-J and I-(J+1) occur simultaneously.
8130 C The system loses extra energy.
8131 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8136 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8137 c & ' jj=',jj,' kk=',kk
8139 C Contacts I-J and (I+1)-J occur simultaneously.
8140 C The system loses extra energy.
8141 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8148 c------------------------------------------------------------------------------
8149 subroutine add_hb_contact(ii,jj,itask)
8150 implicit real*8 (a-h,o-z)
8151 include "DIMENSIONS"
8152 include "COMMON.IOUNITS"
8155 parameter (max_cont=maxconts)
8156 parameter (max_dim=26)
8157 include "COMMON.CONTACTS"
8158 double precision zapas(max_dim,maxconts,max_fg_procs),
8159 & zapas_recv(max_dim,maxconts,max_fg_procs)
8160 common /przechowalnia/ zapas
8161 integer i,j,ii,jj,iproc,itask(4),nn
8162 c write (iout,*) "itask",itask
8165 if (iproc.gt.0) then
8166 do j=1,num_cont_hb(ii)
8168 c write (iout,*) "i",ii," j",jj," jjc",jjc
8170 ncont_sent(iproc)=ncont_sent(iproc)+1
8171 nn=ncont_sent(iproc)
8172 zapas(1,nn,iproc)=ii
8173 zapas(2,nn,iproc)=jjc
8174 zapas(3,nn,iproc)=facont_hb(j,ii)
8175 zapas(4,nn,iproc)=ees0p(j,ii)
8176 zapas(5,nn,iproc)=ees0m(j,ii)
8177 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8178 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8179 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8180 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8181 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8182 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8183 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8184 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8185 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8186 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8187 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8188 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8189 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8190 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8191 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8192 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8193 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8194 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8195 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8196 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8197 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8205 c------------------------------------------------------------------------------
8206 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8208 C This subroutine calculates multi-body contributions to hydrogen-bonding
8209 implicit real*8 (a-h,o-z)
8210 include 'DIMENSIONS'
8211 include 'COMMON.IOUNITS'
8214 parameter (max_cont=maxconts)
8215 parameter (max_dim=70)
8216 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8217 double precision zapas(max_dim,maxconts,max_fg_procs),
8218 & zapas_recv(max_dim,maxconts,max_fg_procs)
8219 common /przechowalnia/ zapas
8220 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8221 & status_array(MPI_STATUS_SIZE,maxconts*2)
8223 include 'COMMON.SETUP'
8224 include 'COMMON.FFIELD'
8225 include 'COMMON.DERIV'
8226 include 'COMMON.LOCAL'
8227 include 'COMMON.INTERACT'
8228 include 'COMMON.CONTACTS'
8229 include 'COMMON.CHAIN'
8230 include 'COMMON.CONTROL'
8231 include 'COMMON.SHIELD'
8232 double precision gx(3),gx1(3)
8233 integer num_cont_hb_old(maxres)
8235 double precision eello4,eello5,eelo6,eello_turn6
8236 external eello4,eello5,eello6,eello_turn6
8237 C Set lprn=.true. for debugging
8242 num_cont_hb_old(i)=num_cont_hb(i)
8246 if (nfgtasks.le.1) goto 30
8248 write (iout,'(a)') 'Contact function values before RECEIVE:'
8250 write (iout,'(2i3,50(1x,i2,f5.2))')
8251 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8252 & j=1,num_cont_hb(i))
8256 do i=1,ntask_cont_from
8259 do i=1,ntask_cont_to
8262 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8264 C Make the list of contacts to send to send to other procesors
8265 do i=iturn3_start,iturn3_end
8266 c write (iout,*) "make contact list turn3",i," num_cont",
8268 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8270 do i=iturn4_start,iturn4_end
8271 c write (iout,*) "make contact list turn4",i," num_cont",
8273 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8277 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8279 do j=1,num_cont_hb(i)
8282 iproc=iint_sent_local(k,jjc,ii)
8283 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8284 if (iproc.ne.0) then
8285 ncont_sent(iproc)=ncont_sent(iproc)+1
8286 nn=ncont_sent(iproc)
8288 zapas(2,nn,iproc)=jjc
8289 zapas(3,nn,iproc)=d_cont(j,i)
8293 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8298 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8306 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8317 & "Numbers of contacts to be sent to other processors",
8318 & (ncont_sent(i),i=1,ntask_cont_to)
8319 write (iout,*) "Contacts sent"
8320 do ii=1,ntask_cont_to
8322 iproc=itask_cont_to(ii)
8323 write (iout,*) nn," contacts to processor",iproc,
8324 & " of CONT_TO_COMM group"
8326 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8334 CorrelID1=nfgtasks+fg_rank+1
8336 C Receive the numbers of needed contacts from other processors
8337 do ii=1,ntask_cont_from
8338 iproc=itask_cont_from(ii)
8340 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8341 & FG_COMM,req(ireq),IERR)
8343 c write (iout,*) "IRECV ended"
8345 C Send the number of contacts needed by other processors
8346 do ii=1,ntask_cont_to
8347 iproc=itask_cont_to(ii)
8349 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8350 & FG_COMM,req(ireq),IERR)
8352 c write (iout,*) "ISEND ended"
8353 c write (iout,*) "number of requests (nn)",ireq
8356 & call MPI_Waitall(ireq,req,status_array,ierr)
8358 c & "Numbers of contacts to be received from other processors",
8359 c & (ncont_recv(i),i=1,ntask_cont_from)
8363 do ii=1,ntask_cont_from
8364 iproc=itask_cont_from(ii)
8366 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8367 c & " of CONT_TO_COMM group"
8371 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8372 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8373 c write (iout,*) "ireq,req",ireq,req(ireq)
8376 C Send the contacts to processors that need them
8377 do ii=1,ntask_cont_to
8378 iproc=itask_cont_to(ii)
8380 c write (iout,*) nn," contacts to processor",iproc,
8381 c & " of CONT_TO_COMM group"
8384 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8385 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8386 c write (iout,*) "ireq,req",ireq,req(ireq)
8388 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8392 c write (iout,*) "number of requests (contacts)",ireq
8393 c write (iout,*) "req",(req(i),i=1,4)
8396 & call MPI_Waitall(ireq,req,status_array,ierr)
8397 do iii=1,ntask_cont_from
8398 iproc=itask_cont_from(iii)
8401 write (iout,*) "Received",nn," contacts from processor",iproc,
8402 & " of CONT_FROM_COMM group"
8405 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8410 ii=zapas_recv(1,i,iii)
8411 c Flag the received contacts to prevent double-counting
8412 jj=-zapas_recv(2,i,iii)
8413 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8415 nnn=num_cont_hb(ii)+1
8418 d_cont(nnn,ii)=zapas_recv(3,i,iii)
8422 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8427 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8435 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8444 write (iout,'(a)') 'Contact function values after receive:'
8446 write (iout,'(2i3,50(1x,i3,5f6.3))')
8447 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8448 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8455 write (iout,'(a)') 'Contact function values:'
8457 write (iout,'(2i3,50(1x,i2,5f6.3))')
8458 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8459 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8465 C Remove the loop below after debugging !!!
8472 C Calculate the dipole-dipole interaction energies
8473 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8474 do i=iatel_s,iatel_e+1
8475 num_conti=num_cont_hb(i)
8484 C Calculate the local-electrostatic correlation terms
8485 c write (iout,*) "gradcorr5 in eello5 before loop"
8487 c write (iout,'(i5,3f10.5)')
8488 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8490 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8491 c write (iout,*) "corr loop i",i
8493 num_conti=num_cont_hb(i)
8494 num_conti1=num_cont_hb(i+1)
8501 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8502 c & ' jj=',jj,' kk=',kk
8503 c if (j1.eq.j+1 .or. j1.eq.j-1) then
8504 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8505 & .or. j.lt.0 .and. j1.gt.0) .and.
8506 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8507 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8508 C The system gains extra energy.
8510 sqd1=dsqrt(d_cont(jj,i))
8511 sqd2=dsqrt(d_cont(kk,i1))
8512 sred_geom = sqd1*sqd2
8513 IF (sred_geom.lt.cutoff_corr) THEN
8514 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8516 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8517 cd & ' jj=',jj,' kk=',kk
8518 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8519 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8521 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8522 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8525 cd write (iout,*) 'sred_geom=',sred_geom,
8526 cd & ' ekont=',ekont,' fprim=',fprimcont,
8527 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8528 cd write (iout,*) "g_contij",g_contij
8529 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8530 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8531 call calc_eello(i,jp,i+1,jp1,jj,kk)
8532 if (wcorr4.gt.0.0d0)
8533 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8534 CC & *fac_shield(i)**2*fac_shield(j)**2
8535 if (energy_dec.and.wcorr4.gt.0.0d0)
8536 1 write (iout,'(a6,4i5,0pf7.3)')
8537 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8538 c write (iout,*) "gradcorr5 before eello5"
8540 c write (iout,'(i5,3f10.5)')
8541 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8543 if (wcorr5.gt.0.0d0)
8544 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8545 c write (iout,*) "gradcorr5 after eello5"
8547 c write (iout,'(i5,3f10.5)')
8548 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8550 if (energy_dec.and.wcorr5.gt.0.0d0)
8551 1 write (iout,'(a6,4i5,0pf7.3)')
8552 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8553 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8554 cd write(2,*)'ijkl',i,jp,i+1,jp1
8555 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8556 & .or. wturn6.eq.0.0d0))then
8557 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8558 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8559 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8560 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8561 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8562 cd & 'ecorr6=',ecorr6
8563 cd write (iout,'(4e15.5)') sred_geom,
8564 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8565 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8566 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
8567 else if (wturn6.gt.0.0d0
8568 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8569 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8570 eturn6=eturn6+eello_turn6(i,jj,kk)
8571 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8572 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8573 cd write (2,*) 'multibody_eello:eturn6',eturn6
8582 num_cont_hb(i)=num_cont_hb_old(i)
8584 c write (iout,*) "gradcorr5 in eello5"
8586 c write (iout,'(i5,3f10.5)')
8587 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8591 c------------------------------------------------------------------------------
8592 subroutine add_hb_contact_eello(ii,jj,itask)
8593 implicit real*8 (a-h,o-z)
8594 include "DIMENSIONS"
8595 include "COMMON.IOUNITS"
8598 parameter (max_cont=maxconts)
8599 parameter (max_dim=70)
8600 include "COMMON.CONTACTS"
8601 double precision zapas(max_dim,maxconts,max_fg_procs),
8602 & zapas_recv(max_dim,maxconts,max_fg_procs)
8603 common /przechowalnia/ zapas
8604 integer i,j,ii,jj,iproc,itask(4),nn
8605 c write (iout,*) "itask",itask
8608 if (iproc.gt.0) then
8609 do j=1,num_cont_hb(ii)
8611 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8613 ncont_sent(iproc)=ncont_sent(iproc)+1
8614 nn=ncont_sent(iproc)
8615 zapas(1,nn,iproc)=ii
8616 zapas(2,nn,iproc)=jjc
8617 zapas(3,nn,iproc)=d_cont(j,ii)
8621 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8626 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8634 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8646 c------------------------------------------------------------------------------
8647 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8648 implicit real*8 (a-h,o-z)
8649 include 'DIMENSIONS'
8650 include 'COMMON.IOUNITS'
8651 include 'COMMON.DERIV'
8652 include 'COMMON.INTERACT'
8653 include 'COMMON.CONTACTS'
8654 include 'COMMON.SHIELD'
8655 include 'COMMON.CONTROL'
8656 double precision gx(3),gx1(3)
8659 C print *,"wchodze",fac_shield(i),shield_mode
8667 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8669 C & fac_shield(i)**2*fac_shield(j)**2
8670 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8671 C Following 4 lines for diagnostics.
8676 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8677 c & 'Contacts ',i,j,
8678 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8679 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8681 C Calculate the multi-body contribution to energy.
8682 c ecorr=ecorr+ekont*ees
8683 C Calculate multi-body contributions to the gradient.
8684 coeffpees0pij=coeffp*ees0pij
8685 coeffmees0mij=coeffm*ees0mij
8686 coeffpees0pkl=coeffp*ees0pkl
8687 coeffmees0mkl=coeffm*ees0mkl
8689 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8690 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8691 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8692 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
8693 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8694 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8695 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
8696 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8697 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8698 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8699 & coeffmees0mij*gacontm_hb1(ll,kk,k))
8700 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8701 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8702 & coeffmees0mij*gacontm_hb2(ll,kk,k))
8703 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8704 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8705 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
8706 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8707 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8708 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8709 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8710 & coeffmees0mij*gacontm_hb3(ll,kk,k))
8711 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8712 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8713 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8718 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
8719 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
8720 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8721 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8726 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
8727 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
8728 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8729 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8732 c write (iout,*) "ehbcorr",ekont*ees
8733 C print *,ekont,ees,i,k
8735 C now gradient over shielding
8737 if (shield_mode.gt.0) then
8740 C print *,i,j,fac_shield(i),fac_shield(j),
8741 C &fac_shield(k),fac_shield(l)
8742 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8743 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8744 do ilist=1,ishield_list(i)
8745 iresshield=shield_list(ilist,i)
8747 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8749 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8751 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8752 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8756 do ilist=1,ishield_list(j)
8757 iresshield=shield_list(ilist,j)
8759 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8761 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8763 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8764 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8769 do ilist=1,ishield_list(k)
8770 iresshield=shield_list(ilist,k)
8772 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8774 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8776 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8777 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8781 do ilist=1,ishield_list(l)
8782 iresshield=shield_list(ilist,l)
8784 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8786 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8788 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8789 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8793 C print *,gshieldx(m,iresshield)
8795 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8796 & grad_shield(m,i)*ehbcorr/fac_shield(i)
8797 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8798 & grad_shield(m,j)*ehbcorr/fac_shield(j)
8799 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8800 & grad_shield(m,i)*ehbcorr/fac_shield(i)
8801 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8802 & grad_shield(m,j)*ehbcorr/fac_shield(j)
8804 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8805 & grad_shield(m,k)*ehbcorr/fac_shield(k)
8806 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8807 & grad_shield(m,l)*ehbcorr/fac_shield(l)
8808 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8809 & grad_shield(m,k)*ehbcorr/fac_shield(k)
8810 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8811 & grad_shield(m,l)*ehbcorr/fac_shield(l)
8819 C---------------------------------------------------------------------------
8820 subroutine dipole(i,j,jj)
8821 implicit real*8 (a-h,o-z)
8822 include 'DIMENSIONS'
8823 include 'COMMON.IOUNITS'
8824 include 'COMMON.CHAIN'
8825 include 'COMMON.FFIELD'
8826 include 'COMMON.DERIV'
8827 include 'COMMON.INTERACT'
8828 include 'COMMON.CONTACTS'
8829 include 'COMMON.TORSION'
8830 include 'COMMON.VAR'
8831 include 'COMMON.GEO'
8832 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8834 iti1 = itortyp(itype(i+1))
8835 if (j.lt.nres-1) then
8836 itj1 = itortyp(itype(j+1))
8841 dipi(iii,1)=Ub2(iii,i)
8842 dipderi(iii)=Ub2der(iii,i)
8843 dipi(iii,2)=b1(iii,i+1)
8844 dipj(iii,1)=Ub2(iii,j)
8845 dipderj(iii)=Ub2der(iii,j)
8846 dipj(iii,2)=b1(iii,j+1)
8850 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8853 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8860 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8864 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8869 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8870 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8872 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8874 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8876 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8881 C---------------------------------------------------------------------------
8882 subroutine calc_eello(i,j,k,l,jj,kk)
8884 C This subroutine computes matrices and vectors needed to calculate
8885 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8887 implicit real*8 (a-h,o-z)
8888 include 'DIMENSIONS'
8889 include 'COMMON.IOUNITS'
8890 include 'COMMON.CHAIN'
8891 include 'COMMON.DERIV'
8892 include 'COMMON.INTERACT'
8893 include 'COMMON.CONTACTS'
8894 include 'COMMON.TORSION'
8895 include 'COMMON.VAR'
8896 include 'COMMON.GEO'
8897 include 'COMMON.FFIELD'
8898 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8899 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8902 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8903 cd & ' jj=',jj,' kk=',kk
8904 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8905 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8906 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8909 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8910 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8913 call transpose2(aa1(1,1),aa1t(1,1))
8914 call transpose2(aa2(1,1),aa2t(1,1))
8917 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8918 & aa1tder(1,1,lll,kkk))
8919 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8920 & aa2tder(1,1,lll,kkk))
8924 C parallel orientation of the two CA-CA-CA frames.
8926 iti=itortyp(itype(i))
8930 itk1=itortyp(itype(k+1))
8931 itj=itortyp(itype(j))
8932 if (l.lt.nres-1) then
8933 itl1=itortyp(itype(l+1))
8937 C A1 kernel(j+1) A2T
8939 cd write (iout,'(3f10.5,5x,3f10.5)')
8940 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8942 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8943 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8944 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8945 C Following matrices are needed only for 6-th order cumulants
8946 IF (wcorr6.gt.0.0d0) THEN
8947 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8948 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8949 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8950 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8951 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8952 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8953 & ADtEAderx(1,1,1,1,1,1))
8955 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8956 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8957 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8958 & ADtEA1derx(1,1,1,1,1,1))
8960 C End 6-th order cumulants
8963 cd write (2,*) 'In calc_eello6'
8965 cd write (2,*) 'iii=',iii
8967 cd write (2,*) 'kkk=',kkk
8969 cd write (2,'(3(2f10.5),5x)')
8970 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8975 call transpose2(EUgder(1,1,k),auxmat(1,1))
8976 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8977 call transpose2(EUg(1,1,k),auxmat(1,1))
8978 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8979 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8983 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8984 & EAEAderx(1,1,lll,kkk,iii,1))
8988 C A1T kernel(i+1) A2
8989 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8990 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8991 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8992 C Following matrices are needed only for 6-th order cumulants
8993 IF (wcorr6.gt.0.0d0) THEN
8994 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8995 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8996 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8997 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8998 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8999 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9000 & ADtEAderx(1,1,1,1,1,2))
9001 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9002 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9003 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9004 & ADtEA1derx(1,1,1,1,1,2))
9006 C End 6-th order cumulants
9007 call transpose2(EUgder(1,1,l),auxmat(1,1))
9008 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9009 call transpose2(EUg(1,1,l),auxmat(1,1))
9010 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9011 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9015 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9016 & EAEAderx(1,1,lll,kkk,iii,2))
9021 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9022 C They are needed only when the fifth- or the sixth-order cumulants are
9024 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9025 call transpose2(AEA(1,1,1),auxmat(1,1))
9026 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9027 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9028 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9029 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9030 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9031 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9032 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9033 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9034 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9035 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9036 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9037 call transpose2(AEA(1,1,2),auxmat(1,1))
9038 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9039 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9040 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9041 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9042 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9043 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9044 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9045 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9046 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9047 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9048 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9049 C Calculate the Cartesian derivatives of the vectors.
9053 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9054 call matvec2(auxmat(1,1),b1(1,i),
9055 & AEAb1derx(1,lll,kkk,iii,1,1))
9056 call matvec2(auxmat(1,1),Ub2(1,i),
9057 & AEAb2derx(1,lll,kkk,iii,1,1))
9058 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9059 & AEAb1derx(1,lll,kkk,iii,2,1))
9060 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9061 & AEAb2derx(1,lll,kkk,iii,2,1))
9062 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9063 call matvec2(auxmat(1,1),b1(1,j),
9064 & AEAb1derx(1,lll,kkk,iii,1,2))
9065 call matvec2(auxmat(1,1),Ub2(1,j),
9066 & AEAb2derx(1,lll,kkk,iii,1,2))
9067 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9068 & AEAb1derx(1,lll,kkk,iii,2,2))
9069 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9070 & AEAb2derx(1,lll,kkk,iii,2,2))
9077 C Antiparallel orientation of the two CA-CA-CA frames.
9079 iti=itortyp(itype(i))
9083 itk1=itortyp(itype(k+1))
9084 itl=itortyp(itype(l))
9085 itj=itortyp(itype(j))
9086 if (j.lt.nres-1) then
9087 itj1=itortyp(itype(j+1))
9091 C A2 kernel(j-1)T A1T
9092 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9093 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9094 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9095 C Following matrices are needed only for 6-th order cumulants
9096 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9097 & j.eq.i+4 .and. l.eq.i+3)) THEN
9098 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9099 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9100 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9101 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9102 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9103 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9104 & ADtEAderx(1,1,1,1,1,1))
9105 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9106 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9107 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9108 & ADtEA1derx(1,1,1,1,1,1))
9110 C End 6-th order cumulants
9111 call transpose2(EUgder(1,1,k),auxmat(1,1))
9112 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9113 call transpose2(EUg(1,1,k),auxmat(1,1))
9114 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9115 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9119 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9120 & EAEAderx(1,1,lll,kkk,iii,1))
9124 C A2T kernel(i+1)T A1
9125 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9126 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9127 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9128 C Following matrices are needed only for 6-th order cumulants
9129 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9130 & j.eq.i+4 .and. l.eq.i+3)) THEN
9131 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9132 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9133 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9134 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9135 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9136 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9137 & ADtEAderx(1,1,1,1,1,2))
9138 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9139 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9140 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9141 & ADtEA1derx(1,1,1,1,1,2))
9143 C End 6-th order cumulants
9144 call transpose2(EUgder(1,1,j),auxmat(1,1))
9145 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9146 call transpose2(EUg(1,1,j),auxmat(1,1))
9147 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9148 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9152 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9153 & EAEAderx(1,1,lll,kkk,iii,2))
9158 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9159 C They are needed only when the fifth- or the sixth-order cumulants are
9161 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9162 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9163 call transpose2(AEA(1,1,1),auxmat(1,1))
9164 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9165 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9166 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9167 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9168 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9169 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9170 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9171 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9172 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9173 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9174 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9175 call transpose2(AEA(1,1,2),auxmat(1,1))
9176 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9177 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9178 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9179 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9180 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9181 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9182 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9183 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9184 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9185 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9186 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9187 C Calculate the Cartesian derivatives of the vectors.
9191 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9192 call matvec2(auxmat(1,1),b1(1,i),
9193 & AEAb1derx(1,lll,kkk,iii,1,1))
9194 call matvec2(auxmat(1,1),Ub2(1,i),
9195 & AEAb2derx(1,lll,kkk,iii,1,1))
9196 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9197 & AEAb1derx(1,lll,kkk,iii,2,1))
9198 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9199 & AEAb2derx(1,lll,kkk,iii,2,1))
9200 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9201 call matvec2(auxmat(1,1),b1(1,l),
9202 & AEAb1derx(1,lll,kkk,iii,1,2))
9203 call matvec2(auxmat(1,1),Ub2(1,l),
9204 & AEAb2derx(1,lll,kkk,iii,1,2))
9205 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9206 & AEAb1derx(1,lll,kkk,iii,2,2))
9207 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9208 & AEAb2derx(1,lll,kkk,iii,2,2))
9217 C---------------------------------------------------------------------------
9218 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9219 & KK,KKderg,AKA,AKAderg,AKAderx)
9223 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9224 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9225 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9230 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9232 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9235 cd if (lprn) write (2,*) 'In kernel'
9237 cd if (lprn) write (2,*) 'kkk=',kkk
9239 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9240 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9242 cd write (2,*) 'lll=',lll
9243 cd write (2,*) 'iii=1'
9245 cd write (2,'(3(2f10.5),5x)')
9246 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9249 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9250 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9252 cd write (2,*) 'lll=',lll
9253 cd write (2,*) 'iii=2'
9255 cd write (2,'(3(2f10.5),5x)')
9256 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9263 C---------------------------------------------------------------------------
9264 double precision function eello4(i,j,k,l,jj,kk)
9265 implicit real*8 (a-h,o-z)
9266 include 'DIMENSIONS'
9267 include 'COMMON.IOUNITS'
9268 include 'COMMON.CHAIN'
9269 include 'COMMON.DERIV'
9270 include 'COMMON.INTERACT'
9271 include 'COMMON.CONTACTS'
9272 include 'COMMON.TORSION'
9273 include 'COMMON.VAR'
9274 include 'COMMON.GEO'
9275 double precision pizda(2,2),ggg1(3),ggg2(3)
9276 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9280 cd print *,'eello4:',i,j,k,l,jj,kk
9281 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
9282 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
9283 cold eij=facont_hb(jj,i)
9284 cold ekl=facont_hb(kk,k)
9286 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9287 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9288 gcorr_loc(k-1)=gcorr_loc(k-1)
9289 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9291 gcorr_loc(l-1)=gcorr_loc(l-1)
9292 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9294 gcorr_loc(j-1)=gcorr_loc(j-1)
9295 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9300 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9301 & -EAEAderx(2,2,lll,kkk,iii,1)
9302 cd derx(lll,kkk,iii)=0.0d0
9306 cd gcorr_loc(l-1)=0.0d0
9307 cd gcorr_loc(j-1)=0.0d0
9308 cd gcorr_loc(k-1)=0.0d0
9310 cd write (iout,*)'Contacts have occurred for peptide groups',
9311 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
9312 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9313 if (j.lt.nres-1) then
9320 if (l.lt.nres-1) then
9328 cgrad ggg1(ll)=eel4*g_contij(ll,1)
9329 cgrad ggg2(ll)=eel4*g_contij(ll,2)
9330 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9331 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9332 cgrad ghalf=0.5d0*ggg1(ll)
9333 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9334 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9335 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9336 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9337 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9338 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9339 cgrad ghalf=0.5d0*ggg2(ll)
9340 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9341 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9342 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9343 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9344 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9345 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9349 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9354 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9359 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9364 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9368 cd write (2,*) iii,gcorr_loc(iii)
9371 cd write (2,*) 'ekont',ekont
9372 cd write (iout,*) 'eello4',ekont*eel4
9375 C---------------------------------------------------------------------------
9376 double precision function eello5(i,j,k,l,jj,kk)
9377 implicit real*8 (a-h,o-z)
9378 include 'DIMENSIONS'
9379 include 'COMMON.IOUNITS'
9380 include 'COMMON.CHAIN'
9381 include 'COMMON.DERIV'
9382 include 'COMMON.INTERACT'
9383 include 'COMMON.CONTACTS'
9384 include 'COMMON.TORSION'
9385 include 'COMMON.VAR'
9386 include 'COMMON.GEO'
9387 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9388 double precision ggg1(3),ggg2(3)
9389 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9394 C /l\ / \ \ / \ / \ / C
9395 C / \ / \ \ / \ / \ / C
9396 C j| o |l1 | o | o| o | | o |o C
9397 C \ |/k\| |/ \| / |/ \| |/ \| C
9398 C \i/ \ / \ / / \ / \ C
9400 C (I) (II) (III) (IV) C
9402 C eello5_1 eello5_2 eello5_3 eello5_4 C
9404 C Antiparallel chains C
9407 C /j\ / \ \ / \ / \ / C
9408 C / \ / \ \ / \ / \ / C
9409 C j1| o |l | o | o| o | | o |o C
9410 C \ |/k\| |/ \| / |/ \| |/ \| C
9411 C \i/ \ / \ / / \ / \ C
9413 C (I) (II) (III) (IV) C
9415 C eello5_1 eello5_2 eello5_3 eello5_4 C
9417 C o denotes a local interaction, vertical lines an electrostatic interaction. C
9419 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9420 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9425 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
9427 itk=itortyp(itype(k))
9428 itl=itortyp(itype(l))
9429 itj=itortyp(itype(j))
9434 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9435 cd & eel5_3_num,eel5_4_num)
9439 derx(lll,kkk,iii)=0.0d0
9443 cd eij=facont_hb(jj,i)
9444 cd ekl=facont_hb(kk,k)
9446 cd write (iout,*)'Contacts have occurred for peptide groups',
9447 cd & i,j,' fcont:',eij,' eij',' and ',k,l
9449 C Contribution from the graph I.
9450 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9451 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9452 call transpose2(EUg(1,1,k),auxmat(1,1))
9453 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9454 vv(1)=pizda(1,1)-pizda(2,2)
9455 vv(2)=pizda(1,2)+pizda(2,1)
9456 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9457 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9458 C Explicit gradient in virtual-dihedral angles.
9459 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9460 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9461 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9462 call transpose2(EUgder(1,1,k),auxmat1(1,1))
9463 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9464 vv(1)=pizda(1,1)-pizda(2,2)
9465 vv(2)=pizda(1,2)+pizda(2,1)
9466 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9467 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9468 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9469 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9470 vv(1)=pizda(1,1)-pizda(2,2)
9471 vv(2)=pizda(1,2)+pizda(2,1)
9473 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9474 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9475 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9477 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9478 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9479 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9481 C Cartesian gradient
9485 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9487 vv(1)=pizda(1,1)-pizda(2,2)
9488 vv(2)=pizda(1,2)+pizda(2,1)
9489 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9490 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9491 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9497 C Contribution from graph II
9498 call transpose2(EE(1,1,itk),auxmat(1,1))
9499 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9500 vv(1)=pizda(1,1)+pizda(2,2)
9501 vv(2)=pizda(2,1)-pizda(1,2)
9502 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9503 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9504 C Explicit gradient in virtual-dihedral angles.
9505 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9506 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9507 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9508 vv(1)=pizda(1,1)+pizda(2,2)
9509 vv(2)=pizda(2,1)-pizda(1,2)
9511 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9512 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9513 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9515 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9516 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9517 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9519 C Cartesian gradient
9523 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9525 vv(1)=pizda(1,1)+pizda(2,2)
9526 vv(2)=pizda(2,1)-pizda(1,2)
9527 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9528 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9529 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9537 C Parallel orientation
9538 C Contribution from graph III
9539 call transpose2(EUg(1,1,l),auxmat(1,1))
9540 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9541 vv(1)=pizda(1,1)-pizda(2,2)
9542 vv(2)=pizda(1,2)+pizda(2,1)
9543 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9544 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9545 C Explicit gradient in virtual-dihedral angles.
9546 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9547 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9548 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9549 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9550 vv(1)=pizda(1,1)-pizda(2,2)
9551 vv(2)=pizda(1,2)+pizda(2,1)
9552 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9553 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9554 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9555 call transpose2(EUgder(1,1,l),auxmat1(1,1))
9556 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9557 vv(1)=pizda(1,1)-pizda(2,2)
9558 vv(2)=pizda(1,2)+pizda(2,1)
9559 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9560 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9561 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9562 C Cartesian gradient
9566 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9568 vv(1)=pizda(1,1)-pizda(2,2)
9569 vv(2)=pizda(1,2)+pizda(2,1)
9570 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9571 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9572 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9577 C Contribution from graph IV
9579 call transpose2(EE(1,1,itl),auxmat(1,1))
9580 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9581 vv(1)=pizda(1,1)+pizda(2,2)
9582 vv(2)=pizda(2,1)-pizda(1,2)
9583 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9584 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
9585 C Explicit gradient in virtual-dihedral angles.
9586 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9587 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9588 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9589 vv(1)=pizda(1,1)+pizda(2,2)
9590 vv(2)=pizda(2,1)-pizda(1,2)
9591 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9592 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9593 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9594 C Cartesian gradient
9598 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9600 vv(1)=pizda(1,1)+pizda(2,2)
9601 vv(2)=pizda(2,1)-pizda(1,2)
9602 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9603 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9604 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
9609 C Antiparallel orientation
9610 C Contribution from graph III
9612 call transpose2(EUg(1,1,j),auxmat(1,1))
9613 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9614 vv(1)=pizda(1,1)-pizda(2,2)
9615 vv(2)=pizda(1,2)+pizda(2,1)
9616 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9617 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9618 C Explicit gradient in virtual-dihedral angles.
9619 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9620 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9621 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9622 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9623 vv(1)=pizda(1,1)-pizda(2,2)
9624 vv(2)=pizda(1,2)+pizda(2,1)
9625 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9626 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9627 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9628 call transpose2(EUgder(1,1,j),auxmat1(1,1))
9629 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9630 vv(1)=pizda(1,1)-pizda(2,2)
9631 vv(2)=pizda(1,2)+pizda(2,1)
9632 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9633 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9634 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9635 C Cartesian gradient
9639 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9641 vv(1)=pizda(1,1)-pizda(2,2)
9642 vv(2)=pizda(1,2)+pizda(2,1)
9643 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9644 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9645 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9650 C Contribution from graph IV
9652 call transpose2(EE(1,1,itj),auxmat(1,1))
9653 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9654 vv(1)=pizda(1,1)+pizda(2,2)
9655 vv(2)=pizda(2,1)-pizda(1,2)
9656 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9657 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
9658 C Explicit gradient in virtual-dihedral angles.
9659 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9660 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9661 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9662 vv(1)=pizda(1,1)+pizda(2,2)
9663 vv(2)=pizda(2,1)-pizda(1,2)
9664 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9665 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9666 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9667 C Cartesian gradient
9671 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9673 vv(1)=pizda(1,1)+pizda(2,2)
9674 vv(2)=pizda(2,1)-pizda(1,2)
9675 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9676 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9677 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
9683 eel5=eello5_1+eello5_2+eello5_3+eello5_4
9684 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9685 cd write (2,*) 'ijkl',i,j,k,l
9686 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9687 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
9689 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9690 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9691 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9692 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9693 if (j.lt.nres-1) then
9700 if (l.lt.nres-1) then
9710 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9711 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9712 C summed up outside the subrouine as for the other subroutines
9713 C handling long-range interactions. The old code is commented out
9714 C with "cgrad" to keep track of changes.
9716 cgrad ggg1(ll)=eel5*g_contij(ll,1)
9717 cgrad ggg2(ll)=eel5*g_contij(ll,2)
9718 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9719 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9720 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9721 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9722 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9723 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9724 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9725 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9727 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9728 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9729 cgrad ghalf=0.5d0*ggg1(ll)
9731 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9732 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9733 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9734 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9735 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9736 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9737 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9738 cgrad ghalf=0.5d0*ggg2(ll)
9740 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9741 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9742 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9743 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9744 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9745 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9750 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9751 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9756 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9757 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9763 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9768 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9772 cd write (2,*) iii,g_corr5_loc(iii)
9775 cd write (2,*) 'ekont',ekont
9776 cd write (iout,*) 'eello5',ekont*eel5
9779 c--------------------------------------------------------------------------
9780 double precision function eello6(i,j,k,l,jj,kk)
9781 implicit real*8 (a-h,o-z)
9782 include 'DIMENSIONS'
9783 include 'COMMON.IOUNITS'
9784 include 'COMMON.CHAIN'
9785 include 'COMMON.DERIV'
9786 include 'COMMON.INTERACT'
9787 include 'COMMON.CONTACTS'
9788 include 'COMMON.TORSION'
9789 include 'COMMON.VAR'
9790 include 'COMMON.GEO'
9791 include 'COMMON.FFIELD'
9792 double precision ggg1(3),ggg2(3)
9793 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9798 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
9806 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9807 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9811 derx(lll,kkk,iii)=0.0d0
9815 cd eij=facont_hb(jj,i)
9816 cd ekl=facont_hb(kk,k)
9822 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9823 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9824 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9825 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9826 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9827 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9829 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9830 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9831 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9832 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9833 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9834 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9838 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9840 C If turn contributions are considered, they will be handled separately.
9841 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9842 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9843 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9844 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9845 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9846 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9847 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9849 if (j.lt.nres-1) then
9856 if (l.lt.nres-1) then
9864 cgrad ggg1(ll)=eel6*g_contij(ll,1)
9865 cgrad ggg2(ll)=eel6*g_contij(ll,2)
9866 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9867 cgrad ghalf=0.5d0*ggg1(ll)
9869 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9870 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9871 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9872 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9873 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9874 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9875 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9876 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9877 cgrad ghalf=0.5d0*ggg2(ll)
9878 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9880 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9881 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9882 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9883 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9884 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9885 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9890 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9891 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9896 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9897 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9903 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9908 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9912 cd write (2,*) iii,g_corr6_loc(iii)
9915 cd write (2,*) 'ekont',ekont
9916 cd write (iout,*) 'eello6',ekont*eel6
9919 c--------------------------------------------------------------------------
9920 double precision function eello6_graph1(i,j,k,l,imat,swap)
9921 implicit real*8 (a-h,o-z)
9922 include 'DIMENSIONS'
9923 include 'COMMON.IOUNITS'
9924 include 'COMMON.CHAIN'
9925 include 'COMMON.DERIV'
9926 include 'COMMON.INTERACT'
9927 include 'COMMON.CONTACTS'
9928 include 'COMMON.TORSION'
9929 include 'COMMON.VAR'
9930 include 'COMMON.GEO'
9931 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9935 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9937 C Parallel Antiparallel C
9943 C \ j|/k\| / \ |/k\|l / C
9948 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9949 itk=itortyp(itype(k))
9950 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9951 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9952 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9953 call transpose2(EUgC(1,1,k),auxmat(1,1))
9954 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9955 vv1(1)=pizda1(1,1)-pizda1(2,2)
9956 vv1(2)=pizda1(1,2)+pizda1(2,1)
9957 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9958 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9959 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9960 s5=scalar2(vv(1),Dtobr2(1,i))
9961 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9962 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9963 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9964 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9965 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9966 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9967 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9968 & +scalar2(vv(1),Dtobr2der(1,i)))
9969 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9970 vv1(1)=pizda1(1,1)-pizda1(2,2)
9971 vv1(2)=pizda1(1,2)+pizda1(2,1)
9972 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9973 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9975 g_corr6_loc(l-1)=g_corr6_loc(l-1)
9976 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9977 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9978 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9979 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9981 g_corr6_loc(j-1)=g_corr6_loc(j-1)
9982 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9983 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9984 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9985 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9987 call transpose2(EUgCder(1,1,k),auxmat(1,1))
9988 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9989 vv1(1)=pizda1(1,1)-pizda1(2,2)
9990 vv1(2)=pizda1(1,2)+pizda1(2,1)
9991 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9992 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9993 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9994 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10003 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10004 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10005 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10006 call transpose2(EUgC(1,1,k),auxmat(1,1))
10007 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10009 vv1(1)=pizda1(1,1)-pizda1(2,2)
10010 vv1(2)=pizda1(1,2)+pizda1(2,1)
10011 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10012 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10013 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10014 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10015 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10016 s5=scalar2(vv(1),Dtobr2(1,i))
10017 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10023 c----------------------------------------------------------------------------
10024 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10025 implicit real*8 (a-h,o-z)
10026 include 'DIMENSIONS'
10027 include 'COMMON.IOUNITS'
10028 include 'COMMON.CHAIN'
10029 include 'COMMON.DERIV'
10030 include 'COMMON.INTERACT'
10031 include 'COMMON.CONTACTS'
10032 include 'COMMON.TORSION'
10033 include 'COMMON.VAR'
10034 include 'COMMON.GEO'
10036 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10037 & auxvec1(2),auxvec2(2),auxmat1(2,2)
10039 common /kutas/ lprn
10040 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10042 C Parallel Antiparallel C
10048 C \ j|/k\| \ |/k\|l C
10053 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10054 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10055 C AL 7/4/01 s1 would occur in the sixth-order moment,
10056 C but not in a cluster cumulant
10058 s1=dip(1,jj,i)*dip(1,kk,k)
10060 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10061 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10062 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10063 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10064 call transpose2(EUg(1,1,k),auxmat(1,1))
10065 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10066 vv(1)=pizda(1,1)-pizda(2,2)
10067 vv(2)=pizda(1,2)+pizda(2,1)
10068 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10069 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10071 eello6_graph2=-(s1+s2+s3+s4)
10073 eello6_graph2=-(s2+s3+s4)
10075 c eello6_graph2=-s3
10076 C Derivatives in gamma(i-1)
10079 s1=dipderg(1,jj,i)*dip(1,kk,k)
10081 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10082 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10083 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10084 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10086 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10088 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10090 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10092 C Derivatives in gamma(k-1)
10094 s1=dip(1,jj,i)*dipderg(1,kk,k)
10096 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10097 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10098 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10099 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10100 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10101 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10102 vv(1)=pizda(1,1)-pizda(2,2)
10103 vv(2)=pizda(1,2)+pizda(2,1)
10104 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10106 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10108 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10110 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10111 C Derivatives in gamma(j-1) or gamma(l-1)
10114 s1=dipderg(3,jj,i)*dip(1,kk,k)
10116 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10117 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10118 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10119 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10120 vv(1)=pizda(1,1)-pizda(2,2)
10121 vv(2)=pizda(1,2)+pizda(2,1)
10122 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10125 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10127 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10130 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10131 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10133 C Derivatives in gamma(l-1) or gamma(j-1)
10136 s1=dip(1,jj,i)*dipderg(3,kk,k)
10138 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10139 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10140 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10141 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10142 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10143 vv(1)=pizda(1,1)-pizda(2,2)
10144 vv(2)=pizda(1,2)+pizda(2,1)
10145 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10148 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10150 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10153 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10154 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10156 C Cartesian derivatives.
10158 write (2,*) 'In eello6_graph2'
10160 write (2,*) 'iii=',iii
10162 write (2,*) 'kkk=',kkk
10164 write (2,'(3(2f10.5),5x)')
10165 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10175 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10177 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10180 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10182 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10183 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10185 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10186 call transpose2(EUg(1,1,k),auxmat(1,1))
10187 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10189 vv(1)=pizda(1,1)-pizda(2,2)
10190 vv(2)=pizda(1,2)+pizda(2,1)
10191 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10192 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10194 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10196 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10199 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10201 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10208 c----------------------------------------------------------------------------
10209 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10210 implicit real*8 (a-h,o-z)
10211 include 'DIMENSIONS'
10212 include 'COMMON.IOUNITS'
10213 include 'COMMON.CHAIN'
10214 include 'COMMON.DERIV'
10215 include 'COMMON.INTERACT'
10216 include 'COMMON.CONTACTS'
10217 include 'COMMON.TORSION'
10218 include 'COMMON.VAR'
10219 include 'COMMON.GEO'
10220 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10222 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10224 C Parallel Antiparallel C
10229 C /| o |o o| o |\ C
10230 C j|/k\| / |/k\|l / C
10235 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10237 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10238 C energy moment and not to the cluster cumulant.
10239 iti=itortyp(itype(i))
10240 if (j.lt.nres-1) then
10241 itj1=itortyp(itype(j+1))
10245 itk=itortyp(itype(k))
10246 itk1=itortyp(itype(k+1))
10247 if (l.lt.nres-1) then
10248 itl1=itortyp(itype(l+1))
10253 s1=dip(4,jj,i)*dip(4,kk,k)
10255 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10256 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10257 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10258 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10259 call transpose2(EE(1,1,itk),auxmat(1,1))
10260 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10261 vv(1)=pizda(1,1)+pizda(2,2)
10262 vv(2)=pizda(2,1)-pizda(1,2)
10263 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10264 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10265 cd & "sum",-(s2+s3+s4)
10267 eello6_graph3=-(s1+s2+s3+s4)
10269 eello6_graph3=-(s2+s3+s4)
10271 c eello6_graph3=-s4
10272 C Derivatives in gamma(k-1)
10273 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10274 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10275 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10276 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10277 C Derivatives in gamma(l-1)
10278 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10279 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10280 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10281 vv(1)=pizda(1,1)+pizda(2,2)
10282 vv(2)=pizda(2,1)-pizda(1,2)
10283 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10284 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10285 C Cartesian derivatives.
10291 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10293 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10296 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10298 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10299 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10301 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10302 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10304 vv(1)=pizda(1,1)+pizda(2,2)
10305 vv(2)=pizda(2,1)-pizda(1,2)
10306 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10308 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10310 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10313 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10315 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10317 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10323 c----------------------------------------------------------------------------
10324 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10325 implicit real*8 (a-h,o-z)
10326 include 'DIMENSIONS'
10327 include 'COMMON.IOUNITS'
10328 include 'COMMON.CHAIN'
10329 include 'COMMON.DERIV'
10330 include 'COMMON.INTERACT'
10331 include 'COMMON.CONTACTS'
10332 include 'COMMON.TORSION'
10333 include 'COMMON.VAR'
10334 include 'COMMON.GEO'
10335 include 'COMMON.FFIELD'
10336 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10337 & auxvec1(2),auxmat1(2,2)
10339 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10341 C Parallel Antiparallel C
10346 C /| o |o o| o |\ C
10347 C \ j|/k\| \ |/k\|l C
10352 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10354 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10355 C energy moment and not to the cluster cumulant.
10356 cd write (2,*) 'eello_graph4: wturn6',wturn6
10357 iti=itortyp(itype(i))
10358 itj=itortyp(itype(j))
10359 if (j.lt.nres-1) then
10360 itj1=itortyp(itype(j+1))
10364 itk=itortyp(itype(k))
10365 if (k.lt.nres-1) then
10366 itk1=itortyp(itype(k+1))
10370 itl=itortyp(itype(l))
10371 if (l.lt.nres-1) then
10372 itl1=itortyp(itype(l+1))
10376 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10377 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10378 cd & ' itl',itl,' itl1',itl1
10380 if (imat.eq.1) then
10381 s1=dip(3,jj,i)*dip(3,kk,k)
10383 s1=dip(2,jj,j)*dip(2,kk,l)
10386 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10387 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10389 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10390 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10392 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10393 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10395 call transpose2(EUg(1,1,k),auxmat(1,1))
10396 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10397 vv(1)=pizda(1,1)-pizda(2,2)
10398 vv(2)=pizda(2,1)+pizda(1,2)
10399 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10400 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10402 eello6_graph4=-(s1+s2+s3+s4)
10404 eello6_graph4=-(s2+s3+s4)
10406 C Derivatives in gamma(i-1)
10409 if (imat.eq.1) then
10410 s1=dipderg(2,jj,i)*dip(3,kk,k)
10412 s1=dipderg(4,jj,j)*dip(2,kk,l)
10415 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10417 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10418 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10420 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10421 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10423 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10424 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10425 cd write (2,*) 'turn6 derivatives'
10427 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10429 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10433 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10435 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10439 C Derivatives in gamma(k-1)
10441 if (imat.eq.1) then
10442 s1=dip(3,jj,i)*dipderg(2,kk,k)
10444 s1=dip(2,jj,j)*dipderg(4,kk,l)
10447 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10448 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10450 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10451 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10453 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10454 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10456 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10457 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10458 vv(1)=pizda(1,1)-pizda(2,2)
10459 vv(2)=pizda(2,1)+pizda(1,2)
10460 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10461 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10463 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10465 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10469 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10471 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10474 C Derivatives in gamma(j-1) or gamma(l-1)
10475 if (l.eq.j+1 .and. l.gt.1) then
10476 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10477 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10478 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10479 vv(1)=pizda(1,1)-pizda(2,2)
10480 vv(2)=pizda(2,1)+pizda(1,2)
10481 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10482 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10483 else if (j.gt.1) then
10484 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10485 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10486 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10487 vv(1)=pizda(1,1)-pizda(2,2)
10488 vv(2)=pizda(2,1)+pizda(1,2)
10489 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10490 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10491 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10493 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10496 C Cartesian derivatives.
10502 if (imat.eq.1) then
10503 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10505 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10508 if (imat.eq.1) then
10509 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10511 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10515 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10517 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10519 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10520 & b1(1,j+1),auxvec(1))
10521 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10523 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10524 & b1(1,l+1),auxvec(1))
10525 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10527 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10529 vv(1)=pizda(1,1)-pizda(2,2)
10530 vv(2)=pizda(2,1)+pizda(1,2)
10531 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10533 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10535 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10538 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10541 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10544 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10546 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10548 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10552 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10554 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10557 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10559 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10567 c----------------------------------------------------------------------------
10568 double precision function eello_turn6(i,jj,kk)
10569 implicit real*8 (a-h,o-z)
10570 include 'DIMENSIONS'
10571 include 'COMMON.IOUNITS'
10572 include 'COMMON.CHAIN'
10573 include 'COMMON.DERIV'
10574 include 'COMMON.INTERACT'
10575 include 'COMMON.CONTACTS'
10576 include 'COMMON.TORSION'
10577 include 'COMMON.VAR'
10578 include 'COMMON.GEO'
10579 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10580 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10582 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10583 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10584 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10585 C the respective energy moment and not to the cluster cumulant.
10594 iti=itortyp(itype(i))
10595 itk=itortyp(itype(k))
10596 itk1=itortyp(itype(k+1))
10597 itl=itortyp(itype(l))
10598 itj=itortyp(itype(j))
10599 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10600 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
10601 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10606 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10608 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
10612 derx_turn(lll,kkk,iii)=0.0d0
10619 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10621 cd write (2,*) 'eello6_5',eello6_5
10623 call transpose2(AEA(1,1,1),auxmat(1,1))
10624 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10625 ss1=scalar2(Ub2(1,i+2),b1(1,l))
10626 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10628 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10629 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10630 s2 = scalar2(b1(1,k),vtemp1(1))
10632 call transpose2(AEA(1,1,2),atemp(1,1))
10633 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10634 call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10635 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10637 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10638 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10639 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10641 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10642 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10643 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10644 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10645 ss13 = scalar2(b1(1,k),vtemp4(1))
10646 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10648 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10654 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10655 C Derivatives in gamma(i+2)
10659 call transpose2(AEA(1,1,1),auxmatd(1,1))
10660 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10661 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10662 call transpose2(AEAderg(1,1,2),atempd(1,1))
10663 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10664 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10666 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10667 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10668 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10674 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10675 C Derivatives in gamma(i+3)
10677 call transpose2(AEA(1,1,1),auxmatd(1,1))
10678 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10679 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10680 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10682 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10683 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10684 s2d = scalar2(b1(1,k),vtemp1d(1))
10686 call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10687 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10689 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10691 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10692 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10693 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10701 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10702 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10704 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10705 & -0.5d0*ekont*(s2d+s12d)
10707 C Derivatives in gamma(i+4)
10708 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10709 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10710 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10712 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10713 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10714 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10722 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10724 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10726 C Derivatives in gamma(i+5)
10728 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10729 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10730 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10732 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10733 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10734 s2d = scalar2(b1(1,k),vtemp1d(1))
10736 call transpose2(AEA(1,1,2),atempd(1,1))
10737 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10738 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10740 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10741 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10743 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10744 ss13d = scalar2(b1(1,k),vtemp4d(1))
10745 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10753 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10754 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10756 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10757 & -0.5d0*ekont*(s2d+s12d)
10759 C Cartesian derivatives
10764 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10765 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10766 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10768 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10769 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10771 s2d = scalar2(b1(1,k),vtemp1d(1))
10773 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10774 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10775 s8d = -(atempd(1,1)+atempd(2,2))*
10776 & scalar2(cc(1,1,itl),vtemp2(1))
10778 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10780 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10781 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10788 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10789 & - 0.5d0*(s1d+s2d)
10791 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10795 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10796 & - 0.5d0*(s8d+s12d)
10798 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10807 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10808 & achuj_tempd(1,1))
10809 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10810 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10811 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10812 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10813 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10815 ss13d = scalar2(b1(1,k),vtemp4d(1))
10816 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10817 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10821 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10822 cd & 16*eel_turn6_num
10824 if (j.lt.nres-1) then
10831 if (l.lt.nres-1) then
10839 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
10840 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
10841 cgrad ghalf=0.5d0*ggg1(ll)
10843 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10844 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10845 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10846 & +ekont*derx_turn(ll,2,1)
10847 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10848 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10849 & +ekont*derx_turn(ll,4,1)
10850 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10851 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10852 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10853 cgrad ghalf=0.5d0*ggg2(ll)
10855 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10856 & +ekont*derx_turn(ll,2,2)
10857 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10858 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10859 & +ekont*derx_turn(ll,4,2)
10860 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10861 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10862 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10867 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10872 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10878 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10883 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10887 cd write (2,*) iii,g_corr6_loc(iii)
10889 eello_turn6=ekont*eel_turn6
10890 cd write (2,*) 'ekont',ekont
10891 cd write (2,*) 'eel_turn6',ekont*eel_turn6
10895 C-----------------------------------------------------------------------------
10896 double precision function scalar(u,v)
10897 !DIR$ INLINEALWAYS scalar
10899 cDEC$ ATTRIBUTES FORCEINLINE::scalar
10902 double precision u(3),v(3)
10903 cd double precision sc
10911 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
10914 crc-------------------------------------------------
10915 SUBROUTINE MATVEC2(A1,V1,V2)
10916 !DIR$ INLINEALWAYS MATVEC2
10918 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10920 implicit real*8 (a-h,o-z)
10921 include 'DIMENSIONS'
10922 DIMENSION A1(2,2),V1(2),V2(2)
10926 c 3 VI=VI+A1(I,K)*V1(K)
10930 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10931 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10936 C---------------------------------------
10937 SUBROUTINE MATMAT2(A1,A2,A3)
10939 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10941 implicit real*8 (a-h,o-z)
10942 include 'DIMENSIONS'
10943 DIMENSION A1(2,2),A2(2,2),A3(2,2)
10944 c DIMENSION AI3(2,2)
10948 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
10954 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10955 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10956 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10957 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10965 c-------------------------------------------------------------------------
10966 double precision function scalar2(u,v)
10967 !DIR$ INLINEALWAYS scalar2
10969 double precision u(2),v(2)
10970 double precision sc
10972 scalar2=u(1)*v(1)+u(2)*v(2)
10976 C-----------------------------------------------------------------------------
10978 subroutine transpose2(a,at)
10979 !DIR$ INLINEALWAYS transpose2
10981 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
10984 double precision a(2,2),at(2,2)
10991 c--------------------------------------------------------------------------
10992 subroutine transpose(n,a,at)
10995 double precision a(n,n),at(n,n)
11003 C---------------------------------------------------------------------------
11004 subroutine prodmat3(a1,a2,kk,transp,prod)
11005 !DIR$ INLINEALWAYS prodmat3
11007 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11011 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11013 crc double precision auxmat(2,2),prod_(2,2)
11016 crc call transpose2(kk(1,1),auxmat(1,1))
11017 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11018 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11020 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11021 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11022 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11023 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11024 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11025 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11026 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11027 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11030 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11031 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11033 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11034 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11035 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11036 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11037 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11038 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11039 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11040 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11043 c call transpose2(a2(1,1),a2t(1,1))
11046 crc print *,((prod_(i,j),i=1,2),j=1,2)
11047 crc print *,((prod(i,j),i=1,2),j=1,2)
11051 CCC----------------------------------------------
11052 subroutine Eliptransfer(eliptran)
11053 implicit real*8 (a-h,o-z)
11054 include 'DIMENSIONS'
11055 include 'COMMON.GEO'
11056 include 'COMMON.VAR'
11057 include 'COMMON.LOCAL'
11058 include 'COMMON.CHAIN'
11059 include 'COMMON.DERIV'
11060 include 'COMMON.NAMES'
11061 include 'COMMON.INTERACT'
11062 include 'COMMON.IOUNITS'
11063 include 'COMMON.CALC'
11064 include 'COMMON.CONTROL'
11065 include 'COMMON.SPLITELE'
11066 include 'COMMON.SBRIDGE'
11067 C this is done by Adasko
11068 C print *,"wchodze"
11069 C structure of box:
11071 C--bordliptop-- buffore starts
11072 C--bufliptop--- here true lipid starts
11074 C--buflipbot--- lipid ends buffore starts
11075 C--bordlipbot--buffore ends
11077 do i=ilip_start,ilip_end
11079 if (itype(i).eq.ntyp1) cycle
11081 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11082 if (positi.le.0) positi=positi+boxzsize
11084 C first for peptide groups
11085 c for each residue check if it is in lipid or lipid water border area
11086 if ((positi.gt.bordlipbot)
11087 &.and.(positi.lt.bordliptop)) then
11088 C the energy transfer exist
11089 if (positi.lt.buflipbot) then
11090 C what fraction I am in
11092 & ((positi-bordlipbot)/lipbufthick)
11093 C lipbufthick is thickenes of lipid buffore
11094 sslip=sscalelip(fracinbuf)
11095 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11096 eliptran=eliptran+sslip*pepliptran
11097 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11098 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11099 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11101 C print *,"doing sccale for lower part"
11102 C print *,i,sslip,fracinbuf,ssgradlip
11103 elseif (positi.gt.bufliptop) then
11104 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11105 sslip=sscalelip(fracinbuf)
11106 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11107 eliptran=eliptran+sslip*pepliptran
11108 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11109 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11110 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11111 C print *, "doing sscalefor top part"
11112 C print *,i,sslip,fracinbuf,ssgradlip
11114 eliptran=eliptran+pepliptran
11115 C print *,"I am in true lipid"
11118 C eliptran=elpitran+0.0 ! I am in water
11121 C print *, "nic nie bylo w lipidzie?"
11122 C now multiply all by the peptide group transfer factor
11123 C eliptran=eliptran*pepliptran
11124 C now the same for side chains
11126 do i=ilip_start,ilip_end
11127 if (itype(i).eq.ntyp1) cycle
11128 positi=(mod(c(3,i+nres),boxzsize))
11129 if (positi.le.0) positi=positi+boxzsize
11130 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11131 c for each residue check if it is in lipid or lipid water border area
11132 C respos=mod(c(3,i+nres),boxzsize)
11133 C print *,positi,bordlipbot,buflipbot
11134 if ((positi.gt.bordlipbot)
11135 & .and.(positi.lt.bordliptop)) then
11136 C the energy transfer exist
11137 if (positi.lt.buflipbot) then
11139 & ((positi-bordlipbot)/lipbufthick)
11140 C lipbufthick is thickenes of lipid buffore
11141 sslip=sscalelip(fracinbuf)
11142 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11143 eliptran=eliptran+sslip*liptranene(itype(i))
11144 gliptranx(3,i)=gliptranx(3,i)
11145 &+ssgradlip*liptranene(itype(i))
11146 gliptranc(3,i-1)= gliptranc(3,i-1)
11147 &+ssgradlip*liptranene(itype(i))
11148 C print *,"doing sccale for lower part"
11149 elseif (positi.gt.bufliptop) then
11151 &((bordliptop-positi)/lipbufthick)
11152 sslip=sscalelip(fracinbuf)
11153 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11154 eliptran=eliptran+sslip*liptranene(itype(i))
11155 gliptranx(3,i)=gliptranx(3,i)
11156 &+ssgradlip*liptranene(itype(i))
11157 gliptranc(3,i-1)= gliptranc(3,i-1)
11158 &+ssgradlip*liptranene(itype(i))
11159 C print *, "doing sscalefor top part",sslip,fracinbuf
11161 eliptran=eliptran+liptranene(itype(i))
11162 C print *,"I am in true lipid"
11164 endif ! if in lipid or buffor
11166 C eliptran=elpitran+0.0 ! I am in water
11170 C---------------------------------------------------------
11171 C AFM soubroutine for constant force
11172 subroutine AFMforce(Eafmforce)
11173 implicit real*8 (a-h,o-z)
11174 include 'DIMENSIONS'
11175 include 'COMMON.GEO'
11176 include 'COMMON.VAR'
11177 include 'COMMON.LOCAL'
11178 include 'COMMON.CHAIN'
11179 include 'COMMON.DERIV'
11180 include 'COMMON.NAMES'
11181 include 'COMMON.INTERACT'
11182 include 'COMMON.IOUNITS'
11183 include 'COMMON.CALC'
11184 include 'COMMON.CONTROL'
11185 include 'COMMON.SPLITELE'
11186 include 'COMMON.SBRIDGE'
11191 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11192 dist=dist+diffafm(i)**2
11195 Eafmforce=-forceAFMconst*(dist-distafminit)
11197 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11198 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11200 C print *,'AFM',Eafmforce
11203 C---------------------------------------------------------
11204 C AFM subroutine with pseudoconstant velocity
11205 subroutine AFMvel(Eafmforce)
11206 implicit real*8 (a-h,o-z)
11207 include 'DIMENSIONS'
11208 include 'COMMON.GEO'
11209 include 'COMMON.VAR'
11210 include 'COMMON.LOCAL'
11211 include 'COMMON.CHAIN'
11212 include 'COMMON.DERIV'
11213 include 'COMMON.NAMES'
11214 include 'COMMON.INTERACT'
11215 include 'COMMON.IOUNITS'
11216 include 'COMMON.CALC'
11217 include 'COMMON.CONTROL'
11218 include 'COMMON.SPLITELE'
11219 include 'COMMON.SBRIDGE'
11221 C Only for check grad COMMENT if not used for checkgrad
11223 C--------------------------------------------------------
11224 C print *,"wchodze"
11228 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11229 dist=dist+diffafm(i)**2
11232 Eafmforce=0.5d0*forceAFMconst
11233 & *(distafminit+totTafm*velAFMconst-dist)**2
11234 C Eafmforce=-forceAFMconst*(dist-distafminit)
11236 gradafm(i,afmend-1)=-forceAFMconst*
11237 &(distafminit+totTafm*velAFMconst-dist)
11239 gradafm(i,afmbeg-1)=forceAFMconst*
11240 &(distafminit+totTafm*velAFMconst-dist)
11243 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11246 C-----------------------------------------------------------
11247 C first for shielding is setting of function of side-chains
11248 subroutine set_shield_fac
11249 implicit real*8 (a-h,o-z)
11250 include 'DIMENSIONS'
11251 include 'COMMON.CHAIN'
11252 include 'COMMON.DERIV'
11253 include 'COMMON.IOUNITS'
11254 include 'COMMON.SHIELD'
11255 include 'COMMON.INTERACT'
11256 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11257 double precision div77_81/0.974996043d0/,
11258 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11260 C the vector between center of side_chain and peptide group
11261 double precision pep_side(3),long,side_calf(3),
11262 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11263 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11264 C the line belowe needs to be changed for FGPROC>1
11266 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11268 Cif there two consequtive dummy atoms there is no peptide group between them
11269 C the line below has to be changed for FGPROC>1
11272 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11276 C first lets set vector conecting the ithe side-chain with kth side-chain
11277 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11278 C pep_side(j)=2.0d0
11279 C and vector conecting the side-chain with its proper calfa
11280 side_calf(j)=c(j,k+nres)-c(j,k)
11281 C side_calf(j)=2.0d0
11282 pept_group(j)=c(j,i)-c(j,i+1)
11283 C lets have their lenght
11284 dist_pep_side=pep_side(j)**2+dist_pep_side
11285 dist_side_calf=dist_side_calf+side_calf(j)**2
11286 dist_pept_group=dist_pept_group+pept_group(j)**2
11288 dist_pep_side=dsqrt(dist_pep_side)
11289 dist_pept_group=dsqrt(dist_pept_group)
11290 dist_side_calf=dsqrt(dist_side_calf)
11292 pep_side_norm(j)=pep_side(j)/dist_pep_side
11293 side_calf_norm(j)=dist_side_calf
11295 C now sscale fraction
11296 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11297 C print *,buff_shield,"buff"
11299 if (sh_frac_dist.le.0.0) cycle
11300 C If we reach here it means that this side chain reaches the shielding sphere
11301 C Lets add him to the list for gradient
11302 ishield_list(i)=ishield_list(i)+1
11303 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11304 C this list is essential otherwise problem would be O3
11305 shield_list(ishield_list(i),i)=k
11306 C Lets have the sscale value
11307 if (sh_frac_dist.gt.1.0) then
11308 scale_fac_dist=1.0d0
11310 sh_frac_dist_grad(j)=0.0d0
11313 scale_fac_dist=-sh_frac_dist*sh_frac_dist
11314 & *(2.0*sh_frac_dist-3.0d0)
11315 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11316 & /dist_pep_side/buff_shield*0.5
11317 C remember for the final gradient multiply sh_frac_dist_grad(j)
11318 C for side_chain by factor -2 !
11320 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11321 C print *,"jestem",scale_fac_dist,fac_help_scale,
11322 C & sh_frac_dist_grad(j)
11325 C if ((i.eq.3).and.(k.eq.2)) then
11326 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11330 C this is what is now we have the distance scaling now volume...
11331 short=short_r_sidechain(itype(k))
11332 long=long_r_sidechain(itype(k))
11333 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11336 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11337 C costhet_fac=0.0d0
11339 costhet_grad(j)=costhet_fac*pep_side(j)
11341 C remember for the final gradient multiply costhet_grad(j)
11342 C for side_chain by factor -2 !
11343 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11344 C pep_side0pept_group is vector multiplication
11345 pep_side0pept_group=0.0
11347 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11349 cosalfa=(pep_side0pept_group/
11350 & (dist_pep_side*dist_side_calf))
11351 fac_alfa_sin=1.0-cosalfa**2
11352 fac_alfa_sin=dsqrt(fac_alfa_sin)
11353 rkprim=fac_alfa_sin*(long-short)+short
11355 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11356 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11359 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11360 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11361 &*(long-short)/fac_alfa_sin*cosalfa/
11362 &((dist_pep_side*dist_side_calf))*
11363 &((side_calf(j))-cosalfa*
11364 &((pep_side(j)/dist_pep_side)*dist_side_calf))
11366 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11367 &*(long-short)/fac_alfa_sin*cosalfa
11368 &/((dist_pep_side*dist_side_calf))*
11370 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11373 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11376 C now the gradient...
11377 C grad_shield is gradient of Calfa for peptide groups
11378 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11380 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11381 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11383 grad_shield(j,i)=grad_shield(j,i)
11384 C gradient po skalowaniu
11385 & +(sh_frac_dist_grad(j)
11386 C gradient po costhet
11387 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11388 &-scale_fac_dist*(cosphi_grad_long(j))
11389 &/(1.0-cosphi) )*div77_81
11391 C grad_shield_side is Cbeta sidechain gradient
11392 grad_shield_side(j,ishield_list(i),i)=
11393 & (sh_frac_dist_grad(j)*-2.0d0
11394 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11395 & +scale_fac_dist*(cosphi_grad_long(j))
11396 & *2.0d0/(1.0-cosphi))
11397 & *div77_81*VofOverlap
11399 grad_shield_loc(j,ishield_list(i),i)=
11400 & scale_fac_dist*cosphi_grad_loc(j)
11401 & *2.0d0/(1.0-cosphi)
11402 & *div77_81*VofOverlap
11404 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11406 fac_shield(i)=VolumeTotal*div77_81+div4_81
11407 C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11411 C--------------------------------------------------------------------------
11412 double precision function tschebyshev(m,n,x,y)
11414 include "DIMENSIONS"
11416 double precision x(n),y,yy(0:maxvar),aux
11417 c Tschebyshev polynomial. Note that the first term is omitted
11418 c m=0: the constant term is included
11419 c m=1: the constant term is not included
11423 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11432 C--------------------------------------------------------------------------
11433 double precision function gradtschebyshev(m,n,x,y)
11435 include "DIMENSIONS"
11437 double precision x(n+1),y,yy(0:maxvar),aux
11438 c Tschebyshev polynomial. Note that the first term is omitted
11439 c m=0: the constant term is included
11440 c m=1: the constant term is not included
11444 yy(i)=2*y*yy(i-1)-yy(i-2)
11448 aux=aux+x(i+1)*yy(i)*(i+1)
11449 C print *, x(i+1),yy(i),i
11451 gradtschebyshev=aux
11454 C------------------------------------------------------------------------
11455 C first for shielding is setting of function of side-chains
11456 subroutine set_shield_fac2
11457 implicit real*8 (a-h,o-z)
11458 include 'DIMENSIONS'
11459 include 'COMMON.CHAIN'
11460 include 'COMMON.DERIV'
11461 include 'COMMON.IOUNITS'
11462 include 'COMMON.SHIELD'
11463 include 'COMMON.INTERACT'
11464 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11465 double precision div77_81/0.974996043d0/,
11466 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11468 C the vector between center of side_chain and peptide group
11469 double precision pep_side(3),long,side_calf(3),
11470 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11471 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11472 C the line belowe needs to be changed for FGPROC>1
11474 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11476 Cif there two consequtive dummy atoms there is no peptide group between them
11477 C the line below has to be changed for FGPROC>1
11480 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11484 C first lets set vector conecting the ithe side-chain with kth side-chain
11485 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11486 C pep_side(j)=2.0d0
11487 C and vector conecting the side-chain with its proper calfa
11488 side_calf(j)=c(j,k+nres)-c(j,k)
11489 C side_calf(j)=2.0d0
11490 pept_group(j)=c(j,i)-c(j,i+1)
11491 C lets have their lenght
11492 dist_pep_side=pep_side(j)**2+dist_pep_side
11493 dist_side_calf=dist_side_calf+side_calf(j)**2
11494 dist_pept_group=dist_pept_group+pept_group(j)**2
11496 dist_pep_side=dsqrt(dist_pep_side)
11497 dist_pept_group=dsqrt(dist_pept_group)
11498 dist_side_calf=dsqrt(dist_side_calf)
11500 pep_side_norm(j)=pep_side(j)/dist_pep_side
11501 side_calf_norm(j)=dist_side_calf
11503 C now sscale fraction
11504 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11505 C print *,buff_shield,"buff"
11507 if (sh_frac_dist.le.0.0) cycle
11508 C If we reach here it means that this side chain reaches the shielding sphere
11509 C Lets add him to the list for gradient
11510 ishield_list(i)=ishield_list(i)+1
11511 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11512 C this list is essential otherwise problem would be O3
11513 shield_list(ishield_list(i),i)=k
11514 C Lets have the sscale value
11515 if (sh_frac_dist.gt.1.0) then
11516 scale_fac_dist=1.0d0
11518 sh_frac_dist_grad(j)=0.0d0
11521 scale_fac_dist=-sh_frac_dist*sh_frac_dist
11522 & *(2.0d0*sh_frac_dist-3.0d0)
11523 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11524 & /dist_pep_side/buff_shield*0.5d0
11525 C remember for the final gradient multiply sh_frac_dist_grad(j)
11526 C for side_chain by factor -2 !
11528 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11529 C sh_frac_dist_grad(j)=0.0d0
11530 C scale_fac_dist=1.0d0
11531 C print *,"jestem",scale_fac_dist,fac_help_scale,
11532 C & sh_frac_dist_grad(j)
11535 C this is what is now we have the distance scaling now volume...
11536 short=short_r_sidechain(itype(k))
11537 long=long_r_sidechain(itype(k))
11538 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11539 sinthet=short/dist_pep_side*costhet
11543 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11544 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11545 C & -short/dist_pep_side**2/costhet)
11546 C costhet_fac=0.0d0
11548 costhet_grad(j)=costhet_fac*pep_side(j)
11550 C remember for the final gradient multiply costhet_grad(j)
11551 C for side_chain by factor -2 !
11552 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11553 C pep_side0pept_group is vector multiplication
11554 pep_side0pept_group=0.0d0
11556 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11558 cosalfa=(pep_side0pept_group/
11559 & (dist_pep_side*dist_side_calf))
11560 fac_alfa_sin=1.0d0-cosalfa**2
11561 fac_alfa_sin=dsqrt(fac_alfa_sin)
11562 rkprim=fac_alfa_sin*(long-short)+short
11566 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11568 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11569 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11570 & dist_pep_side**2)
11573 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11574 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11575 &*(long-short)/fac_alfa_sin*cosalfa/
11576 &((dist_pep_side*dist_side_calf))*
11577 &((side_calf(j))-cosalfa*
11578 &((pep_side(j)/dist_pep_side)*dist_side_calf))
11579 C cosphi_grad_long(j)=0.0d0
11580 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11581 &*(long-short)/fac_alfa_sin*cosalfa
11582 &/((dist_pep_side*dist_side_calf))*
11584 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11585 C cosphi_grad_loc(j)=0.0d0
11587 C print *,sinphi,sinthet
11588 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11591 C now the gradient...
11593 grad_shield(j,i)=grad_shield(j,i)
11594 C gradient po skalowaniu
11595 & +(sh_frac_dist_grad(j)*VofOverlap
11596 C gradient po costhet
11597 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11598 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11599 & sinphi/sinthet*costhet*costhet_grad(j)
11600 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11602 C grad_shield_side is Cbeta sidechain gradient
11603 grad_shield_side(j,ishield_list(i),i)=
11604 & (sh_frac_dist_grad(j)*-2.0d0
11606 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11607 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11608 & sinphi/sinthet*costhet*costhet_grad(j)
11609 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11612 grad_shield_loc(j,ishield_list(i),i)=
11613 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11614 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11615 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11619 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11621 fac_shield(i)=VolumeTotal*div77_81+div4_81
11622 C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)