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'
28 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
29 c & " nfgtasks",nfgtasks
30 if (nfgtasks.gt.1) then
32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
33 if (fg_rank.eq.0) then
34 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
35 c print *,"Processor",myrank," BROADCAST iorder"
36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
37 C FG slaves as WEIGHTS array.
57 C FG Master broadcasts the WEIGHTS_ array
58 call MPI_Bcast(weights_(1),n_ene,
59 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
61 C FG slaves receive the WEIGHTS array
62 call MPI_Bcast(weights(1),n_ene,
63 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
84 time_Bcast=time_Bcast+MPI_Wtime()-time00
85 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
86 c call chainbuild_cart
88 c print *,'Processor',myrank,' calling etotal ipot=',ipot
89 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
91 c if (modecalc.eq.12.or.modecalc.eq.14) then
92 c call int_from_cart1(.false.)
99 C Compute the side-chain and electrostatic interaction energy
101 goto (101,102,103,104,105,106) ipot
102 C Lennard-Jones potential.
104 cd print '(a)','Exit ELJ'
106 C Lennard-Jones-Kihara potential (shifted).
109 C Berne-Pechukas potential (dilated LJ, angular dependence).
112 C Gay-Berne potential (shifted LJ, angular dependence).
115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
118 C Soft-sphere potential
119 106 call e_softsphere(evdw)
121 C Calculate electrostatic (H-bonding) energy of the main chain.
124 c print *,"Processor",myrank," computed USCSC"
130 time_vec=time_vec+MPI_Wtime()-time01
132 c print *,"Processor",myrank," left VEC_AND_DERIV"
135 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
136 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
137 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
138 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
140 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
141 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
142 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
143 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
145 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
154 c write (iout,*) "Soft-spheer ELEC potential"
155 call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
158 c print *,"Processor",myrank," computed UELEC"
160 C Calculate excluded-volume interaction energy between peptide groups
165 call escp(evdw2,evdw2_14)
171 c write (iout,*) "Soft-sphere SCP potential"
172 call escp_soft_sphere(evdw2,evdw2_14)
175 c Calculate the bond-stretching energy
179 C Calculate the disulfide-bridge and other energy and the contributions
180 C from other distance constraints.
181 cd print *,'Calling EHPB'
183 cd print *,'EHPB exitted succesfully.'
185 C Calculate the virtual-bond-angle energy.
187 if (wang.gt.0d0) then
192 c print *,"Processor",myrank," computed UB"
194 C Calculate the SC local energy.
197 c print *,"Processor",myrank," computed USC"
199 C Calculate the virtual-bond torsional energy.
201 cd print *,'nterm=',nterm
203 call etor(etors,edihcnstr)
208 c print *,"Processor",myrank," computed Utor"
210 C 6/23/01 Calculate double-torsional energy
212 if (wtor_d.gt.0) then
217 c print *,"Processor",myrank," computed Utord"
219 C 21/5/07 Calculate local sicdechain correlation energy
221 if (wsccor.gt.0.0d0) then
222 call eback_sc_corr(esccor)
226 c print *,"Processor",myrank," computed Usccorr"
228 C 12/1/95 Multi-body terms
232 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
233 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
234 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
235 cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
236 cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
243 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
244 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
245 cd write (iout,*) "multibody_hb ecorr",ecorr
247 c print *,"Processor",myrank," computed Ucorr"
249 C If performing constraint dynamics, call the constraint energy
250 C after the equilibration time
251 if(usampl.and.totT.gt.eq_time) then
259 time_enecalc=time_enecalc+MPI_Wtime()-time00
261 c print *,"Processor",myrank," computed Uconstr"
270 energia(2)=evdw2-evdw2_14
287 energia(8)=eello_turn3
288 energia(9)=eello_turn4
295 energia(19)=edihcnstr
297 energia(20)=Uconst+Uconst_back
299 c print *," Processor",myrank," calls SUM_ENERGY"
300 call sum_energy(energia,.true.)
301 c print *," Processor",myrank," left SUM_ENERGY"
303 time_sumene=time_sumene+MPI_Wtime()-time00
307 c-------------------------------------------------------------------------------
308 subroutine sum_energy(energia,reduce)
309 implicit real*8 (a-h,o-z)
314 cMS$ATTRIBUTES C :: proc_proc
320 include 'COMMON.SETUP'
321 include 'COMMON.IOUNITS'
322 double precision energia(0:n_ene),enebuff(0:n_ene+1)
323 include 'COMMON.FFIELD'
324 include 'COMMON.DERIV'
325 include 'COMMON.INTERACT'
326 include 'COMMON.SBRIDGE'
327 include 'COMMON.CHAIN'
329 include 'COMMON.CONTROL'
330 include 'COMMON.TIME1'
333 if (nfgtasks.gt.1 .and. reduce) then
335 write (iout,*) "energies before REDUCE"
336 call enerprint(energia)
340 enebuff(i)=energia(i)
343 call MPI_Barrier(FG_COMM,IERR)
344 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
346 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
347 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
349 write (iout,*) "energies after REDUCE"
350 call enerprint(energia)
353 time_Reduce=time_Reduce+MPI_Wtime()-time00
355 if (fg_rank.eq.0) then
359 evdw2=energia(2)+energia(18)
375 eello_turn3=energia(8)
376 eello_turn4=energia(9)
383 edihcnstr=energia(19)
388 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
389 & +wang*ebe+wtor*etors+wscloc*escloc
390 & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
391 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
392 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
393 & +wbond*estr+Uconst+wsccor*esccor
395 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
396 & +wang*ebe+wtor*etors+wscloc*escloc
397 & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
398 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
399 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
400 & +wbond*estr+Uconst+wsccor*esccor
406 if (isnan(etot).ne.0) energia(0)=1.0d+99
408 if (isnan(etot)) energia(0)=1.0d+99
413 idumm=proc_proc(etot,i)
415 call proc_proc(etot,i)
417 if(i.eq.1)energia(0)=1.0d+99
424 c-------------------------------------------------------------------------------
425 subroutine sum_gradient
426 implicit real*8 (a-h,o-z)
431 cMS$ATTRIBUTES C :: proc_proc
436 double precision gradbufc(3,maxres),gradbufx(3,maxres),
437 & glocbuf(4*maxres),gradbufc_sum(3,maxres)
439 include 'COMMON.SETUP'
440 include 'COMMON.IOUNITS'
441 include 'COMMON.FFIELD'
442 include 'COMMON.DERIV'
443 include 'COMMON.INTERACT'
444 include 'COMMON.SBRIDGE'
445 include 'COMMON.CHAIN'
447 include 'COMMON.CONTROL'
448 include 'COMMON.TIME1'
449 include 'COMMON.MAXGRAD'
454 write (iout,*) "sum_gradient gvdwc, gvdwx"
456 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
457 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
462 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
463 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
464 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
467 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
468 C in virtual-bond-vector coordinates
471 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
473 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
474 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
476 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
478 c write (iout,'(i5,3f10.5,2x,f10.5)')
479 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
481 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
483 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
484 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
492 gradbufc(j,i)=wsc*gvdwc(j,i)+
493 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
494 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
495 & wel_loc*gel_loc_long(j,i)+
496 & wcorr*gradcorr_long(j,i)+
497 & wcorr5*gradcorr5_long(j,i)+
498 & wcorr6*gradcorr6_long(j,i)+
499 & wturn6*gcorr6_turn_long(j,i)+
506 gradbufc(j,i)=wsc*gvdwc(j,i)+
507 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
508 & welec*gelc_long(j,i)+
510 & wel_loc*gel_loc_long(j,i)+
511 & wcorr*gradcorr_long(j,i)+
512 & wcorr5*gradcorr5_long(j,i)+
513 & wcorr6*gradcorr6_long(j,i)+
514 & wturn6*gcorr6_turn_long(j,i)+
520 if (nfgtasks.gt.1) then
523 write (iout,*) "gradbufc before allreduce"
525 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
531 gradbufc_sum(j,i)=gradbufc(j,i)
534 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
535 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
536 c time_reduce=time_reduce+MPI_Wtime()-time00
538 c write (iout,*) "gradbufc_sum after allreduce"
540 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
545 c time_allreduce=time_allreduce+MPI_Wtime()-time00
553 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
554 write (iout,*) (i," jgrad_start",jgrad_start(i),
555 & " jgrad_end ",jgrad_end(i),
556 & i=igrad_start,igrad_end)
559 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
560 c do not parallelize this part.
562 c do i=igrad_start,igrad_end
563 c do j=jgrad_start(i),jgrad_end(i)
565 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
570 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
574 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
578 write (iout,*) "gradbufc after summing"
580 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
587 write (iout,*) "gradbufc"
589 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
595 gradbufc_sum(j,i)=gradbufc(j,i)
600 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
604 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
609 c gradbufc(k,i)=0.0d0
613 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
618 write (iout,*) "gradbufc after summing"
620 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
628 gradbufc(k,nres)=0.0d0
633 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
634 & wel_loc*gel_loc(j,i)+
635 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
636 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
637 & wel_loc*gel_loc_long(j,i)+
638 & wcorr*gradcorr_long(j,i)+
639 & wcorr5*gradcorr5_long(j,i)+
640 & wcorr6*gradcorr6_long(j,i)+
641 & wturn6*gcorr6_turn_long(j,i))+
643 & wcorr*gradcorr(j,i)+
644 & wturn3*gcorr3_turn(j,i)+
645 & wturn4*gcorr4_turn(j,i)+
646 & wcorr5*gradcorr5(j,i)+
647 & wcorr6*gradcorr6(j,i)+
648 & wturn6*gcorr6_turn(j,i)+
649 & wsccor*gsccorc(j,i)
650 & +wscloc*gscloc(j,i)
652 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
653 & wel_loc*gel_loc(j,i)+
654 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
655 & welec*gelc_long(j,i)
656 & wel_loc*gel_loc_long(j,i)+
657 & wcorr*gcorr_long(j,i)+
658 & wcorr5*gradcorr5_long(j,i)+
659 & wcorr6*gradcorr6_long(j,i)+
660 & wturn6*gcorr6_turn_long(j,i))+
662 & wcorr*gradcorr(j,i)+
663 & wturn3*gcorr3_turn(j,i)+
664 & wturn4*gcorr4_turn(j,i)+
665 & wcorr5*gradcorr5(j,i)+
666 & wcorr6*gradcorr6(j,i)+
667 & wturn6*gcorr6_turn(j,i)+
668 & wsccor*gsccorc(j,i)
669 & +wscloc*gscloc(j,i)
671 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
673 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
674 & wsccor*gsccorx(j,i)
675 & +wscloc*gsclocx(j,i)
679 write (iout,*) "gloc before adding corr"
681 write (iout,*) i,gloc(i,icg)
685 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
686 & +wcorr5*g_corr5_loc(i)
687 & +wcorr6*g_corr6_loc(i)
688 & +wturn4*gel_loc_turn4(i)
689 & +wturn3*gel_loc_turn3(i)
690 & +wturn6*gel_loc_turn6(i)
691 & +wel_loc*gel_loc_loc(i)
692 & +wsccor*gsccor_loc(i)
695 write (iout,*) "gloc after adding corr"
697 write (iout,*) i,gloc(i,icg)
701 if (nfgtasks.gt.1) then
704 gradbufc(j,i)=gradc(j,i,icg)
705 gradbufx(j,i)=gradx(j,i,icg)
709 glocbuf(i)=gloc(i,icg)
712 call MPI_Barrier(FG_COMM,IERR)
713 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
715 call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
716 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
717 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
718 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
719 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
720 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
721 time_reduce=time_reduce+MPI_Wtime()-time00
723 write (iout,*) "gloc after reduce"
725 write (iout,*) i,gloc(i,icg)
730 if (gnorm_check) then
732 c Compute the maximum elements of the gradient
742 gcorr3_turn_max=0.0d0
743 gcorr4_turn_max=0.0d0
746 gcorr6_turn_max=0.0d0
756 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
757 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
758 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
759 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
760 & gvdwc_scp_max=gvdwc_scp_norm
761 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
762 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
763 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
764 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
765 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
766 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
767 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
768 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
769 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
770 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
771 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
772 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
773 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
775 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
776 & gcorr3_turn_max=gcorr3_turn_norm
777 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
779 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
780 & gcorr4_turn_max=gcorr4_turn_norm
781 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
782 if (gradcorr5_norm.gt.gradcorr5_max)
783 & gradcorr5_max=gradcorr5_norm
784 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
785 if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
786 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
788 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
789 & gcorr6_turn_max=gcorr6_turn_norm
790 gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
791 if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
792 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
793 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
794 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
795 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
796 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
797 if (gradx_scp_norm.gt.gradx_scp_max)
798 & gradx_scp_max=gradx_scp_norm
799 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
800 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
801 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
802 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
803 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
804 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
805 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
806 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
810 open(istat,file=statname,position="append")
812 open(istat,file=statname,access="append")
814 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
815 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
816 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
817 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
818 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
819 & gsccorx_max,gsclocx_max
821 if (gvdwc_max.gt.1.0d4) then
822 write (iout,*) "gvdwc gvdwx gradb gradbx"
824 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
825 & gradb(j,i),gradbx(j,i),j=1,3)
827 call pdbout(0.0d0,'cipiszcze',iout)
833 write (iout,*) "gradc gradx gloc"
835 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
836 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
840 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
844 c-------------------------------------------------------------------------------
845 subroutine rescale_weights(t_bath)
846 implicit real*8 (a-h,o-z)
848 include 'COMMON.IOUNITS'
849 include 'COMMON.FFIELD'
850 include 'COMMON.SBRIDGE'
851 double precision kfac /2.4d0/
852 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
854 c facT=2*temp0/(t_bath+temp0)
855 if (rescale_mode.eq.0) then
861 else if (rescale_mode.eq.1) then
862 facT=kfac/(kfac-1.0d0+t_bath/temp0)
863 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
864 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
865 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
866 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
867 else if (rescale_mode.eq.2) then
873 facT=licznik/dlog(dexp(x)+dexp(-x))
874 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
875 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
876 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
877 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
879 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
880 write (*,*) "Wrong RESCALE_MODE",rescale_mode
882 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
886 welec=weights(3)*fact
887 wcorr=weights(4)*fact3
888 wcorr5=weights(5)*fact4
889 wcorr6=weights(6)*fact5
890 wel_loc=weights(7)*fact2
891 wturn3=weights(8)*fact2
892 wturn4=weights(9)*fact3
893 wturn6=weights(10)*fact5
894 wtor=weights(13)*fact
895 wtor_d=weights(14)*fact2
896 wsccor=weights(21)*fact
900 C------------------------------------------------------------------------
901 subroutine enerprint(energia)
902 implicit real*8 (a-h,o-z)
904 include 'COMMON.IOUNITS'
905 include 'COMMON.FFIELD'
906 include 'COMMON.SBRIDGE'
908 double precision energia(0:n_ene)
913 evdw2=energia(2)+energia(18)
925 eello_turn3=energia(8)
926 eello_turn4=energia(9)
927 eello_turn6=energia(10)
933 edihcnstr=energia(19)
938 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
939 & estr,wbond,ebe,wang,
940 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
942 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
943 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
946 10 format (/'Virtual-chain energies:'//
947 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
948 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
949 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
950 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
951 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
952 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
953 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
954 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
955 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
956 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
957 & ' (SS bridges & dist. cnstr.)'/
958 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
959 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
960 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
961 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
962 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
963 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
964 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
965 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
966 & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
967 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
968 & 'UCONST= ',1pE16.6,' (Constraint energy)'/
969 & 'ETOT= ',1pE16.6,' (total)')
971 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
972 & estr,wbond,ebe,wang,
973 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
975 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
976 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
977 & ebr*nss,Uconst,etot
978 10 format (/'Virtual-chain energies:'//
979 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
980 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
981 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
982 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
983 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
984 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
985 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
986 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
987 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
988 & ' (SS bridges & dist. cnstr.)'/
989 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
990 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
991 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
992 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
993 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
994 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
995 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
996 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
997 & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
998 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
999 & 'UCONST=',1pE16.6,' (Constraint energy)'/
1000 & 'ETOT= ',1pE16.6,' (total)')
1004 C-----------------------------------------------------------------------
1005 subroutine elj(evdw)
1007 C This subroutine calculates the interaction energy of nonbonded side chains
1008 C assuming the LJ potential of interaction.
1010 implicit real*8 (a-h,o-z)
1011 include 'DIMENSIONS'
1012 parameter (accur=1.0d-10)
1013 include 'COMMON.GEO'
1014 include 'COMMON.VAR'
1015 include 'COMMON.LOCAL'
1016 include 'COMMON.CHAIN'
1017 include 'COMMON.DERIV'
1018 include 'COMMON.INTERACT'
1019 include 'COMMON.TORSION'
1020 include 'COMMON.SBRIDGE'
1021 include 'COMMON.NAMES'
1022 include 'COMMON.IOUNITS'
1023 include 'COMMON.CONTACTS'
1025 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1027 do i=iatsc_s,iatsc_e
1029 if (itypi.eq.21) cycle
1037 C Calculate SC interaction energy.
1039 do iint=1,nint_gr(i)
1040 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1041 cd & 'iend=',iend(i,iint)
1042 do j=istart(i,iint),iend(i,iint)
1044 if (itypj.eq.21) cycle
1048 C Change 12/1/95 to calculate four-body interactions
1049 rij=xj*xj+yj*yj+zj*zj
1051 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1052 eps0ij=eps(itypi,itypj)
1054 e1=fac*fac*aa(itypi,itypj)
1055 e2=fac*bb(itypi,itypj)
1057 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1058 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1059 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1060 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1061 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1062 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1065 C Calculate the components of the gradient in DC and X
1067 fac=-rrij*(e1+evdwij)
1072 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1073 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1074 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1075 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1079 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1083 C 12/1/95, revised on 5/20/97
1085 C Calculate the contact function. The ith column of the array JCONT will
1086 C contain the numbers of atoms that make contacts with the atom I (of numbers
1087 C greater than I). The arrays FACONT and GACONT will contain the values of
1088 C the contact function and its derivative.
1090 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1091 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1092 C Uncomment next line, if the correlation interactions are contact function only
1093 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1095 sigij=sigma(itypi,itypj)
1096 r0ij=rs0(itypi,itypj)
1098 C Check whether the SC's are not too far to make a contact.
1101 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1102 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1104 if (fcont.gt.0.0D0) then
1105 C If the SC-SC distance if close to sigma, apply spline.
1106 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1107 cAdam & fcont1,fprimcont1)
1108 cAdam fcont1=1.0d0-fcont1
1109 cAdam if (fcont1.gt.0.0d0) then
1110 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1111 cAdam fcont=fcont*fcont1
1113 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1114 cga eps0ij=1.0d0/dsqrt(eps0ij)
1116 cga gg(k)=gg(k)*eps0ij
1118 cga eps0ij=-evdwij*eps0ij
1119 C Uncomment for AL's type of SC correlation interactions.
1120 cadam eps0ij=-evdwij
1121 num_conti=num_conti+1
1122 jcont(num_conti,i)=j
1123 facont(num_conti,i)=fcont*eps0ij
1124 fprimcont=eps0ij*fprimcont/rij
1126 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1127 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1128 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1129 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1130 gacont(1,num_conti,i)=-fprimcont*xj
1131 gacont(2,num_conti,i)=-fprimcont*yj
1132 gacont(3,num_conti,i)=-fprimcont*zj
1133 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1134 cd write (iout,'(2i3,3f10.5)')
1135 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1141 num_cont(i)=num_conti
1145 gvdwc(j,i)=expon*gvdwc(j,i)
1146 gvdwx(j,i)=expon*gvdwx(j,i)
1149 C******************************************************************************
1153 C To save time, the factor of EXPON has been extracted from ALL components
1154 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1157 C******************************************************************************
1160 C-----------------------------------------------------------------------------
1161 subroutine eljk(evdw)
1163 C This subroutine calculates the interaction energy of nonbonded side chains
1164 C assuming the LJK potential of interaction.
1166 implicit real*8 (a-h,o-z)
1167 include 'DIMENSIONS'
1168 include 'COMMON.GEO'
1169 include 'COMMON.VAR'
1170 include 'COMMON.LOCAL'
1171 include 'COMMON.CHAIN'
1172 include 'COMMON.DERIV'
1173 include 'COMMON.INTERACT'
1174 include 'COMMON.IOUNITS'
1175 include 'COMMON.NAMES'
1178 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1180 do i=iatsc_s,iatsc_e
1182 if (itypi.eq.21) cycle
1188 C Calculate SC interaction energy.
1190 do iint=1,nint_gr(i)
1191 do j=istart(i,iint),iend(i,iint)
1193 if (itypj.eq.21) cycle
1197 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1198 fac_augm=rrij**expon
1199 e_augm=augm(itypi,itypj)*fac_augm
1200 r_inv_ij=dsqrt(rrij)
1202 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1203 fac=r_shift_inv**expon
1204 e1=fac*fac*aa(itypi,itypj)
1205 e2=fac*bb(itypi,itypj)
1207 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1208 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1209 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1210 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1211 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1212 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1213 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1216 C Calculate the components of the gradient in DC and X
1218 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1223 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1224 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1225 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1226 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1230 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1238 gvdwc(j,i)=expon*gvdwc(j,i)
1239 gvdwx(j,i)=expon*gvdwx(j,i)
1244 C-----------------------------------------------------------------------------
1245 subroutine ebp(evdw)
1247 C This subroutine calculates the interaction energy of nonbonded side chains
1248 C assuming the Berne-Pechukas potential of interaction.
1250 implicit real*8 (a-h,o-z)
1251 include 'DIMENSIONS'
1252 include 'COMMON.GEO'
1253 include 'COMMON.VAR'
1254 include 'COMMON.LOCAL'
1255 include 'COMMON.CHAIN'
1256 include 'COMMON.DERIV'
1257 include 'COMMON.NAMES'
1258 include 'COMMON.INTERACT'
1259 include 'COMMON.IOUNITS'
1260 include 'COMMON.CALC'
1261 common /srutu/ icall
1262 c double precision rrsave(maxdim)
1265 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1267 c if (icall.eq.0) then
1273 do i=iatsc_s,iatsc_e
1275 if (itypi.eq.21) cycle
1280 dxi=dc_norm(1,nres+i)
1281 dyi=dc_norm(2,nres+i)
1282 dzi=dc_norm(3,nres+i)
1283 c dsci_inv=dsc_inv(itypi)
1284 dsci_inv=vbld_inv(i+nres)
1286 C Calculate SC interaction energy.
1288 do iint=1,nint_gr(i)
1289 do j=istart(i,iint),iend(i,iint)
1292 if (itypj.eq.21) cycle
1293 c dscj_inv=dsc_inv(itypj)
1294 dscj_inv=vbld_inv(j+nres)
1295 chi1=chi(itypi,itypj)
1296 chi2=chi(itypj,itypi)
1303 alf12=0.5D0*(alf1+alf2)
1304 C For diagnostics only!!!
1317 dxj=dc_norm(1,nres+j)
1318 dyj=dc_norm(2,nres+j)
1319 dzj=dc_norm(3,nres+j)
1320 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1321 cd if (icall.eq.0) then
1327 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1329 C Calculate whole angle-dependent part of epsilon and contributions
1330 C to its derivatives
1331 fac=(rrij*sigsq)**expon2
1332 e1=fac*fac*aa(itypi,itypj)
1333 e2=fac*bb(itypi,itypj)
1334 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1335 eps2der=evdwij*eps3rt
1336 eps3der=evdwij*eps2rt
1337 evdwij=evdwij*eps2rt*eps3rt
1340 sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1341 epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1342 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1343 cd & restyp(itypi),i,restyp(itypj),j,
1344 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1345 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1346 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1349 C Calculate gradient components.
1350 e1=e1*eps1*eps2rt**2*eps3rt**2
1351 fac=-expon*(e1+evdwij)
1354 C Calculate radial part of the gradient
1358 C Calculate the angular part of the gradient and sum add the contributions
1359 C to the appropriate components of the Cartesian gradient.
1367 C-----------------------------------------------------------------------------
1368 subroutine egb(evdw)
1370 C This subroutine calculates the interaction energy of nonbonded side chains
1371 C assuming the Gay-Berne potential of interaction.
1373 implicit real*8 (a-h,o-z)
1374 include 'DIMENSIONS'
1375 include 'COMMON.GEO'
1376 include 'COMMON.VAR'
1377 include 'COMMON.LOCAL'
1378 include 'COMMON.CHAIN'
1379 include 'COMMON.DERIV'
1380 include 'COMMON.NAMES'
1381 include 'COMMON.INTERACT'
1382 include 'COMMON.IOUNITS'
1383 include 'COMMON.CALC'
1384 include 'COMMON.CONTROL'
1387 ccccc energy_dec=.false.
1388 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1391 c if (icall.eq.0) lprn=.false.
1393 do i=iatsc_s,iatsc_e
1395 if (itypi.eq.21) cycle
1400 dxi=dc_norm(1,nres+i)
1401 dyi=dc_norm(2,nres+i)
1402 dzi=dc_norm(3,nres+i)
1403 c dsci_inv=dsc_inv(itypi)
1404 dsci_inv=vbld_inv(i+nres)
1405 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1406 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1408 C Calculate SC interaction energy.
1410 do iint=1,nint_gr(i)
1411 do j=istart(i,iint),iend(i,iint)
1414 if (itypj.eq.21) cycle
1415 c dscj_inv=dsc_inv(itypj)
1416 dscj_inv=vbld_inv(j+nres)
1417 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1418 c & 1.0d0/vbld(j+nres)
1419 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1420 sig0ij=sigma(itypi,itypj)
1421 chi1=chi(itypi,itypj)
1422 chi2=chi(itypj,itypi)
1429 alf12=0.5D0*(alf1+alf2)
1430 C For diagnostics only!!!
1443 dxj=dc_norm(1,nres+j)
1444 dyj=dc_norm(2,nres+j)
1445 dzj=dc_norm(3,nres+j)
1446 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1447 c write (iout,*) "j",j," dc_norm",
1448 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1449 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1451 C Calculate angle-dependent terms of energy and contributions to their
1455 sig=sig0ij*dsqrt(sigsq)
1456 rij_shift=1.0D0/rij-sig+sig0ij
1457 c for diagnostics; uncomment
1458 c rij_shift=1.2*sig0ij
1459 C I hate to put IF's in the loops, but here don't have another choice!!!!
1460 if (rij_shift.le.0.0D0) then
1462 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1463 cd & restyp(itypi),i,restyp(itypj),j,
1464 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1468 c---------------------------------------------------------------
1469 rij_shift=1.0D0/rij_shift
1470 fac=rij_shift**expon
1471 e1=fac*fac*aa(itypi,itypj)
1472 e2=fac*bb(itypi,itypj)
1473 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1474 eps2der=evdwij*eps3rt
1475 eps3der=evdwij*eps2rt
1476 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1477 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1478 evdwij=evdwij*eps2rt*eps3rt
1481 sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1482 epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1483 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1484 & restyp(itypi),i,restyp(itypj),j,
1485 & epsi,sigm,chi1,chi2,chip1,chip2,
1486 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1487 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1491 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1494 C Calculate gradient components.
1495 e1=e1*eps1*eps2rt**2*eps3rt**2
1496 fac=-expon*(e1+evdwij)*rij_shift
1500 C Calculate the radial part of the gradient
1504 C Calculate angular part of the gradient.
1509 c write (iout,*) "Number of loop steps in EGB:",ind
1510 cccc energy_dec=.false.
1513 C-----------------------------------------------------------------------------
1514 subroutine egbv(evdw)
1516 C This subroutine calculates the interaction energy of nonbonded side chains
1517 C assuming the Gay-Berne-Vorobjev potential of interaction.
1519 implicit real*8 (a-h,o-z)
1520 include 'DIMENSIONS'
1521 include 'COMMON.GEO'
1522 include 'COMMON.VAR'
1523 include 'COMMON.LOCAL'
1524 include 'COMMON.CHAIN'
1525 include 'COMMON.DERIV'
1526 include 'COMMON.NAMES'
1527 include 'COMMON.INTERACT'
1528 include 'COMMON.IOUNITS'
1529 include 'COMMON.CALC'
1530 common /srutu/ icall
1533 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1536 c if (icall.eq.0) lprn=.true.
1538 do i=iatsc_s,iatsc_e
1540 if (itypi.eq.21) cycle
1545 dxi=dc_norm(1,nres+i)
1546 dyi=dc_norm(2,nres+i)
1547 dzi=dc_norm(3,nres+i)
1548 c dsci_inv=dsc_inv(itypi)
1549 dsci_inv=vbld_inv(i+nres)
1551 C Calculate SC interaction energy.
1553 do iint=1,nint_gr(i)
1554 do j=istart(i,iint),iend(i,iint)
1557 if (itypj.eq.21) cycle
1558 c dscj_inv=dsc_inv(itypj)
1559 dscj_inv=vbld_inv(j+nres)
1560 sig0ij=sigma(itypi,itypj)
1561 r0ij=r0(itypi,itypj)
1562 chi1=chi(itypi,itypj)
1563 chi2=chi(itypj,itypi)
1570 alf12=0.5D0*(alf1+alf2)
1571 C For diagnostics only!!!
1584 dxj=dc_norm(1,nres+j)
1585 dyj=dc_norm(2,nres+j)
1586 dzj=dc_norm(3,nres+j)
1587 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1589 C Calculate angle-dependent terms of energy and contributions to their
1593 sig=sig0ij*dsqrt(sigsq)
1594 rij_shift=1.0D0/rij-sig+r0ij
1595 C I hate to put IF's in the loops, but here don't have another choice!!!!
1596 if (rij_shift.le.0.0D0) then
1601 c---------------------------------------------------------------
1602 rij_shift=1.0D0/rij_shift
1603 fac=rij_shift**expon
1604 e1=fac*fac*aa(itypi,itypj)
1605 e2=fac*bb(itypi,itypj)
1606 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1607 eps2der=evdwij*eps3rt
1608 eps3der=evdwij*eps2rt
1609 fac_augm=rrij**expon
1610 e_augm=augm(itypi,itypj)*fac_augm
1611 evdwij=evdwij*eps2rt*eps3rt
1612 evdw=evdw+evdwij+e_augm
1614 sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1615 epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1616 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1617 & restyp(itypi),i,restyp(itypj),j,
1618 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1619 & chi1,chi2,chip1,chip2,
1620 & eps1,eps2rt**2,eps3rt**2,
1621 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1624 C Calculate gradient components.
1625 e1=e1*eps1*eps2rt**2*eps3rt**2
1626 fac=-expon*(e1+evdwij)*rij_shift
1628 fac=rij*fac-2*expon*rrij*e_augm
1629 C Calculate the radial part of the gradient
1633 C Calculate angular part of the gradient.
1639 C-----------------------------------------------------------------------------
1640 subroutine sc_angular
1641 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1642 C om12. Called by ebp, egb, and egbv.
1644 include 'COMMON.CALC'
1645 include 'COMMON.IOUNITS'
1649 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1650 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1651 om12=dxi*dxj+dyi*dyj+dzi*dzj
1653 C Calculate eps1(om12) and its derivative in om12
1654 faceps1=1.0D0-om12*chiom12
1655 faceps1_inv=1.0D0/faceps1
1656 eps1=dsqrt(faceps1_inv)
1657 C Following variable is eps1*deps1/dom12
1658 eps1_om12=faceps1_inv*chiom12
1663 c write (iout,*) "om12",om12," eps1",eps1
1664 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1669 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1670 sigsq=1.0D0-facsig*faceps1_inv
1671 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1672 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1673 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1679 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1680 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1682 C Calculate eps2 and its derivatives in om1, om2, and om12.
1685 chipom12=chip12*om12
1686 facp=1.0D0-om12*chipom12
1688 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1689 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1690 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1691 C Following variable is the square root of eps2
1692 eps2rt=1.0D0-facp1*facp_inv
1693 C Following three variables are the derivatives of the square root of eps
1694 C in om1, om2, and om12.
1695 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1696 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1697 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1698 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1699 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1700 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1701 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1702 c & " eps2rt_om12",eps2rt_om12
1703 C Calculate whole angle-dependent part of epsilon and contributions
1704 C to its derivatives
1707 C----------------------------------------------------------------------------
1709 implicit real*8 (a-h,o-z)
1710 include 'DIMENSIONS'
1711 include 'COMMON.CHAIN'
1712 include 'COMMON.DERIV'
1713 include 'COMMON.CALC'
1714 include 'COMMON.IOUNITS'
1715 double precision dcosom1(3),dcosom2(3)
1716 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1717 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1718 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1719 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
1723 c eom12=evdwij*eps1_om12
1725 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1726 c & " sigder",sigder
1727 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1728 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1730 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1731 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1734 gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1736 c write (iout,*) "gg",(gg(k),k=1,3)
1738 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1739 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1740 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1741 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1742 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1743 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1744 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1745 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1746 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1747 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1750 C Calculate the components of the gradient in DC and X
1754 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1758 gvdwc(l,i)=gvdwc(l,i)-gg(l)
1759 gvdwc(l,j)=gvdwc(l,j)+gg(l)
1763 C-----------------------------------------------------------------------
1764 subroutine e_softsphere(evdw)
1766 C This subroutine calculates the interaction energy of nonbonded side chains
1767 C assuming the LJ potential of interaction.
1769 implicit real*8 (a-h,o-z)
1770 include 'DIMENSIONS'
1771 parameter (accur=1.0d-10)
1772 include 'COMMON.GEO'
1773 include 'COMMON.VAR'
1774 include 'COMMON.LOCAL'
1775 include 'COMMON.CHAIN'
1776 include 'COMMON.DERIV'
1777 include 'COMMON.INTERACT'
1778 include 'COMMON.TORSION'
1779 include 'COMMON.SBRIDGE'
1780 include 'COMMON.NAMES'
1781 include 'COMMON.IOUNITS'
1782 include 'COMMON.CONTACTS'
1784 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1786 do i=iatsc_s,iatsc_e
1788 if (itypi.eq.21) cycle
1794 C Calculate SC interaction energy.
1796 do iint=1,nint_gr(i)
1797 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1798 cd & 'iend=',iend(i,iint)
1799 do j=istart(i,iint),iend(i,iint)
1801 if (itypj.eq.21) cycle
1805 rij=xj*xj+yj*yj+zj*zj
1806 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1807 r0ij=r0(itypi,itypj)
1809 c print *,i,j,r0ij,dsqrt(rij)
1810 if (rij.lt.r0ijsq) then
1811 evdwij=0.25d0*(rij-r0ijsq)**2
1819 C Calculate the components of the gradient in DC and X
1825 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1826 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1827 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1828 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1832 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1840 C--------------------------------------------------------------------------
1841 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1844 C Soft-sphere potential of p-p interaction
1846 implicit real*8 (a-h,o-z)
1847 include 'DIMENSIONS'
1848 include 'COMMON.CONTROL'
1849 include 'COMMON.IOUNITS'
1850 include 'COMMON.GEO'
1851 include 'COMMON.VAR'
1852 include 'COMMON.LOCAL'
1853 include 'COMMON.CHAIN'
1854 include 'COMMON.DERIV'
1855 include 'COMMON.INTERACT'
1856 include 'COMMON.CONTACTS'
1857 include 'COMMON.TORSION'
1858 include 'COMMON.VECTORS'
1859 include 'COMMON.FFIELD'
1861 cd write(iout,*) 'In EELEC_soft_sphere'
1868 do i=iatel_s,iatel_e
1869 if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
1873 xmedi=c(1,i)+0.5d0*dxi
1874 ymedi=c(2,i)+0.5d0*dyi
1875 zmedi=c(3,i)+0.5d0*dzi
1877 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1878 do j=ielstart(i),ielend(i)
1879 if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
1883 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1884 r0ij=rpp(iteli,itelj)
1889 xj=c(1,j)+0.5D0*dxj-xmedi
1890 yj=c(2,j)+0.5D0*dyj-ymedi
1891 zj=c(3,j)+0.5D0*dzj-zmedi
1892 rij=xj*xj+yj*yj+zj*zj
1893 if (rij.lt.r0ijsq) then
1894 evdw1ij=0.25d0*(rij-r0ijsq)**2
1902 C Calculate contributions to the Cartesian gradient.
1908 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1909 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1912 * Loop over residues i+1 thru j-1.
1916 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
1921 cgrad do i=nnt,nct-1
1923 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1925 cgrad do j=i+1,nct-1
1927 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
1933 c------------------------------------------------------------------------------
1934 subroutine vec_and_deriv
1935 implicit real*8 (a-h,o-z)
1936 include 'DIMENSIONS'
1940 include 'COMMON.IOUNITS'
1941 include 'COMMON.GEO'
1942 include 'COMMON.VAR'
1943 include 'COMMON.LOCAL'
1944 include 'COMMON.CHAIN'
1945 include 'COMMON.VECTORS'
1946 include 'COMMON.SETUP'
1947 include 'COMMON.TIME1'
1948 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1949 C Compute the local reference systems. For reference system (i), the
1950 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1951 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1953 do i=ivec_start,ivec_end
1957 if (i.eq.nres-1) then
1958 C Case of the last full residue
1959 C Compute the Z-axis
1960 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1961 costh=dcos(pi-theta(nres))
1962 fac=1.0d0/dsqrt(1.0d0-costh*costh)
1966 C Compute the derivatives of uz
1968 uzder(2,1,1)=-dc_norm(3,i-1)
1969 uzder(3,1,1)= dc_norm(2,i-1)
1970 uzder(1,2,1)= dc_norm(3,i-1)
1972 uzder(3,2,1)=-dc_norm(1,i-1)
1973 uzder(1,3,1)=-dc_norm(2,i-1)
1974 uzder(2,3,1)= dc_norm(1,i-1)
1977 uzder(2,1,2)= dc_norm(3,i)
1978 uzder(3,1,2)=-dc_norm(2,i)
1979 uzder(1,2,2)=-dc_norm(3,i)
1981 uzder(3,2,2)= dc_norm(1,i)
1982 uzder(1,3,2)= dc_norm(2,i)
1983 uzder(2,3,2)=-dc_norm(1,i)
1985 C Compute the Y-axis
1988 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1990 C Compute the derivatives of uy
1993 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1994 & -dc_norm(k,i)*dc_norm(j,i-1)
1995 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1997 uyder(j,j,1)=uyder(j,j,1)-costh
1998 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2003 uygrad(l,k,j,i)=uyder(l,k,j)
2004 uzgrad(l,k,j,i)=uzder(l,k,j)
2008 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2009 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2010 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2011 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2014 C Compute the Z-axis
2015 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2016 costh=dcos(pi-theta(i+2))
2017 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2021 C Compute the derivatives of uz
2023 uzder(2,1,1)=-dc_norm(3,i+1)
2024 uzder(3,1,1)= dc_norm(2,i+1)
2025 uzder(1,2,1)= dc_norm(3,i+1)
2027 uzder(3,2,1)=-dc_norm(1,i+1)
2028 uzder(1,3,1)=-dc_norm(2,i+1)
2029 uzder(2,3,1)= dc_norm(1,i+1)
2032 uzder(2,1,2)= dc_norm(3,i)
2033 uzder(3,1,2)=-dc_norm(2,i)
2034 uzder(1,2,2)=-dc_norm(3,i)
2036 uzder(3,2,2)= dc_norm(1,i)
2037 uzder(1,3,2)= dc_norm(2,i)
2038 uzder(2,3,2)=-dc_norm(1,i)
2040 C Compute the Y-axis
2043 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2045 C Compute the derivatives of uy
2048 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2049 & -dc_norm(k,i)*dc_norm(j,i+1)
2050 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2052 uyder(j,j,1)=uyder(j,j,1)-costh
2053 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2058 uygrad(l,k,j,i)=uyder(l,k,j)
2059 uzgrad(l,k,j,i)=uzder(l,k,j)
2063 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2064 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2065 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2066 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2070 vbld_inv_temp(1)=vbld_inv(i+1)
2071 if (i.lt.nres-1) then
2072 vbld_inv_temp(2)=vbld_inv(i+2)
2074 vbld_inv_temp(2)=vbld_inv(i)
2079 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2080 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2085 #if defined(PARVEC) && defined(MPI)
2086 if (nfgtasks1.gt.1) then
2088 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2089 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2090 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2091 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2092 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2094 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2095 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2097 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2098 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2099 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2100 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2101 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2102 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2103 time_gather=time_gather+MPI_Wtime()-time00
2105 c if (fg_rank.eq.0) then
2106 c write (iout,*) "Arrays UY and UZ"
2108 c write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2115 C-----------------------------------------------------------------------------
2116 subroutine check_vecgrad
2117 implicit real*8 (a-h,o-z)
2118 include 'DIMENSIONS'
2119 include 'COMMON.IOUNITS'
2120 include 'COMMON.GEO'
2121 include 'COMMON.VAR'
2122 include 'COMMON.LOCAL'
2123 include 'COMMON.CHAIN'
2124 include 'COMMON.VECTORS'
2125 dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2126 dimension uyt(3,maxres),uzt(3,maxres)
2127 dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2128 double precision delta /1.0d-7/
2131 crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2132 crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2133 crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2134 cd write(iout,'(2i5,2(3f10.5,5x))') i,1,
2135 cd & (dc_norm(if90,i),if90=1,3)
2136 cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2137 cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2138 cd write(iout,'(a)')
2144 uygradt(l,k,j,i)=uygrad(l,k,j,i)
2145 uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2158 cd write (iout,*) 'i=',i
2160 erij(k)=dc_norm(k,i)
2164 dc_norm(k,i)=erij(k)
2166 dc_norm(j,i)=dc_norm(j,i)+delta
2167 c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2169 c dc_norm(k,i)=dc_norm(k,i)/fac
2171 c write (iout,*) (dc_norm(k,i),k=1,3)
2172 c write (iout,*) (erij(k),k=1,3)
2175 uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2176 uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2177 uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2178 uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2180 c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2181 c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2182 c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2185 dc_norm(k,i)=erij(k)
2188 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2189 cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2190 cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2191 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2192 cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2193 cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2194 cd write (iout,'(a)')
2199 C--------------------------------------------------------------------------
2200 subroutine set_matrices
2201 implicit real*8 (a-h,o-z)
2202 include 'DIMENSIONS'
2205 include "COMMON.SETUP"
2207 integer status(MPI_STATUS_SIZE)
2209 include 'COMMON.IOUNITS'
2210 include 'COMMON.GEO'
2211 include 'COMMON.VAR'
2212 include 'COMMON.LOCAL'
2213 include 'COMMON.CHAIN'
2214 include 'COMMON.DERIV'
2215 include 'COMMON.INTERACT'
2216 include 'COMMON.CONTACTS'
2217 include 'COMMON.TORSION'
2218 include 'COMMON.VECTORS'
2219 include 'COMMON.FFIELD'
2220 double precision auxvec(2),auxmat(2,2)
2222 C Compute the virtual-bond-torsional-angle dependent quantities needed
2223 C to calculate the el-loc multibody terms of various order.
2226 do i=ivec_start+2,ivec_end+2
2230 if (i .lt. nres+1) then
2267 if (i .gt. 3 .and. i .lt. nres+1) then
2268 obrot_der(1,i-2)=-sin1
2269 obrot_der(2,i-2)= cos1
2270 Ugder(1,1,i-2)= sin1
2271 Ugder(1,2,i-2)=-cos1
2272 Ugder(2,1,i-2)=-cos1
2273 Ugder(2,2,i-2)=-sin1
2276 obrot2_der(1,i-2)=-dwasin2
2277 obrot2_der(2,i-2)= dwacos2
2278 Ug2der(1,1,i-2)= dwasin2
2279 Ug2der(1,2,i-2)=-dwacos2
2280 Ug2der(2,1,i-2)=-dwacos2
2281 Ug2der(2,2,i-2)=-dwasin2
2283 obrot_der(1,i-2)=0.0d0
2284 obrot_der(2,i-2)=0.0d0
2285 Ugder(1,1,i-2)=0.0d0
2286 Ugder(1,2,i-2)=0.0d0
2287 Ugder(2,1,i-2)=0.0d0
2288 Ugder(2,2,i-2)=0.0d0
2289 obrot2_der(1,i-2)=0.0d0
2290 obrot2_der(2,i-2)=0.0d0
2291 Ug2der(1,1,i-2)=0.0d0
2292 Ug2der(1,2,i-2)=0.0d0
2293 Ug2der(2,1,i-2)=0.0d0
2294 Ug2der(2,2,i-2)=0.0d0
2296 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2297 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2298 iti = itortyp(itype(i-2))
2302 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2303 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2304 iti1 = itortyp(itype(i-1))
2308 cd write (iout,*) '*******i',i,' iti1',iti
2309 cd write (iout,*) 'b1',b1(:,iti)
2310 cd write (iout,*) 'b2',b2(:,iti)
2311 cd write (iout,*) 'Ug',Ug(:,:,i-2)
2312 c if (i .gt. iatel_s+2) then
2313 if (i .gt. nnt+2) then
2314 call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2315 call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2316 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2318 call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2319 call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2320 call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2321 call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2322 call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2333 DtUg2(l,k,i-2)=0.0d0
2337 call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2338 call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2340 muder(k,i-2)=Ub2der(k,i-2)
2342 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2343 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2344 iti1 = itortyp(itype(i-1))
2349 mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2351 cd write (iout,*) 'mu ',mu(:,i-2)
2352 cd write (iout,*) 'mu1',mu1(:,i-2)
2353 cd write (iout,*) 'mu2',mu2(:,i-2)
2354 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2356 call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2357 call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2358 call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2359 call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2360 call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2361 C Vectors and matrices dependent on a single virtual-bond dihedral.
2362 call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2363 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2364 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2365 call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2366 call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2367 call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2368 call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2369 call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2370 call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2373 C Matrices dependent on two consecutive virtual-bond dihedrals.
2374 C The order of matrices is from left to right.
2375 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2377 c do i=max0(ivec_start,2),ivec_end
2379 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2380 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2381 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2382 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2383 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2384 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2385 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2386 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2389 #if defined(MPI) && defined(PARMAT)
2391 c if (fg_rank.eq.0) then
2392 write (iout,*) "Arrays UG and UGDER before GATHER"
2394 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2395 & ((ug(l,k,i),l=1,2),k=1,2),
2396 & ((ugder(l,k,i),l=1,2),k=1,2)
2398 write (iout,*) "Arrays UG2 and UG2DER"
2400 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2401 & ((ug2(l,k,i),l=1,2),k=1,2),
2402 & ((ug2der(l,k,i),l=1,2),k=1,2)
2404 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2406 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2407 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2408 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2410 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2412 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2413 & costab(i),sintab(i),costab2(i),sintab2(i)
2415 write (iout,*) "Array MUDER"
2417 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2421 if (nfgtasks.gt.1) then
2423 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2424 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2425 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2427 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2428 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2430 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2431 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2433 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2434 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2436 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2437 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2439 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2440 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2442 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2443 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2445 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2446 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2447 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2448 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2449 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2450 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2451 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2452 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2453 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2454 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2455 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2456 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2457 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2459 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2460 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2462 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2463 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2465 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2466 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2468 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2469 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2471 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2472 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2474 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2475 & ivec_count(fg_rank1),
2476 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2478 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2479 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2481 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2482 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2484 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2485 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2487 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2488 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2490 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2491 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2493 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2494 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2496 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2497 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2499 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2500 & ivec_count(fg_rank1),
2501 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2503 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2504 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2506 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2507 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2509 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2510 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2512 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2513 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2515 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2516 & ivec_count(fg_rank1),
2517 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2519 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2520 & ivec_count(fg_rank1),
2521 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2523 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2524 & ivec_count(fg_rank1),
2525 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2526 & MPI_MAT2,FG_COMM1,IERR)
2527 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2528 & ivec_count(fg_rank1),
2529 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2530 & MPI_MAT2,FG_COMM1,IERR)
2533 c Passes matrix info through the ring
2536 if (irecv.lt.0) irecv=nfgtasks1-1
2539 if (inext.ge.nfgtasks1) inext=0
2541 c write (iout,*) "isend",isend," irecv",irecv
2543 lensend=lentyp(isend)
2544 lenrecv=lentyp(irecv)
2545 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
2546 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2547 c & MPI_ROTAT1(lensend),inext,2200+isend,
2548 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2549 c & iprev,2200+irecv,FG_COMM,status,IERR)
2550 c write (iout,*) "Gather ROTAT1"
2552 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2553 c & MPI_ROTAT2(lensend),inext,3300+isend,
2554 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2555 c & iprev,3300+irecv,FG_COMM,status,IERR)
2556 c write (iout,*) "Gather ROTAT2"
2558 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2559 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
2560 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2561 & iprev,4400+irecv,FG_COMM,status,IERR)
2562 c write (iout,*) "Gather ROTAT_OLD"
2564 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2565 & MPI_PRECOMP11(lensend),inext,5500+isend,
2566 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2567 & iprev,5500+irecv,FG_COMM,status,IERR)
2568 c write (iout,*) "Gather PRECOMP11"
2570 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2571 & MPI_PRECOMP12(lensend),inext,6600+isend,
2572 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2573 & iprev,6600+irecv,FG_COMM,status,IERR)
2574 c write (iout,*) "Gather PRECOMP12"
2576 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2578 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2579 & MPI_ROTAT2(lensend),inext,7700+isend,
2580 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2581 & iprev,7700+irecv,FG_COMM,status,IERR)
2582 c write (iout,*) "Gather PRECOMP21"
2584 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2585 & MPI_PRECOMP22(lensend),inext,8800+isend,
2586 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2587 & iprev,8800+irecv,FG_COMM,status,IERR)
2588 c write (iout,*) "Gather PRECOMP22"
2590 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2591 & MPI_PRECOMP23(lensend),inext,9900+isend,
2592 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2593 & MPI_PRECOMP23(lenrecv),
2594 & iprev,9900+irecv,FG_COMM,status,IERR)
2595 c write (iout,*) "Gather PRECOMP23"
2600 if (irecv.lt.0) irecv=nfgtasks1-1
2603 time_gather=time_gather+MPI_Wtime()-time00
2606 c if (fg_rank.eq.0) then
2607 write (iout,*) "Arrays UG and UGDER"
2609 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2610 & ((ug(l,k,i),l=1,2),k=1,2),
2611 & ((ugder(l,k,i),l=1,2),k=1,2)
2613 write (iout,*) "Arrays UG2 and UG2DER"
2615 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2616 & ((ug2(l,k,i),l=1,2),k=1,2),
2617 & ((ug2der(l,k,i),l=1,2),k=1,2)
2619 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2621 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2622 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2623 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2625 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2627 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2628 & costab(i),sintab(i),costab2(i),sintab2(i)
2630 write (iout,*) "Array MUDER"
2632 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2638 cd iti = itortyp(itype(i))
2641 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2642 cd & (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2647 C--------------------------------------------------------------------------
2648 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2650 C This subroutine calculates the average interaction energy and its gradient
2651 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2652 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2653 C The potential depends both on the distance of peptide-group centers and on
2654 C the orientation of the CA-CA virtual bonds.
2656 implicit real*8 (a-h,o-z)
2660 include 'DIMENSIONS'
2661 include 'COMMON.CONTROL'
2662 include 'COMMON.SETUP'
2663 include 'COMMON.IOUNITS'
2664 include 'COMMON.GEO'
2665 include 'COMMON.VAR'
2666 include 'COMMON.LOCAL'
2667 include 'COMMON.CHAIN'
2668 include 'COMMON.DERIV'
2669 include 'COMMON.INTERACT'
2670 include 'COMMON.CONTACTS'
2671 include 'COMMON.TORSION'
2672 include 'COMMON.VECTORS'
2673 include 'COMMON.FFIELD'
2674 include 'COMMON.TIME1'
2675 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2676 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2677 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2678 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2679 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2680 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2682 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2684 double precision scal_el /1.0d0/
2686 double precision scal_el /0.5d0/
2689 C 13-go grudnia roku pamietnego...
2690 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2691 & 0.0d0,1.0d0,0.0d0,
2692 & 0.0d0,0.0d0,1.0d0/
2693 cd write(iout,*) 'In EELEC'
2695 cd write(iout,*) 'Type',i
2696 cd write(iout,*) 'B1',B1(:,i)
2697 cd write(iout,*) 'B2',B2(:,i)
2698 cd write(iout,*) 'CC',CC(:,:,i)
2699 cd write(iout,*) 'DD',DD(:,:,i)
2700 cd write(iout,*) 'EE',EE(:,:,i)
2702 cd call check_vecgrad
2704 if (icheckgrad.eq.1) then
2706 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2708 dc_norm(k,i)=dc(k,i)*fac
2710 c write (iout,*) 'i',i,' fac',fac
2713 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2714 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2715 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2716 c call vec_and_deriv
2722 time_mat=time_mat+MPI_Wtime()-time01
2726 cd write (iout,*) 'i=',i
2728 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2731 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2732 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2745 cd print '(a)','Enter EELEC'
2746 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2748 gel_loc_loc(i)=0.0d0
2753 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2755 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2757 do i=iturn3_start,iturn3_end
2758 if (itype(i).eq.21 .or. itype(i+1).eq.21
2759 & .or. itype(i+2).eq.21 .or. itype(i+3).eq.21) cycle
2763 dx_normi=dc_norm(1,i)
2764 dy_normi=dc_norm(2,i)
2765 dz_normi=dc_norm(3,i)
2766 xmedi=c(1,i)+0.5d0*dxi
2767 ymedi=c(2,i)+0.5d0*dyi
2768 zmedi=c(3,i)+0.5d0*dzi
2770 call eelecij(i,i+2,ees,evdw1,eel_loc)
2771 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2772 num_cont_hb(i)=num_conti
2774 do i=iturn4_start,iturn4_end
2775 if (itype(i).eq.21 .or. itype(i+1).eq.21
2776 & .or. itype(i+3).eq.21
2777 & .or. itype(i+4).eq.21) cycle
2781 dx_normi=dc_norm(1,i)
2782 dy_normi=dc_norm(2,i)
2783 dz_normi=dc_norm(3,i)
2784 xmedi=c(1,i)+0.5d0*dxi
2785 ymedi=c(2,i)+0.5d0*dyi
2786 zmedi=c(3,i)+0.5d0*dzi
2787 num_conti=num_cont_hb(i)
2788 call eelecij(i,i+3,ees,evdw1,eel_loc)
2789 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.21)
2790 & call eturn4(i,eello_turn4)
2791 num_cont_hb(i)=num_conti
2794 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2796 do i=iatel_s,iatel_e
2797 if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
2801 dx_normi=dc_norm(1,i)
2802 dy_normi=dc_norm(2,i)
2803 dz_normi=dc_norm(3,i)
2804 xmedi=c(1,i)+0.5d0*dxi
2805 ymedi=c(2,i)+0.5d0*dyi
2806 zmedi=c(3,i)+0.5d0*dzi
2807 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2808 num_conti=num_cont_hb(i)
2809 do j=ielstart(i),ielend(i)
2810 c write (iout,*) i,j,itype(i),itype(j)
2811 if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
2812 call eelecij(i,j,ees,evdw1,eel_loc)
2814 num_cont_hb(i)=num_conti
2816 c write (iout,*) "Number of loop steps in EELEC:",ind
2818 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
2819 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2821 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2822 ccc eel_loc=eel_loc+eello_turn3
2823 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
2826 C-------------------------------------------------------------------------------
2827 subroutine eelecij(i,j,ees,evdw1,eel_loc)
2828 implicit real*8 (a-h,o-z)
2829 include 'DIMENSIONS'
2833 include 'COMMON.CONTROL'
2834 include 'COMMON.IOUNITS'
2835 include 'COMMON.GEO'
2836 include 'COMMON.VAR'
2837 include 'COMMON.LOCAL'
2838 include 'COMMON.CHAIN'
2839 include 'COMMON.DERIV'
2840 include 'COMMON.INTERACT'
2841 include 'COMMON.CONTACTS'
2842 include 'COMMON.TORSION'
2843 include 'COMMON.VECTORS'
2844 include 'COMMON.FFIELD'
2845 include 'COMMON.TIME1'
2846 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2847 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2848 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2849 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2850 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2851 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2853 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2855 double precision scal_el /1.0d0/
2857 double precision scal_el /0.5d0/
2860 C 13-go grudnia roku pamietnego...
2861 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2862 & 0.0d0,1.0d0,0.0d0,
2863 & 0.0d0,0.0d0,1.0d0/
2864 c time00=MPI_Wtime()
2865 cd write (iout,*) "eelecij",i,j
2869 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2870 aaa=app(iteli,itelj)
2871 bbb=bpp(iteli,itelj)
2872 ael6i=ael6(iteli,itelj)
2873 ael3i=ael3(iteli,itelj)
2877 dx_normj=dc_norm(1,j)
2878 dy_normj=dc_norm(2,j)
2879 dz_normj=dc_norm(3,j)
2880 xj=c(1,j)+0.5D0*dxj-xmedi
2881 yj=c(2,j)+0.5D0*dyj-ymedi
2882 zj=c(3,j)+0.5D0*dzj-zmedi
2883 rij=xj*xj+yj*yj+zj*zj
2889 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2890 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2891 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2892 fac=cosa-3.0D0*cosb*cosg
2894 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2895 if (j.eq.i+2) ev1=scal_el*ev1
2900 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2903 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2904 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2907 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2908 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2909 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
2910 cd & xmedi,ymedi,zmedi,xj,yj,zj
2912 if (energy_dec) then
2913 write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2914 write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2918 C Calculate contributions to the Cartesian gradient.
2921 facvdw=-6*rrmij*(ev1+evdwij)
2922 facel=-3*rrmij*(el1+eesij)
2928 * Radial derivatives. First process both termini of the fragment (i,j)
2934 c ghalf=0.5D0*ggg(k)
2935 c gelc(k,i)=gelc(k,i)+ghalf
2936 c gelc(k,j)=gelc(k,j)+ghalf
2938 c 9/28/08 AL Gradient compotents will be summed only at the end
2940 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2941 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2944 * Loop over residues i+1 thru j-1.
2948 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2955 c ghalf=0.5D0*ggg(k)
2956 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2957 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2959 c 9/28/08 AL Gradient compotents will be summed only at the end
2961 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2962 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2965 * Loop over residues i+1 thru j-1.
2969 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2976 fac=-3*rrmij*(facvdw+facvdw+facel)
2981 * Radial derivatives. First process both termini of the fragment (i,j)
2987 c ghalf=0.5D0*ggg(k)
2988 c gelc(k,i)=gelc(k,i)+ghalf
2989 c gelc(k,j)=gelc(k,j)+ghalf
2991 c 9/28/08 AL Gradient compotents will be summed only at the end
2993 gelc_long(k,j)=gelc(k,j)+ggg(k)
2994 gelc_long(k,i)=gelc(k,i)-ggg(k)
2997 * Loop over residues i+1 thru j-1.
3001 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
3004 c 9/28/08 AL Gradient compotents will be summed only at the end
3009 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3010 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3016 ecosa=2.0D0*fac3*fac1+fac4
3019 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3020 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3022 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3023 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3025 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3026 cd & (dcosg(k),k=1,3)
3028 ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3031 c ghalf=0.5D0*ggg(k)
3032 c gelc(k,i)=gelc(k,i)+ghalf
3033 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3034 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3035 c gelc(k,j)=gelc(k,j)+ghalf
3036 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3037 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3041 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
3046 & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3047 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3049 & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3050 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3051 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3052 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3054 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3055 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3056 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3058 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3059 C energy of a peptide unit is assumed in the form of a second-order
3060 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3061 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3062 C are computed for EVERY pair of non-contiguous peptide groups.
3064 if (j.lt.nres-1) then
3075 muij(kkk)=mu(k,i)*mu(l,j)
3078 cd write (iout,*) 'EELEC: i',i,' j',j
3079 cd write (iout,*) 'j',j,' j1',j1,' j2',j2
3080 cd write(iout,*) 'muij',muij
3081 ury=scalar(uy(1,i),erij)
3082 urz=scalar(uz(1,i),erij)
3083 vry=scalar(uy(1,j),erij)
3084 vrz=scalar(uz(1,j),erij)
3085 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3086 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3087 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3088 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3089 fac=dsqrt(-ael6i)*r3ij
3094 cd write (iout,'(4i5,4f10.5)')
3095 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3096 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3097 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3098 cd & uy(:,j),uz(:,j)
3099 cd write (iout,'(4f10.5)')
3100 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3101 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3102 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
3103 cd write (iout,'(9f10.5/)')
3104 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3105 C Derivatives of the elements of A in virtual-bond vectors
3106 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3108 uryg(k,1)=scalar(erder(1,k),uy(1,i))
3109 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3110 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3111 urzg(k,1)=scalar(erder(1,k),uz(1,i))
3112 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3113 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3114 vryg(k,1)=scalar(erder(1,k),uy(1,j))
3115 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3116 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3117 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3118 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3119 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3121 C Compute radial contributions to the gradient
3139 C Add the contributions coming from er
3142 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3143 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3144 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3145 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3148 C Derivatives in DC(i)
3149 cgrad ghalf1=0.5d0*agg(k,1)
3150 cgrad ghalf2=0.5d0*agg(k,2)
3151 cgrad ghalf3=0.5d0*agg(k,3)
3152 cgrad ghalf4=0.5d0*agg(k,4)
3153 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3154 & -3.0d0*uryg(k,2)*vry)!+ghalf1
3155 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3156 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
3157 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3158 & -3.0d0*urzg(k,2)*vry)!+ghalf3
3159 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3160 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
3161 C Derivatives in DC(i+1)
3162 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3163 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3164 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3165 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3166 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3167 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3168 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3169 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3170 C Derivatives in DC(j)
3171 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3172 & -3.0d0*vryg(k,2)*ury)!+ghalf1
3173 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3174 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
3175 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3176 & -3.0d0*vryg(k,2)*urz)!+ghalf3
3177 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3178 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
3179 C Derivatives in DC(j+1) or DC(nres-1)
3180 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3181 & -3.0d0*vryg(k,3)*ury)
3182 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3183 & -3.0d0*vrzg(k,3)*ury)
3184 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3185 & -3.0d0*vryg(k,3)*urz)
3186 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3187 & -3.0d0*vrzg(k,3)*urz)
3188 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
3190 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
3203 aggi(k,l)=-aggi(k,l)
3204 aggi1(k,l)=-aggi1(k,l)
3205 aggj(k,l)=-aggj(k,l)
3206 aggj1(k,l)=-aggj1(k,l)
3209 if (j.lt.nres-1) then
3215 aggi(k,l)=-aggi(k,l)
3216 aggi1(k,l)=-aggi1(k,l)
3217 aggj(k,l)=-aggj(k,l)
3218 aggj1(k,l)=-aggj1(k,l)
3229 aggi(k,l)=-aggi(k,l)
3230 aggi1(k,l)=-aggi1(k,l)
3231 aggj(k,l)=-aggj(k,l)
3232 aggj1(k,l)=-aggj1(k,l)
3237 IF (wel_loc.gt.0.0d0) THEN
3238 C Contribution to the local-electrostatic energy coming from the i-j pair
3239 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3241 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3243 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3244 & 'eelloc',i,j,eel_loc_ij
3246 eel_loc=eel_loc+eel_loc_ij
3247 C Partial derivatives in virtual-bond dihedral angles gamma
3249 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3250 & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3251 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3252 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3253 & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3254 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3255 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3257 ggg(l)=agg(l,1)*muij(1)+
3258 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3259 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3260 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3261 cgrad ghalf=0.5d0*ggg(l)
3262 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
3263 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
3267 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3270 C Remaining derivatives of eello
3272 gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3273 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3274 gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3275 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3276 gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3277 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3278 gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3279 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3282 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3283 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
3284 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3285 & .and. num_conti.le.maxconts) then
3286 c write (iout,*) i,j," entered corr"
3288 C Calculate the contact function. The ith column of the array JCONT will
3289 C contain the numbers of atoms that make contacts with the atom I (of numbers
3290 C greater than I). The arrays FACONT and GACONT will contain the values of
3291 C the contact function and its derivative.
3292 c r0ij=1.02D0*rpp(iteli,itelj)
3293 c r0ij=1.11D0*rpp(iteli,itelj)
3294 r0ij=2.20D0*rpp(iteli,itelj)
3295 c r0ij=1.55D0*rpp(iteli,itelj)
3296 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3297 if (fcont.gt.0.0D0) then
3298 num_conti=num_conti+1
3299 if (num_conti.gt.maxconts) then
3300 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3301 & ' will skip next contacts for this conf.'
3303 jcont_hb(num_conti,i)=j
3304 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
3305 cd & " jcont_hb",jcont_hb(num_conti,i)
3306 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3307 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3308 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3310 d_cont(num_conti,i)=rij
3311 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3312 C --- Electrostatic-interaction matrix ---
3313 a_chuj(1,1,num_conti,i)=a22
3314 a_chuj(1,2,num_conti,i)=a23
3315 a_chuj(2,1,num_conti,i)=a32
3316 a_chuj(2,2,num_conti,i)=a33
3317 C --- Gradient of rij
3319 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3326 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3327 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3328 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3329 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3330 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3335 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3336 C Calculate contact energies
3338 wij=cosa-3.0D0*cosb*cosg
3341 c fac3=dsqrt(-ael6i)/r0ij**3
3342 fac3=dsqrt(-ael6i)*r3ij
3343 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3344 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3345 if (ees0tmp.gt.0) then
3346 ees0pij=dsqrt(ees0tmp)
3350 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3351 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3352 if (ees0tmp.gt.0) then
3353 ees0mij=dsqrt(ees0tmp)
3358 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3359 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3360 C Diagnostics. Comment out or remove after debugging!
3361 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3362 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3363 c ees0m(num_conti,i)=0.0D0
3365 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3366 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3367 C Angular derivatives of the contact function
3368 ees0pij1=fac3/ees0pij
3369 ees0mij1=fac3/ees0mij
3370 fac3p=-3.0D0*fac3*rrmij
3371 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3372 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3374 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
3375 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3376 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3377 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
3378 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3379 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3380 ecosap=ecosa1+ecosa2
3381 ecosbp=ecosb1+ecosb2
3382 ecosgp=ecosg1+ecosg2
3383 ecosam=ecosa1-ecosa2
3384 ecosbm=ecosb1-ecosb2
3385 ecosgm=ecosg1-ecosg2
3394 facont_hb(num_conti,i)=fcont
3395 fprimcont=fprimcont/rij
3396 cd facont_hb(num_conti,i)=1.0D0
3397 C Following line is for diagnostics.
3400 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3401 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3404 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3405 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3407 gggp(1)=gggp(1)+ees0pijp*xj
3408 gggp(2)=gggp(2)+ees0pijp*yj
3409 gggp(3)=gggp(3)+ees0pijp*zj
3410 gggm(1)=gggm(1)+ees0mijp*xj
3411 gggm(2)=gggm(2)+ees0mijp*yj
3412 gggm(3)=gggm(3)+ees0mijp*zj
3413 C Derivatives due to the contact function
3414 gacont_hbr(1,num_conti,i)=fprimcont*xj
3415 gacont_hbr(2,num_conti,i)=fprimcont*yj
3416 gacont_hbr(3,num_conti,i)=fprimcont*zj
3419 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3420 c following the change of gradient-summation algorithm.
3422 cgrad ghalfp=0.5D0*gggp(k)
3423 cgrad ghalfm=0.5D0*gggm(k)
3424 gacontp_hb1(k,num_conti,i)=!ghalfp
3425 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3426 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3427 gacontp_hb2(k,num_conti,i)=!ghalfp
3428 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3429 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3430 gacontp_hb3(k,num_conti,i)=gggp(k)
3431 gacontm_hb1(k,num_conti,i)=!ghalfm
3432 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3433 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3434 gacontm_hb2(k,num_conti,i)=!ghalfm
3435 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3436 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3437 gacontm_hb3(k,num_conti,i)=gggm(k)
3439 C Diagnostics. Comment out or remove after debugging!
3441 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
3442 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
3443 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
3444 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
3445 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
3446 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
3449 endif ! num_conti.le.maxconts
3452 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3455 ghalf=0.5d0*agg(l,k)
3456 aggi(l,k)=aggi(l,k)+ghalf
3457 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3458 aggj(l,k)=aggj(l,k)+ghalf
3461 if (j.eq.nres-1 .and. i.lt.j-2) then
3464 aggj1(l,k)=aggj1(l,k)+agg(l,k)
3469 c t_eelecij=t_eelecij+MPI_Wtime()-time00
3472 C-----------------------------------------------------------------------------
3473 subroutine eturn3(i,eello_turn3)
3474 C Third- and fourth-order contributions from turns
3475 implicit real*8 (a-h,o-z)
3476 include 'DIMENSIONS'
3477 include 'COMMON.IOUNITS'
3478 include 'COMMON.GEO'
3479 include 'COMMON.VAR'
3480 include 'COMMON.LOCAL'
3481 include 'COMMON.CHAIN'
3482 include 'COMMON.DERIV'
3483 include 'COMMON.INTERACT'
3484 include 'COMMON.CONTACTS'
3485 include 'COMMON.TORSION'
3486 include 'COMMON.VECTORS'
3487 include 'COMMON.FFIELD'
3488 include 'COMMON.CONTROL'
3490 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3491 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3492 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3493 double precision agg(3,4),aggi(3,4),aggi1(3,4),
3494 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3495 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3496 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3499 c write (iout,*) "eturn3",i,j,j1,j2
3504 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3506 C Third-order contributions
3513 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3514 cd call checkint_turn3(i,a_temp,eello_turn3_num)
3515 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3516 call transpose2(auxmat(1,1),auxmat1(1,1))
3517 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3518 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3519 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3520 & 'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3521 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
3522 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
3523 cd & ' eello_turn3_num',4*eello_turn3_num
3524 C Derivatives in gamma(i)
3525 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3526 call transpose2(auxmat2(1,1),auxmat3(1,1))
3527 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3528 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3529 C Derivatives in gamma(i+1)
3530 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3531 call transpose2(auxmat2(1,1),auxmat3(1,1))
3532 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3533 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3534 & +0.5d0*(pizda(1,1)+pizda(2,2))
3535 C Cartesian derivatives
3537 c ghalf1=0.5d0*agg(l,1)
3538 c ghalf2=0.5d0*agg(l,2)
3539 c ghalf3=0.5d0*agg(l,3)
3540 c ghalf4=0.5d0*agg(l,4)
3541 a_temp(1,1)=aggi(l,1)!+ghalf1
3542 a_temp(1,2)=aggi(l,2)!+ghalf2
3543 a_temp(2,1)=aggi(l,3)!+ghalf3
3544 a_temp(2,2)=aggi(l,4)!+ghalf4
3545 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3546 gcorr3_turn(l,i)=gcorr3_turn(l,i)
3547 & +0.5d0*(pizda(1,1)+pizda(2,2))
3548 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3549 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3550 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3551 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3552 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3553 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3554 & +0.5d0*(pizda(1,1)+pizda(2,2))
3555 a_temp(1,1)=aggj(l,1)!+ghalf1
3556 a_temp(1,2)=aggj(l,2)!+ghalf2
3557 a_temp(2,1)=aggj(l,3)!+ghalf3
3558 a_temp(2,2)=aggj(l,4)!+ghalf4
3559 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3560 gcorr3_turn(l,j)=gcorr3_turn(l,j)
3561 & +0.5d0*(pizda(1,1)+pizda(2,2))
3562 a_temp(1,1)=aggj1(l,1)
3563 a_temp(1,2)=aggj1(l,2)
3564 a_temp(2,1)=aggj1(l,3)
3565 a_temp(2,2)=aggj1(l,4)
3566 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3567 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3568 & +0.5d0*(pizda(1,1)+pizda(2,2))
3572 C-------------------------------------------------------------------------------
3573 subroutine eturn4(i,eello_turn4)
3574 C Third- and fourth-order contributions from turns
3575 implicit real*8 (a-h,o-z)
3576 include 'DIMENSIONS'
3577 include 'COMMON.IOUNITS'
3578 include 'COMMON.GEO'
3579 include 'COMMON.VAR'
3580 include 'COMMON.LOCAL'
3581 include 'COMMON.CHAIN'
3582 include 'COMMON.DERIV'
3583 include 'COMMON.INTERACT'
3584 include 'COMMON.CONTACTS'
3585 include 'COMMON.TORSION'
3586 include 'COMMON.VECTORS'
3587 include 'COMMON.FFIELD'
3588 include 'COMMON.CONTROL'
3590 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3591 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3592 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3593 double precision agg(3,4),aggi(3,4),aggi1(3,4),
3594 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3595 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3596 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3599 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3601 C Fourth-order contributions
3609 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3610 cd call checkint_turn4(i,a_temp,eello_turn4_num)
3611 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3616 iti1=itortyp(itype(i+1))
3617 iti2=itortyp(itype(i+2))
3618 iti3=itortyp(itype(i+3))
3619 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3620 call transpose2(EUg(1,1,i+1),e1t(1,1))
3621 call transpose2(Eug(1,1,i+2),e2t(1,1))
3622 call transpose2(Eug(1,1,i+3),e3t(1,1))
3623 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3624 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3625 s1=scalar2(b1(1,iti2),auxvec(1))
3626 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3627 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3628 s2=scalar2(b1(1,iti1),auxvec(1))
3629 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3630 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3631 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3632 eello_turn4=eello_turn4-(s1+s2+s3)
3633 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3634 & 'eturn4',i,j,-(s1+s2+s3)
3635 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3636 cd & ' eello_turn4_num',8*eello_turn4_num
3637 C Derivatives in gamma(i)
3638 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3639 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3640 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3641 s1=scalar2(b1(1,iti2),auxvec(1))
3642 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3643 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3644 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3645 C Derivatives in gamma(i+1)
3646 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3647 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3648 s2=scalar2(b1(1,iti1),auxvec(1))
3649 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3650 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3651 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3652 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3653 C Derivatives in gamma(i+2)
3654 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3655 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3656 s1=scalar2(b1(1,iti2),auxvec(1))
3657 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3658 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3659 s2=scalar2(b1(1,iti1),auxvec(1))
3660 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3661 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3662 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3663 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3664 C Cartesian derivatives
3665 C Derivatives of this turn contributions in DC(i+2)
3666 if (j.lt.nres-1) then
3668 a_temp(1,1)=agg(l,1)
3669 a_temp(1,2)=agg(l,2)
3670 a_temp(2,1)=agg(l,3)
3671 a_temp(2,2)=agg(l,4)
3672 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3673 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3674 s1=scalar2(b1(1,iti2),auxvec(1))
3675 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3676 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3677 s2=scalar2(b1(1,iti1),auxvec(1))
3678 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3679 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3680 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3682 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3685 C Remaining derivatives of this turn contribution
3687 a_temp(1,1)=aggi(l,1)
3688 a_temp(1,2)=aggi(l,2)
3689 a_temp(2,1)=aggi(l,3)
3690 a_temp(2,2)=aggi(l,4)
3691 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3692 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3693 s1=scalar2(b1(1,iti2),auxvec(1))
3694 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3695 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3696 s2=scalar2(b1(1,iti1),auxvec(1))
3697 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3698 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3699 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3700 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3701 a_temp(1,1)=aggi1(l,1)
3702 a_temp(1,2)=aggi1(l,2)
3703 a_temp(2,1)=aggi1(l,3)
3704 a_temp(2,2)=aggi1(l,4)
3705 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3706 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3707 s1=scalar2(b1(1,iti2),auxvec(1))
3708 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3709 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3710 s2=scalar2(b1(1,iti1),auxvec(1))
3711 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3712 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3713 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3714 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3715 a_temp(1,1)=aggj(l,1)
3716 a_temp(1,2)=aggj(l,2)
3717 a_temp(2,1)=aggj(l,3)
3718 a_temp(2,2)=aggj(l,4)
3719 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3720 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3721 s1=scalar2(b1(1,iti2),auxvec(1))
3722 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3723 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3724 s2=scalar2(b1(1,iti1),auxvec(1))
3725 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3726 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3727 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3728 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3729 a_temp(1,1)=aggj1(l,1)
3730 a_temp(1,2)=aggj1(l,2)
3731 a_temp(2,1)=aggj1(l,3)
3732 a_temp(2,2)=aggj1(l,4)
3733 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3734 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3735 s1=scalar2(b1(1,iti2),auxvec(1))
3736 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3737 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3738 s2=scalar2(b1(1,iti1),auxvec(1))
3739 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3740 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3741 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3742 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3743 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3747 C-----------------------------------------------------------------------------
3748 subroutine vecpr(u,v,w)
3749 implicit real*8(a-h,o-z)
3750 dimension u(3),v(3),w(3)
3751 w(1)=u(2)*v(3)-u(3)*v(2)
3752 w(2)=-u(1)*v(3)+u(3)*v(1)
3753 w(3)=u(1)*v(2)-u(2)*v(1)
3756 C-----------------------------------------------------------------------------
3757 subroutine unormderiv(u,ugrad,unorm,ungrad)
3758 C This subroutine computes the derivatives of a normalized vector u, given
3759 C the derivatives computed without normalization conditions, ugrad. Returns
3762 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3763 double precision vec(3)
3764 double precision scalar
3766 c write (2,*) 'ugrad',ugrad
3769 vec(i)=scalar(ugrad(1,i),u(1))
3771 c write (2,*) 'vec',vec
3774 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3777 c write (2,*) 'ungrad',ungrad
3780 C-----------------------------------------------------------------------------
3781 subroutine escp_soft_sphere(evdw2,evdw2_14)
3783 C This subroutine calculates the excluded-volume interaction energy between
3784 C peptide-group centers and side chains and its gradient in virtual-bond and
3785 C side-chain vectors.
3787 implicit real*8 (a-h,o-z)
3788 include 'DIMENSIONS'
3789 include 'COMMON.GEO'
3790 include 'COMMON.VAR'
3791 include 'COMMON.LOCAL'
3792 include 'COMMON.CHAIN'
3793 include 'COMMON.DERIV'
3794 include 'COMMON.INTERACT'
3795 include 'COMMON.FFIELD'
3796 include 'COMMON.IOUNITS'
3797 include 'COMMON.CONTROL'
3802 cd print '(a)','Enter ESCP'
3803 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3804 do i=iatscp_s,iatscp_e
3805 if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3807 xi=0.5D0*(c(1,i)+c(1,i+1))
3808 yi=0.5D0*(c(2,i)+c(2,i+1))
3809 zi=0.5D0*(c(3,i)+c(3,i+1))
3811 do iint=1,nscp_gr(i)
3813 do j=iscpstart(i,iint),iscpend(i,iint)
3814 if (itype(j).eq.21) cycle
3816 C Uncomment following three lines for SC-p interactions
3820 C Uncomment following three lines for Ca-p interactions
3824 rij=xj*xj+yj*yj+zj*zj
3827 if (rij.lt.r0ijsq) then
3828 evdwij=0.25d0*(rij-r0ijsq)**2
3836 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3841 cgrad if (j.lt.i) then
3842 cd write (iout,*) 'j<i'
3843 C Uncomment following three lines for SC-p interactions
3845 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3848 cd write (iout,*) 'j>i'
3850 cgrad ggg(k)=-ggg(k)
3851 C Uncomment following line for SC-p interactions
3852 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3856 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3858 cgrad kstart=min0(i+1,j)
3859 cgrad kend=max0(i-1,j-1)
3860 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3861 cd write (iout,*) ggg(1),ggg(2),ggg(3)
3862 cgrad do k=kstart,kend
3864 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3868 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3869 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3877 C-----------------------------------------------------------------------------
3878 subroutine escp(evdw2,evdw2_14)
3880 C This subroutine calculates the excluded-volume interaction energy between
3881 C peptide-group centers and side chains and its gradient in virtual-bond and
3882 C side-chain vectors.
3884 implicit real*8 (a-h,o-z)
3885 include 'DIMENSIONS'
3886 include 'COMMON.GEO'
3887 include 'COMMON.VAR'
3888 include 'COMMON.LOCAL'
3889 include 'COMMON.CHAIN'
3890 include 'COMMON.DERIV'
3891 include 'COMMON.INTERACT'
3892 include 'COMMON.FFIELD'
3893 include 'COMMON.IOUNITS'
3894 include 'COMMON.CONTROL'
3898 cd print '(a)','Enter ESCP'
3899 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3900 do i=iatscp_s,iatscp_e
3901 if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3903 xi=0.5D0*(c(1,i)+c(1,i+1))
3904 yi=0.5D0*(c(2,i)+c(2,i+1))
3905 zi=0.5D0*(c(3,i)+c(3,i+1))
3907 do iint=1,nscp_gr(i)
3909 do j=iscpstart(i,iint),iscpend(i,iint)
3911 if (itypj.eq.21) cycle
3912 C Uncomment following three lines for SC-p interactions
3916 C Uncomment following three lines for Ca-p interactions
3920 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3922 e1=fac*fac*aad(itypj,iteli)
3923 e2=fac*bad(itypj,iteli)
3924 if (iabs(j-i) .le. 2) then
3927 evdw2_14=evdw2_14+e1+e2
3931 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3932 & 'evdw2',i,j,evdwij
3934 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3936 fac=-(evdwij+e1)*rrij
3940 cgrad if (j.lt.i) then
3941 cd write (iout,*) 'j<i'
3942 C Uncomment following three lines for SC-p interactions
3944 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3947 cd write (iout,*) 'j>i'
3949 cgrad ggg(k)=-ggg(k)
3950 C Uncomment following line for SC-p interactions
3951 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3952 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3956 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3958 cgrad kstart=min0(i+1,j)
3959 cgrad kend=max0(i-1,j-1)
3960 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3961 cd write (iout,*) ggg(1),ggg(2),ggg(3)
3962 cgrad do k=kstart,kend
3964 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3968 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3969 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3977 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3978 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3979 gradx_scp(j,i)=expon*gradx_scp(j,i)
3982 C******************************************************************************
3986 C To save time the factor EXPON has been extracted from ALL components
3987 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3990 C******************************************************************************
3993 C--------------------------------------------------------------------------
3994 subroutine edis(ehpb)
3996 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3998 implicit real*8 (a-h,o-z)
3999 include 'DIMENSIONS'
4000 include 'COMMON.SBRIDGE'
4001 include 'COMMON.CHAIN'
4002 include 'COMMON.DERIV'
4003 include 'COMMON.VAR'
4004 include 'COMMON.INTERACT'
4005 include 'COMMON.IOUNITS'
4008 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4009 cd write(iout,*)'link_start=',link_start,' link_end=',link_end
4010 if (link_end.eq.0) return
4011 do i=link_start,link_end
4012 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4013 C CA-CA distance used in regularization of structure.
4016 C iii and jjj point to the residues for which the distance is assigned.
4017 if (ii.gt.nres) then
4024 cd write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4025 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4026 C distance and angle dependent SS bond potential.
4027 if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4028 call ssbond_ene(iii,jjj,eij)
4030 cd write (iout,*) "eij",eij
4032 C Calculate the distance between the two points and its difference from the
4036 C Get the force constant corresponding to this distance.
4038 C Calculate the contribution to energy.
4039 ehpb=ehpb+waga*rdis*rdis
4041 C Evaluate gradient.
4044 cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4045 cd & ' waga=',waga,' fac=',fac
4047 ggg(j)=fac*(c(j,jj)-c(j,ii))
4049 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4050 C If this is a SC-SC distance, we need to calculate the contributions to the
4051 C Cartesian gradient in the SC vectors (ghpbx).
4054 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4055 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4058 cgrad do j=iii,jjj-1
4060 cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4064 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4065 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4072 C--------------------------------------------------------------------------
4073 subroutine ssbond_ene(i,j,eij)
4075 C Calculate the distance and angle dependent SS-bond potential energy
4076 C using a free-energy function derived based on RHF/6-31G** ab initio
4077 C calculations of diethyl disulfide.
4079 C A. Liwo and U. Kozlowska, 11/24/03
4081 implicit real*8 (a-h,o-z)
4082 include 'DIMENSIONS'
4083 include 'COMMON.SBRIDGE'
4084 include 'COMMON.CHAIN'
4085 include 'COMMON.DERIV'
4086 include 'COMMON.LOCAL'
4087 include 'COMMON.INTERACT'
4088 include 'COMMON.VAR'
4089 include 'COMMON.IOUNITS'
4090 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4095 dxi=dc_norm(1,nres+i)
4096 dyi=dc_norm(2,nres+i)
4097 dzi=dc_norm(3,nres+i)
4098 c dsci_inv=dsc_inv(itypi)
4099 dsci_inv=vbld_inv(nres+i)
4101 c dscj_inv=dsc_inv(itypj)
4102 dscj_inv=vbld_inv(nres+j)
4106 dxj=dc_norm(1,nres+j)
4107 dyj=dc_norm(2,nres+j)
4108 dzj=dc_norm(3,nres+j)
4109 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4114 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4115 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4116 om12=dxi*dxj+dyi*dyj+dzi*dzj
4118 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4119 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4125 deltat12=om2-om1+2.0d0
4127 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4128 & +akct*deltad*deltat12
4129 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4130 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4131 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4132 c & " deltat12",deltat12," eij",eij
4133 ed=2*akcm*deltad+akct*deltat12
4135 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4136 eom1=-2*akth*deltat1-pom1-om2*pom2
4137 eom2= 2*akth*deltat2+pom1-om1*pom2
4140 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4141 ghpbx(k,i)=ghpbx(k,i)-ggk
4142 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4143 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4144 ghpbx(k,j)=ghpbx(k,j)+ggk
4145 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4146 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4147 ghpbc(k,i)=ghpbc(k,i)-ggk
4148 ghpbc(k,j)=ghpbc(k,j)+ggk
4151 C Calculate the components of the gradient in DC and X
4155 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
4160 C--------------------------------------------------------------------------
4161 subroutine ebond(estr)
4163 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4165 implicit real*8 (a-h,o-z)
4166 include 'DIMENSIONS'
4167 include 'COMMON.LOCAL'
4168 include 'COMMON.GEO'
4169 include 'COMMON.INTERACT'
4170 include 'COMMON.DERIV'
4171 include 'COMMON.VAR'
4172 include 'COMMON.CHAIN'
4173 include 'COMMON.IOUNITS'
4174 include 'COMMON.NAMES'
4175 include 'COMMON.FFIELD'
4176 include 'COMMON.CONTROL'
4177 include 'COMMON.SETUP'
4178 double precision u(3),ud(3)
4181 do i=ibondp_start,ibondp_end
4182 if (itype(i-1).eq.21 .or. itype(i).eq.21) then
4183 estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4185 gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4186 & *dc(j,i-1)/vbld(i)
4188 if (energy_dec) write(iout,*)
4189 & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4191 diff = vbld(i)-vbldp0
4192 if (energy_dec) write (iout,*)
4193 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4196 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4198 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4201 estr=0.5d0*AKP*estr+estr1
4203 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4205 do i=ibond_start,ibond_end
4207 if (iti.ne.10 .and. iti.ne.21) then
4210 diff=vbld(i+nres)-vbldsc0(1,iti)
4211 if (energy_dec) write (iout,*)
4212 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4213 & AKSC(1,iti),AKSC(1,iti)*diff*diff
4214 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4216 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4220 diff=vbld(i+nres)-vbldsc0(j,iti)
4221 ud(j)=aksc(j,iti)*diff
4222 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4236 uprod2=uprod2*u(k)*u(k)
4240 usumsqder=usumsqder+ud(j)*uprod2
4242 estr=estr+uprod/usum
4244 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4252 C--------------------------------------------------------------------------
4253 subroutine ebend(etheta)
4255 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4256 C angles gamma and its derivatives in consecutive thetas and gammas.
4258 implicit real*8 (a-h,o-z)
4259 include 'DIMENSIONS'
4260 include 'COMMON.LOCAL'
4261 include 'COMMON.GEO'
4262 include 'COMMON.INTERACT'
4263 include 'COMMON.DERIV'
4264 include 'COMMON.VAR'
4265 include 'COMMON.CHAIN'
4266 include 'COMMON.IOUNITS'
4267 include 'COMMON.NAMES'
4268 include 'COMMON.FFIELD'
4269 include 'COMMON.CONTROL'
4270 common /calcthet/ term1,term2,termm,diffak,ratak,
4271 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4272 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4273 double precision y(2),z(2)
4275 c time11=dexp(-2*time)
4278 c write (*,'(a,i2)') 'EBEND ICG=',icg
4279 do i=ithet_start,ithet_end
4280 if (itype(i-1).eq.21) cycle
4281 C Zero the energy function and its derivative at 0 or pi.
4282 call splinthet(theta(i),0.5d0*delta,ss,ssd)
4284 if (i.gt.3 .and. itype(i-2).ne.21) then
4287 if (phii.ne.phii) phii=150.0
4297 if (i.lt.nres .and. itype(i).ne.21) then
4300 if (phii1.ne.phii1) phii1=150.0
4312 C Calculate the "mean" value of theta from the part of the distribution
4313 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4314 C In following comments this theta will be referred to as t_c.
4315 thet_pred_mean=0.0d0
4319 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4321 dthett=thet_pred_mean*ssd
4322 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4323 C Derivatives of the "mean" values in gamma1 and gamma2.
4324 dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4325 dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4326 if (theta(i).gt.pi-delta) then
4327 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4329 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4330 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4331 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4333 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4335 else if (theta(i).lt.delta) then
4336 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4337 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4338 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4340 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4341 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4344 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4347 etheta=etheta+ethetai
4348 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4350 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4351 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4352 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4354 C Ufff.... We've done all this!!!
4357 C---------------------------------------------------------------------------
4358 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4360 implicit real*8 (a-h,o-z)
4361 include 'DIMENSIONS'
4362 include 'COMMON.LOCAL'
4363 include 'COMMON.IOUNITS'
4364 common /calcthet/ term1,term2,termm,diffak,ratak,
4365 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4366 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4367 C Calculate the contributions to both Gaussian lobes.
4368 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4369 C The "polynomial part" of the "standard deviation" of this part of
4373 sig=sig*thet_pred_mean+polthet(j,it)
4375 C Derivative of the "interior part" of the "standard deviation of the"
4376 C gamma-dependent Gaussian lobe in t_c.
4377 sigtc=3*polthet(3,it)
4379 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4382 C Set the parameters of both Gaussian lobes of the distribution.
4383 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4384 fac=sig*sig+sigc0(it)
4387 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4388 sigsqtc=-4.0D0*sigcsq*sigtc
4389 c print *,i,sig,sigtc,sigsqtc
4390 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4391 sigtc=-sigtc/(fac*fac)
4392 C Following variable is sigma(t_c)**(-2)
4393 sigcsq=sigcsq*sigcsq
4395 sig0inv=1.0D0/sig0i**2
4396 delthec=thetai-thet_pred_mean
4397 delthe0=thetai-theta0i
4398 term1=-0.5D0*sigcsq*delthec*delthec
4399 term2=-0.5D0*sig0inv*delthe0*delthe0
4400 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4401 C NaNs in taking the logarithm. We extract the largest exponent which is added
4402 C to the energy (this being the log of the distribution) at the end of energy
4403 C term evaluation for this virtual-bond angle.
4404 if (term1.gt.term2) then
4406 term2=dexp(term2-termm)
4410 term1=dexp(term1-termm)
4413 C The ratio between the gamma-independent and gamma-dependent lobes of
4414 C the distribution is a Gaussian function of thet_pred_mean too.
4415 diffak=gthet(2,it)-thet_pred_mean
4416 ratak=diffak/gthet(3,it)**2
4417 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4418 C Let's differentiate it in thet_pred_mean NOW.
4420 C Now put together the distribution terms to make complete distribution.
4421 termexp=term1+ak*term2
4422 termpre=sigc+ak*sig0i
4423 C Contribution of the bending energy from this theta is just the -log of
4424 C the sum of the contributions from the two lobes and the pre-exponential
4425 C factor. Simple enough, isn't it?
4426 ethetai=(-dlog(termexp)-termm+dlog(termpre))
4427 C NOW the derivatives!!!
4428 C 6/6/97 Take into account the deformation.
4429 E_theta=(delthec*sigcsq*term1
4430 & +ak*delthe0*sig0inv*term2)/termexp
4431 E_tc=((sigtc+aktc*sig0i)/termpre
4432 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4433 & aktc*term2)/termexp)
4436 c-----------------------------------------------------------------------------
4437 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4438 implicit real*8 (a-h,o-z)
4439 include 'DIMENSIONS'
4440 include 'COMMON.LOCAL'
4441 include 'COMMON.IOUNITS'
4442 common /calcthet/ term1,term2,termm,diffak,ratak,
4443 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4444 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4445 delthec=thetai-thet_pred_mean
4446 delthe0=thetai-theta0i
4447 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4448 t3 = thetai-thet_pred_mean
4452 t14 = t12+t6*sigsqtc
4454 t21 = thetai-theta0i
4460 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4461 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4462 & *(-t12*t9-ak*sig0inv*t27)
4466 C--------------------------------------------------------------------------
4467 subroutine ebend(etheta)
4469 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4470 C angles gamma and its derivatives in consecutive thetas and gammas.
4471 C ab initio-derived potentials from
4472 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4474 implicit real*8 (a-h,o-z)
4475 include 'DIMENSIONS'
4476 include 'COMMON.LOCAL'
4477 include 'COMMON.GEO'
4478 include 'COMMON.INTERACT'
4479 include 'COMMON.DERIV'
4480 include 'COMMON.VAR'
4481 include 'COMMON.CHAIN'
4482 include 'COMMON.IOUNITS'
4483 include 'COMMON.NAMES'
4484 include 'COMMON.FFIELD'
4485 include 'COMMON.CONTROL'
4486 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4487 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4488 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4489 & sinph1ph2(maxdouble,maxdouble)
4490 logical lprn /.false./, lprn1 /.false./
4492 do i=ithet_start,ithet_end
4493 if (itype(i-1).eq.21) cycle
4497 theti2=0.5d0*theta(i)
4498 ityp2=ithetyp(itype(i-1))
4500 coskt(k)=dcos(k*theti2)
4501 sinkt(k)=dsin(k*theti2)
4503 if (i.gt.3 .and. itype(i-2).ne.21) then
4506 if (phii.ne.phii) phii=150.0
4510 ityp1=ithetyp(itype(i-2))
4512 cosph1(k)=dcos(k*phii)
4513 sinph1(k)=dsin(k*phii)
4523 if (i.lt.nres .and. itype(i).ne.21) then
4526 if (phii1.ne.phii1) phii1=150.0
4531 ityp3=ithetyp(itype(i))
4533 cosph2(k)=dcos(k*phii1)
4534 sinph2(k)=dsin(k*phii1)
4544 ethetai=aa0thet(ityp1,ityp2,ityp3)
4547 ccl=cosph1(l)*cosph2(k-l)
4548 ssl=sinph1(l)*sinph2(k-l)
4549 scl=sinph1(l)*cosph2(k-l)
4550 csl=cosph1(l)*sinph2(k-l)
4551 cosph1ph2(l,k)=ccl-ssl
4552 cosph1ph2(k,l)=ccl+ssl
4553 sinph1ph2(l,k)=scl+csl
4554 sinph1ph2(k,l)=scl-csl
4558 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4559 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4560 write (iout,*) "coskt and sinkt"
4562 write (iout,*) k,coskt(k),sinkt(k)
4566 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4567 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4570 & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4571 & " ethetai",ethetai
4574 write (iout,*) "cosph and sinph"
4576 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4578 write (iout,*) "cosph1ph2 and sinph2ph2"
4581 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4582 & sinph1ph2(l,k),sinph1ph2(k,l)
4585 write(iout,*) "ethetai",ethetai
4589 aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4590 & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4591 & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4592 & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4593 ethetai=ethetai+sinkt(m)*aux
4594 dethetai=dethetai+0.5d0*m*aux*coskt(m)
4595 dephii=dephii+k*sinkt(m)*(
4596 & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4597 & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4598 dephii1=dephii1+k*sinkt(m)*(
4599 & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4600 & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4602 & write (iout,*) "m",m," k",k," bbthet",
4603 & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4604 & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4605 & ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4606 & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4610 & write(iout,*) "ethetai",ethetai
4614 aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4615 & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4616 & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4617 & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4618 ethetai=ethetai+sinkt(m)*aux
4619 dethetai=dethetai+0.5d0*m*coskt(m)*aux
4620 dephii=dephii+l*sinkt(m)*(
4621 & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4622 & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4623 & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4624 & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4625 dephii1=dephii1+(k-l)*sinkt(m)*(
4626 & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4627 & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4628 & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4629 & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4631 write (iout,*) "m",m," k",k," l",l," ffthet",
4632 & ffthet(l,k,m,ityp1,ityp2,ityp3),
4633 & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4634 & ggthet(l,k,m,ityp1,ityp2,ityp3),
4635 & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4636 write (iout,*) cosph1ph2(l,k)*sinkt(m),
4637 & cosph1ph2(k,l)*sinkt(m),
4638 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4644 if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4645 & i,theta(i)*rad2deg,phii*rad2deg,
4646 & phii1*rad2deg,ethetai
4647 etheta=etheta+ethetai
4648 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4649 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4650 gloc(nphi+i-2,icg)=wang*dethetai
4656 c-----------------------------------------------------------------------------
4657 subroutine esc(escloc)
4658 C Calculate the local energy of a side chain and its derivatives in the
4659 C corresponding virtual-bond valence angles THETA and the spherical angles
4661 implicit real*8 (a-h,o-z)
4662 include 'DIMENSIONS'
4663 include 'COMMON.GEO'
4664 include 'COMMON.LOCAL'
4665 include 'COMMON.VAR'
4666 include 'COMMON.INTERACT'
4667 include 'COMMON.DERIV'
4668 include 'COMMON.CHAIN'
4669 include 'COMMON.IOUNITS'
4670 include 'COMMON.NAMES'
4671 include 'COMMON.FFIELD'
4672 include 'COMMON.CONTROL'
4673 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4674 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
4675 common /sccalc/ time11,time12,time112,theti,it,nlobit
4678 c write (iout,'(a)') 'ESC'
4679 do i=loc_start,loc_end
4682 if (it.eq.10) goto 1
4684 c print *,'i=',i,' it=',it,' nlobit=',nlobit
4685 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4686 theti=theta(i+1)-pipol
4691 if (x(2).gt.pi-delta) then
4695 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4697 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4698 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4700 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4701 & ddersc0(1),dersc(1))
4702 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4703 & ddersc0(3),dersc(3))
4705 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4707 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4708 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4709 & dersc0(2),esclocbi,dersc02)
4710 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4712 call splinthet(x(2),0.5d0*delta,ss,ssd)
4717 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4719 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4720 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4722 escloci=ss*escloci+(1.0d0-ss)*esclocbi
4724 c write (iout,*) escloci
4725 else if (x(2).lt.delta) then
4729 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4731 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4732 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4734 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4735 & ddersc0(1),dersc(1))
4736 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4737 & ddersc0(3),dersc(3))
4739 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4741 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4742 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4743 & dersc0(2),esclocbi,dersc02)
4744 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4749 call splinthet(x(2),0.5d0*delta,ss,ssd)
4751 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4753 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4754 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4756 escloci=ss*escloci+(1.0d0-ss)*esclocbi
4757 c write (iout,*) escloci
4759 call enesc(x,escloci,dersc,ddummy,.false.)
4762 escloc=escloc+escloci
4763 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4764 & 'escloc',i,escloci
4765 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4767 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4769 gloc(ialph(i,1),icg)=wscloc*dersc(2)
4770 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4775 C---------------------------------------------------------------------------
4776 subroutine enesc(x,escloci,dersc,ddersc,mixed)
4777 implicit real*8 (a-h,o-z)
4778 include 'DIMENSIONS'
4779 include 'COMMON.GEO'
4780 include 'COMMON.LOCAL'
4781 include 'COMMON.IOUNITS'
4782 common /sccalc/ time11,time12,time112,theti,it,nlobit
4783 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4784 double precision contr(maxlob,-1:1)
4786 c write (iout,*) 'it=',it,' nlobit=',nlobit
4790 if (mixed) ddersc(j)=0.0d0
4794 C Because of periodicity of the dependence of the SC energy in omega we have
4795 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4796 C To avoid underflows, first compute & store the exponents.
4804 z(k)=x(k)-censc(k,j,it)
4809 Axk=Axk+gaussc(l,k,j,it)*z(l)
4815 expfac=expfac+Ax(k,j,iii)*z(k)
4823 C As in the case of ebend, we want to avoid underflows in exponentiation and
4824 C subsequent NaNs and INFs in energy calculation.
4825 C Find the largest exponent
4829 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4833 cd print *,'it=',it,' emin=',emin
4835 C Compute the contribution to SC energy and derivatives
4840 adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4841 if(adexp.ne.adexp) adexp=1.0
4844 expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4846 cd print *,'j=',j,' expfac=',expfac
4847 escloc_i=escloc_i+expfac
4849 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4853 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4854 & +gaussc(k,2,j,it))*expfac
4861 dersc(1)=dersc(1)/cos(theti)**2
4862 ddersc(1)=ddersc(1)/cos(theti)**2
4865 escloci=-(dlog(escloc_i)-emin)
4867 dersc(j)=dersc(j)/escloc_i
4871 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4876 C------------------------------------------------------------------------------
4877 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4878 implicit real*8 (a-h,o-z)
4879 include 'DIMENSIONS'
4880 include 'COMMON.GEO'
4881 include 'COMMON.LOCAL'
4882 include 'COMMON.IOUNITS'
4883 common /sccalc/ time11,time12,time112,theti,it,nlobit
4884 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4885 double precision contr(maxlob)
4896 z(k)=x(k)-censc(k,j,it)
4902 Axk=Axk+gaussc(l,k,j,it)*z(l)
4908 expfac=expfac+Ax(k,j)*z(k)
4913 C As in the case of ebend, we want to avoid underflows in exponentiation and
4914 C subsequent NaNs and INFs in energy calculation.
4915 C Find the largest exponent
4918 if (emin.gt.contr(j)) emin=contr(j)
4922 C Compute the contribution to SC energy and derivatives
4926 expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4927 escloc_i=escloc_i+expfac
4929 dersc(k)=dersc(k)+Ax(k,j)*expfac
4931 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4932 & +gaussc(1,2,j,it))*expfac
4936 dersc(1)=dersc(1)/cos(theti)**2
4937 dersc12=dersc12/cos(theti)**2
4938 escloci=-(dlog(escloc_i)-emin)
4940 dersc(j)=dersc(j)/escloc_i
4942 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4946 c----------------------------------------------------------------------------------
4947 subroutine esc(escloc)
4948 C Calculate the local energy of a side chain and its derivatives in the
4949 C corresponding virtual-bond valence angles THETA and the spherical angles
4950 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4951 C added by Urszula Kozlowska. 07/11/2007
4953 implicit real*8 (a-h,o-z)
4954 include 'DIMENSIONS'
4955 include 'COMMON.GEO'
4956 include 'COMMON.LOCAL'
4957 include 'COMMON.VAR'
4958 include 'COMMON.SCROT'
4959 include 'COMMON.INTERACT'
4960 include 'COMMON.DERIV'
4961 include 'COMMON.CHAIN'
4962 include 'COMMON.IOUNITS'
4963 include 'COMMON.NAMES'
4964 include 'COMMON.FFIELD'
4965 include 'COMMON.CONTROL'
4966 include 'COMMON.VECTORS'
4967 double precision x_prime(3),y_prime(3),z_prime(3)
4968 & , sumene,dsc_i,dp2_i,x(65),
4969 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4970 & de_dxx,de_dyy,de_dzz,de_dt
4971 double precision s1_t,s1_6_t,s2_t,s2_6_t
4973 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4974 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4975 & dt_dCi(3),dt_dCi1(3)
4976 common /sccalc/ time11,time12,time112,theti,it,nlobit
4979 do i=loc_start,loc_end
4980 if (itype(i).eq.21) cycle
4981 costtab(i+1) =dcos(theta(i+1))
4982 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4983 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4984 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4985 cosfac2=0.5d0/(1.0d0+costtab(i+1))
4986 cosfac=dsqrt(cosfac2)
4987 sinfac2=0.5d0/(1.0d0-costtab(i+1))
4988 sinfac=dsqrt(sinfac2)
4990 if (it.eq.10) goto 1
4992 C Compute the axes of tghe local cartesian coordinates system; store in
4993 c x_prime, y_prime and z_prime
5000 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5001 C & dc_norm(3,i+nres)
5003 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5004 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5007 z_prime(j) = -uz(j,i-1)
5010 c write (2,*) "x_prime",(x_prime(j),j=1,3)
5011 c write (2,*) "y_prime",(y_prime(j),j=1,3)
5012 c write (2,*) "z_prime",(z_prime(j),j=1,3)
5013 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5014 c & " xy",scalar(x_prime(1),y_prime(1)),
5015 c & " xz",scalar(x_prime(1),z_prime(1)),
5016 c & " yy",scalar(y_prime(1),y_prime(1)),
5017 c & " yz",scalar(y_prime(1),z_prime(1)),
5018 c & " zz",scalar(z_prime(1),z_prime(1))
5020 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5021 C to local coordinate system. Store in xx, yy, zz.
5027 xx = xx + x_prime(j)*dc_norm(j,i+nres)
5028 yy = yy + y_prime(j)*dc_norm(j,i+nres)
5029 zz = zz + z_prime(j)*dc_norm(j,i+nres)
5036 C Compute the energy of the ith side cbain
5038 c write (2,*) "xx",xx," yy",yy," zz",zz
5041 x(j) = sc_parmin(j,it)
5044 Cc diagnostics - remove later
5046 yy1 = dsin(alph(2))*dcos(omeg(2))
5047 zz1 = -dsin(alph(2))*dsin(omeg(2))
5048 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5049 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5051 C," --- ", xx_w,yy_w,zz_w
5054 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
5055 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
5057 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5058 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5060 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5061 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5062 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5063 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5064 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5066 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5067 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5068 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5069 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5070 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5072 dsc_i = 0.743d0+x(61)
5074 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5075 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5076 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5077 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5078 s1=(1+x(63))/(0.1d0 + dscp1)
5079 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5080 s2=(1+x(65))/(0.1d0 + dscp2)
5081 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5082 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5083 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5084 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5086 c & dscp1,dscp2,sumene
5087 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5088 escloc = escloc + sumene
5089 c write (2,*) "i",i," escloc",sumene,escloc
5092 C This section to check the numerical derivatives of the energy of ith side
5093 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5094 C #define DEBUG in the code to turn it on.
5096 write (2,*) "sumene =",sumene
5100 write (2,*) xx,yy,zz
5101 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5102 de_dxx_num=(sumenep-sumene)/aincr
5104 write (2,*) "xx+ sumene from enesc=",sumenep
5107 write (2,*) xx,yy,zz
5108 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5109 de_dyy_num=(sumenep-sumene)/aincr
5111 write (2,*) "yy+ sumene from enesc=",sumenep
5114 write (2,*) xx,yy,zz
5115 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5116 de_dzz_num=(sumenep-sumene)/aincr
5118 write (2,*) "zz+ sumene from enesc=",sumenep
5119 costsave=cost2tab(i+1)
5120 sintsave=sint2tab(i+1)
5121 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5122 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5123 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5124 de_dt_num=(sumenep-sumene)/aincr
5125 write (2,*) " t+ sumene from enesc=",sumenep
5126 cost2tab(i+1)=costsave
5127 sint2tab(i+1)=sintsave
5128 C End of diagnostics section.
5131 C Compute the gradient of esc
5133 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5134 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5135 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5136 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5137 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5138 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5139 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5140 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5141 pom1=(sumene3*sint2tab(i+1)+sumene1)
5142 & *(pom_s1/dscp1+pom_s16*dscp1**4)
5143 pom2=(sumene4*cost2tab(i+1)+sumene2)
5144 & *(pom_s2/dscp2+pom_s26*dscp2**4)
5145 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5146 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5147 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5149 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5150 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5151 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5153 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5154 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5155 & +(pom1+pom2)*pom_dx
5157 write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5160 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5161 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5162 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5164 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5165 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5166 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5167 & +x(59)*zz**2 +x(60)*xx*zz
5168 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5169 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5170 & +(pom1-pom2)*pom_dy
5172 write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5175 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5176 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5177 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5178 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
5179 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
5180 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5181 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5182 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
5184 write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5187 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5188 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5189 & +pom1*pom_dt1+pom2*pom_dt2
5191 write(2,*), "de_dt = ", de_dt,de_dt_num
5195 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5196 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5197 cosfac2xx=cosfac2*xx
5198 sinfac2yy=sinfac2*yy
5200 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5202 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5204 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5205 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5206 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5207 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5208 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5209 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5210 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5211 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5212 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5213 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5217 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5218 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5221 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5222 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5223 dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5225 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5226 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5230 dXX_Ctab(k,i)=dXX_Ci(k)
5231 dXX_C1tab(k,i)=dXX_Ci1(k)
5232 dYY_Ctab(k,i)=dYY_Ci(k)
5233 dYY_C1tab(k,i)=dYY_Ci1(k)
5234 dZZ_Ctab(k,i)=dZZ_Ci(k)
5235 dZZ_C1tab(k,i)=dZZ_Ci1(k)
5236 dXX_XYZtab(k,i)=dXX_XYZ(k)
5237 dYY_XYZtab(k,i)=dYY_XYZ(k)
5238 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5242 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5243 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5244 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5245 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
5246 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5248 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5249 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5250 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5251 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5252 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5253 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5254 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
5255 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5257 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5258 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5260 C to check gradient call subroutine check_grad
5266 c------------------------------------------------------------------------------
5267 double precision function enesc(x,xx,yy,zz,cost2,sint2)
5269 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5270 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5271 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
5272 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
5274 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5275 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5277 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5278 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5279 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5280 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5281 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5283 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5284 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5285 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5286 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5287 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5289 dsc_i = 0.743d0+x(61)
5291 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5292 & *(xx*cost2+yy*sint2))
5293 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5294 & *(xx*cost2-yy*sint2))
5295 s1=(1+x(63))/(0.1d0 + dscp1)
5296 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5297 s2=(1+x(65))/(0.1d0 + dscp2)
5298 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5299 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5300 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5305 c------------------------------------------------------------------------------
5306 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5308 C This procedure calculates two-body contact function g(rij) and its derivative:
5311 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
5314 C where x=(rij-r0ij)/delta
5316 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5319 double precision rij,r0ij,eps0ij,fcont,fprimcont
5320 double precision x,x2,x4,delta
5324 if (x.lt.-1.0D0) then
5327 else if (x.le.1.0D0) then
5330 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5331 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5338 c------------------------------------------------------------------------------
5339 subroutine splinthet(theti,delta,ss,ssder)
5340 implicit real*8 (a-h,o-z)
5341 include 'DIMENSIONS'
5342 include 'COMMON.VAR'
5343 include 'COMMON.GEO'
5346 if (theti.gt.pipol) then
5347 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5349 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5354 c------------------------------------------------------------------------------
5355 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5357 double precision x,x0,delta,f0,f1,fprim0,f,fprim
5358 double precision ksi,ksi2,ksi3,a1,a2,a3
5359 a1=fprim0*delta/(f1-f0)
5365 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5366 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5369 c------------------------------------------------------------------------------
5370 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5372 double precision x,x0,delta,f0x,f1x,fprim0x,fx
5373 double precision ksi,ksi2,ksi3,a1,a2,a3
5378 a2=3*(f1x-f0x)-2*fprim0x*delta
5379 a3=fprim0x*delta-2*(f1x-f0x)
5380 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5383 C-----------------------------------------------------------------------------
5385 C-----------------------------------------------------------------------------
5386 subroutine etor(etors,edihcnstr)
5387 implicit real*8 (a-h,o-z)
5388 include 'DIMENSIONS'
5389 include 'COMMON.VAR'
5390 include 'COMMON.GEO'
5391 include 'COMMON.LOCAL'
5392 include 'COMMON.TORSION'
5393 include 'COMMON.INTERACT'
5394 include 'COMMON.DERIV'
5395 include 'COMMON.CHAIN'
5396 include 'COMMON.NAMES'
5397 include 'COMMON.IOUNITS'
5398 include 'COMMON.FFIELD'
5399 include 'COMMON.TORCNSTR'
5400 include 'COMMON.CONTROL'
5402 C Set lprn=.true. for debugging
5406 do i=iphi_start,iphi_end
5408 if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5409 & .or. itype(i).eq.21) cycle
5410 itori=itortyp(itype(i-2))
5411 itori1=itortyp(itype(i-1))
5414 C Proline-Proline pair is a special case...
5415 if (itori.eq.3 .and. itori1.eq.3) then
5416 if (phii.gt.-dwapi3) then
5418 fac=1.0D0/(1.0D0-cosphi)
5419 etorsi=v1(1,3,3)*fac
5420 etorsi=etorsi+etorsi
5421 etors=etors+etorsi-v1(1,3,3)
5422 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5423 gloci=gloci-3*fac*etorsi*dsin(3*phii)
5426 v1ij=v1(j+1,itori,itori1)
5427 v2ij=v2(j+1,itori,itori1)
5430 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5431 if (energy_dec) etors_ii=etors_ii+
5432 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5433 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5437 v1ij=v1(j,itori,itori1)
5438 v2ij=v2(j,itori,itori1)
5441 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5442 if (energy_dec) etors_ii=etors_ii+
5443 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5444 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5447 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5450 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5451 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5452 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5453 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5454 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5456 ! 6/20/98 - dihedral angle constraints
5459 itori=idih_constr(i)
5462 if (difi.gt.drange(i)) then
5464 edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5465 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5466 else if (difi.lt.-drange(i)) then
5468 edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5469 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5471 ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5472 ! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5474 ! write (iout,*) 'edihcnstr',edihcnstr
5477 c------------------------------------------------------------------------------
5478 subroutine etor_d(etors_d)
5482 c----------------------------------------------------------------------------
5484 subroutine etor(etors,edihcnstr)
5485 implicit real*8 (a-h,o-z)
5486 include 'DIMENSIONS'
5487 include 'COMMON.VAR'
5488 include 'COMMON.GEO'
5489 include 'COMMON.LOCAL'
5490 include 'COMMON.TORSION'
5491 include 'COMMON.INTERACT'
5492 include 'COMMON.DERIV'
5493 include 'COMMON.CHAIN'
5494 include 'COMMON.NAMES'
5495 include 'COMMON.IOUNITS'
5496 include 'COMMON.FFIELD'
5497 include 'COMMON.TORCNSTR'
5498 include 'COMMON.CONTROL'
5500 C Set lprn=.true. for debugging
5504 do i=iphi_start,iphi_end
5505 if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5506 & .or. itype(i).eq.21) cycle
5508 itori=itortyp(itype(i-2))
5509 itori1=itortyp(itype(i-1))
5512 C Regular cosine and sine terms
5513 do j=1,nterm(itori,itori1)
5514 v1ij=v1(j,itori,itori1)
5515 v2ij=v2(j,itori,itori1)
5518 etors=etors+v1ij*cosphi+v2ij*sinphi
5519 if (energy_dec) etors_ii=etors_ii+
5520 & v1ij*cosphi+v2ij*sinphi
5521 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5525 C E = SUM ----------------------------------- - v1
5526 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5528 cosphi=dcos(0.5d0*phii)
5529 sinphi=dsin(0.5d0*phii)
5530 do j=1,nlor(itori,itori1)
5531 vl1ij=vlor1(j,itori,itori1)
5532 vl2ij=vlor2(j,itori,itori1)
5533 vl3ij=vlor3(j,itori,itori1)
5534 pom=vl2ij*cosphi+vl3ij*sinphi
5535 pom1=1.0d0/(pom*pom+1.0d0)
5536 etors=etors+vl1ij*pom1
5537 if (energy_dec) etors_ii=etors_ii+
5540 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5542 C Subtract the constant term
5543 etors=etors-v0(itori,itori1)
5544 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5545 & 'etor',i,etors_ii-v0(itori,itori1)
5547 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5548 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5549 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5550 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5551 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5553 ! 6/20/98 - dihedral angle constraints
5555 c do i=1,ndih_constr
5556 do i=idihconstr_start,idihconstr_end
5557 itori=idih_constr(i)
5559 difi=pinorm(phii-phi0(i))
5560 if (difi.gt.drange(i)) then
5562 edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5563 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5564 else if (difi.lt.-drange(i)) then
5566 edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5567 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5571 cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5572 cd & rad2deg*phi0(i), rad2deg*drange(i),
5573 cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5575 cd write (iout,*) 'edihcnstr',edihcnstr
5578 c----------------------------------------------------------------------------
5579 subroutine etor_d(etors_d)
5580 C 6/23/01 Compute double torsional energy
5581 implicit real*8 (a-h,o-z)
5582 include 'DIMENSIONS'
5583 include 'COMMON.VAR'
5584 include 'COMMON.GEO'
5585 include 'COMMON.LOCAL'
5586 include 'COMMON.TORSION'
5587 include 'COMMON.INTERACT'
5588 include 'COMMON.DERIV'
5589 include 'COMMON.CHAIN'
5590 include 'COMMON.NAMES'
5591 include 'COMMON.IOUNITS'
5592 include 'COMMON.FFIELD'
5593 include 'COMMON.TORCNSTR'
5595 C Set lprn=.true. for debugging
5599 do i=iphid_start,iphid_end
5600 if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5601 & .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle
5602 itori=itortyp(itype(i-2))
5603 itori1=itortyp(itype(i-1))
5604 itori2=itortyp(itype(i))
5609 C Regular cosine and sine terms
5610 do j=1,ntermd_1(itori,itori1,itori2)
5611 v1cij=v1c(1,j,itori,itori1,itori2)
5612 v1sij=v1s(1,j,itori,itori1,itori2)
5613 v2cij=v1c(2,j,itori,itori1,itori2)
5614 v2sij=v1s(2,j,itori,itori1,itori2)
5615 cosphi1=dcos(j*phii)
5616 sinphi1=dsin(j*phii)
5617 cosphi2=dcos(j*phii1)
5618 sinphi2=dsin(j*phii1)
5619 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5620 & v2cij*cosphi2+v2sij*sinphi2
5621 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5622 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5624 do k=2,ntermd_2(itori,itori1,itori2)
5626 v1cdij = v2c(k,l,itori,itori1,itori2)
5627 v2cdij = v2c(l,k,itori,itori1,itori2)
5628 v1sdij = v2s(k,l,itori,itori1,itori2)
5629 v2sdij = v2s(l,k,itori,itori1,itori2)
5630 cosphi1p2=dcos(l*phii+(k-l)*phii1)
5631 cosphi1m2=dcos(l*phii-(k-l)*phii1)
5632 sinphi1p2=dsin(l*phii+(k-l)*phii1)
5633 sinphi1m2=dsin(l*phii-(k-l)*phii1)
5634 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5635 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
5636 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5637 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5638 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5639 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5642 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5643 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5648 c------------------------------------------------------------------------------
5649 subroutine eback_sc_corr(esccor)
5650 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5651 c conformational states; temporarily implemented as differences
5652 c between UNRES torsional potentials (dependent on three types of
5653 c residues) and the torsional potentials dependent on all 20 types
5654 c of residues computed from AM1 energy surfaces of terminally-blocked
5655 c amino-acid residues.
5656 implicit real*8 (a-h,o-z)
5657 include 'DIMENSIONS'
5658 include 'COMMON.VAR'
5659 include 'COMMON.GEO'
5660 include 'COMMON.LOCAL'
5661 include 'COMMON.TORSION'
5662 include 'COMMON.SCCOR'
5663 include 'COMMON.INTERACT'
5664 include 'COMMON.DERIV'
5665 include 'COMMON.CHAIN'
5666 include 'COMMON.NAMES'
5667 include 'COMMON.IOUNITS'
5668 include 'COMMON.FFIELD'
5669 include 'COMMON.CONTROL'
5671 C Set lprn=.true. for debugging
5674 c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5676 do i=iphi_start,iphi_end
5677 if (itype(i-2).eq.21 .or. itype(i-1).eq.21) cycle
5684 v1ij=v1sccor(j,itori,itori1)
5685 v2ij=v2sccor(j,itori,itori1)
5688 esccor=esccor+v1ij*cosphi+v2ij*sinphi
5689 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5692 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5693 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5694 & (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5695 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5699 c----------------------------------------------------------------------------
5700 subroutine multibody(ecorr)
5701 C This subroutine calculates multi-body contributions to energy following
5702 C the idea of Skolnick et al. If side chains I and J make a contact and
5703 C at the same time side chains I+1 and J+1 make a contact, an extra
5704 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5705 implicit real*8 (a-h,o-z)
5706 include 'DIMENSIONS'
5707 include 'COMMON.IOUNITS'
5708 include 'COMMON.DERIV'
5709 include 'COMMON.INTERACT'
5710 include 'COMMON.CONTACTS'
5711 double precision gx(3),gx1(3)
5714 C Set lprn=.true. for debugging
5718 write (iout,'(a)') 'Contact function values:'
5720 write (iout,'(i2,20(1x,i2,f10.5))')
5721 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5736 num_conti=num_cont(i)
5737 num_conti1=num_cont(i1)
5742 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5743 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5744 cd & ' ishift=',ishift
5745 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5746 C The system gains extra energy.
5747 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5748 endif ! j1==j+-ishift
5757 c------------------------------------------------------------------------------
5758 double precision function esccorr(i,j,k,l,jj,kk)
5759 implicit real*8 (a-h,o-z)
5760 include 'DIMENSIONS'
5761 include 'COMMON.IOUNITS'
5762 include 'COMMON.DERIV'
5763 include 'COMMON.INTERACT'
5764 include 'COMMON.CONTACTS'
5765 double precision gx(3),gx1(3)
5770 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5771 C Calculate the multi-body contribution to energy.
5772 C Calculate multi-body contributions to the gradient.
5773 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5774 cd & k,l,(gacont(m,kk,k),m=1,3)
5776 gx(m) =ekl*gacont(m,jj,i)
5777 gx1(m)=eij*gacont(m,kk,k)
5778 gradxorr(m,i)=gradxorr(m,i)-gx(m)
5779 gradxorr(m,j)=gradxorr(m,j)+gx(m)
5780 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5781 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5785 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5790 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5796 c------------------------------------------------------------------------------
5797 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5798 C This subroutine calculates multi-body contributions to hydrogen-bonding
5799 implicit real*8 (a-h,o-z)
5800 include 'DIMENSIONS'
5801 include 'COMMON.IOUNITS'
5804 parameter (max_cont=maxconts)
5805 parameter (max_dim=26)
5806 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5807 double precision zapas(max_dim,maxconts,max_fg_procs),
5808 & zapas_recv(max_dim,maxconts,max_fg_procs)
5809 common /przechowalnia/ zapas
5810 integer status(MPI_STATUS_SIZE),req(maxconts*2),
5811 & status_array(MPI_STATUS_SIZE,maxconts*2)
5813 include 'COMMON.SETUP'
5814 include 'COMMON.FFIELD'
5815 include 'COMMON.DERIV'
5816 include 'COMMON.INTERACT'
5817 include 'COMMON.CONTACTS'
5818 include 'COMMON.CONTROL'
5819 include 'COMMON.LOCAL'
5820 double precision gx(3),gx1(3),time00
5823 C Set lprn=.true. for debugging
5828 if (nfgtasks.le.1) goto 30
5830 write (iout,'(a)') 'Contact function values before RECEIVE:'
5832 write (iout,'(2i3,50(1x,i2,f5.2))')
5833 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5834 & j=1,num_cont_hb(i))
5838 do i=1,ntask_cont_from
5841 do i=1,ntask_cont_to
5844 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5846 C Make the list of contacts to send to send to other procesors
5847 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5849 do i=iturn3_start,iturn3_end
5850 c write (iout,*) "make contact list turn3",i," num_cont",
5852 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5854 do i=iturn4_start,iturn4_end
5855 c write (iout,*) "make contact list turn4",i," num_cont",
5857 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5861 c write (iout,*) "make contact list longrange",i,ii," num_cont",
5863 do j=1,num_cont_hb(i)
5866 iproc=iint_sent_local(k,jjc,ii)
5867 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5868 if (iproc.gt.0) then
5869 ncont_sent(iproc)=ncont_sent(iproc)+1
5870 nn=ncont_sent(iproc)
5872 zapas(2,nn,iproc)=jjc
5873 zapas(3,nn,iproc)=facont_hb(j,i)
5874 zapas(4,nn,iproc)=ees0p(j,i)
5875 zapas(5,nn,iproc)=ees0m(j,i)
5876 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5877 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5878 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5879 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5880 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5881 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5882 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5883 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5884 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5885 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5886 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5887 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5888 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5889 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5890 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5891 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5892 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5893 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5894 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5895 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5896 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5903 & "Numbers of contacts to be sent to other processors",
5904 & (ncont_sent(i),i=1,ntask_cont_to)
5905 write (iout,*) "Contacts sent"
5906 do ii=1,ntask_cont_to
5908 iproc=itask_cont_to(ii)
5909 write (iout,*) nn," contacts to processor",iproc,
5910 & " of CONT_TO_COMM group"
5912 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5920 CorrelID1=nfgtasks+fg_rank+1
5922 C Receive the numbers of needed contacts from other processors
5923 do ii=1,ntask_cont_from
5924 iproc=itask_cont_from(ii)
5926 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
5927 & FG_COMM,req(ireq),IERR)
5929 c write (iout,*) "IRECV ended"
5931 C Send the number of contacts needed by other processors
5932 do ii=1,ntask_cont_to
5933 iproc=itask_cont_to(ii)
5935 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
5936 & FG_COMM,req(ireq),IERR)
5938 c write (iout,*) "ISEND ended"
5939 c write (iout,*) "number of requests (nn)",ireq
5942 & call MPI_Waitall(ireq,req,status_array,ierr)
5944 c & "Numbers of contacts to be received from other processors",
5945 c & (ncont_recv(i),i=1,ntask_cont_from)
5949 do ii=1,ntask_cont_from
5950 iproc=itask_cont_from(ii)
5952 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
5953 c & " of CONT_TO_COMM group"
5957 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
5958 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
5959 c write (iout,*) "ireq,req",ireq,req(ireq)
5962 C Send the contacts to processors that need them
5963 do ii=1,ntask_cont_to
5964 iproc=itask_cont_to(ii)
5966 c write (iout,*) nn," contacts to processor",iproc,
5967 c & " of CONT_TO_COMM group"
5970 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
5971 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
5972 c write (iout,*) "ireq,req",ireq,req(ireq)
5974 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5978 c write (iout,*) "number of requests (contacts)",ireq
5979 c write (iout,*) "req",(req(i),i=1,4)
5982 & call MPI_Waitall(ireq,req,status_array,ierr)
5983 do iii=1,ntask_cont_from
5984 iproc=itask_cont_from(iii)
5987 write (iout,*) "Received",nn," contacts from processor",iproc,
5988 & " of CONT_FROM_COMM group"
5991 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
5996 ii=zapas_recv(1,i,iii)
5997 c Flag the received contacts to prevent double-counting
5998 jj=-zapas_recv(2,i,iii)
5999 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6001 nnn=num_cont_hb(ii)+1
6004 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6005 ees0p(nnn,ii)=zapas_recv(4,i,iii)
6006 ees0m(nnn,ii)=zapas_recv(5,i,iii)
6007 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6008 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6009 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6010 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6011 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6012 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6013 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6014 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6015 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6016 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6017 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6018 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6019 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6020 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6021 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6022 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6023 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6024 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6025 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6026 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6027 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6032 write (iout,'(a)') 'Contact function values after receive:'
6034 write (iout,'(2i3,50(1x,i3,f5.2))')
6035 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6036 & j=1,num_cont_hb(i))
6043 write (iout,'(a)') 'Contact function values:'
6045 write (iout,'(2i3,50(1x,i3,f5.2))')
6046 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6047 & j=1,num_cont_hb(i))
6051 C Remove the loop below after debugging !!!
6058 C Calculate the local-electrostatic correlation terms
6059 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6061 num_conti=num_cont_hb(i)
6062 num_conti1=num_cont_hb(i+1)
6069 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6070 c & ' jj=',jj,' kk=',kk
6071 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6072 & .or. j.lt.0 .and. j1.gt.0) .and.
6073 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6074 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6075 C The system gains extra energy.
6076 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6077 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6078 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6080 else if (j1.eq.j) then
6081 C Contacts I-J and I-(J+1) occur simultaneously.
6082 C The system loses extra energy.
6083 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6088 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6089 c & ' jj=',jj,' kk=',kk
6091 C Contacts I-J and (I+1)-J occur simultaneously.
6092 C The system loses extra energy.
6093 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6100 c------------------------------------------------------------------------------
6101 subroutine add_hb_contact(ii,jj,itask)
6102 implicit real*8 (a-h,o-z)
6103 include "DIMENSIONS"
6104 include "COMMON.IOUNITS"
6107 parameter (max_cont=maxconts)
6108 parameter (max_dim=26)
6109 include "COMMON.CONTACTS"
6110 double precision zapas(max_dim,maxconts,max_fg_procs),
6111 & zapas_recv(max_dim,maxconts,max_fg_procs)
6112 common /przechowalnia/ zapas
6113 integer i,j,ii,jj,iproc,itask(4),nn
6114 c write (iout,*) "itask",itask
6117 if (iproc.gt.0) then
6118 do j=1,num_cont_hb(ii)
6120 c write (iout,*) "i",ii," j",jj," jjc",jjc
6122 ncont_sent(iproc)=ncont_sent(iproc)+1
6123 nn=ncont_sent(iproc)
6124 zapas(1,nn,iproc)=ii
6125 zapas(2,nn,iproc)=jjc
6126 zapas(3,nn,iproc)=facont_hb(j,ii)
6127 zapas(4,nn,iproc)=ees0p(j,ii)
6128 zapas(5,nn,iproc)=ees0m(j,ii)
6129 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6130 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6131 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6132 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6133 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6134 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6135 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6136 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6137 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6138 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6139 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6140 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6141 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6142 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6143 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6144 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6145 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6146 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6147 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6148 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6149 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6157 c------------------------------------------------------------------------------
6158 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6160 C This subroutine calculates multi-body contributions to hydrogen-bonding
6161 implicit real*8 (a-h,o-z)
6162 include 'DIMENSIONS'
6163 include 'COMMON.IOUNITS'
6166 parameter (max_cont=maxconts)
6167 parameter (max_dim=70)
6168 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6169 double precision zapas(max_dim,maxconts,max_fg_procs),
6170 & zapas_recv(max_dim,maxconts,max_fg_procs)
6171 common /przechowalnia/ zapas
6172 integer status(MPI_STATUS_SIZE),req(maxconts*2),
6173 & status_array(MPI_STATUS_SIZE,maxconts*2)
6175 include 'COMMON.SETUP'
6176 include 'COMMON.FFIELD'
6177 include 'COMMON.DERIV'
6178 include 'COMMON.LOCAL'
6179 include 'COMMON.INTERACT'
6180 include 'COMMON.CONTACTS'
6181 include 'COMMON.CHAIN'
6182 include 'COMMON.CONTROL'
6183 double precision gx(3),gx1(3)
6184 integer num_cont_hb_old(maxres)
6186 double precision eello4,eello5,eelo6,eello_turn6
6187 external eello4,eello5,eello6,eello_turn6
6188 C Set lprn=.true. for debugging
6193 num_cont_hb_old(i)=num_cont_hb(i)
6197 if (nfgtasks.le.1) goto 30
6199 write (iout,'(a)') 'Contact function values before RECEIVE:'
6201 write (iout,'(2i3,50(1x,i2,f5.2))')
6202 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6203 & j=1,num_cont_hb(i))
6207 do i=1,ntask_cont_from
6210 do i=1,ntask_cont_to
6213 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6215 C Make the list of contacts to send to send to other procesors
6216 do i=iturn3_start,iturn3_end
6217 c write (iout,*) "make contact list turn3",i," num_cont",
6219 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6221 do i=iturn4_start,iturn4_end
6222 c write (iout,*) "make contact list turn4",i," num_cont",
6224 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6228 c write (iout,*) "make contact list longrange",i,ii," num_cont",
6230 do j=1,num_cont_hb(i)
6233 iproc=iint_sent_local(k,jjc,ii)
6234 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6235 if (iproc.ne.0) then
6236 ncont_sent(iproc)=ncont_sent(iproc)+1
6237 nn=ncont_sent(iproc)
6239 zapas(2,nn,iproc)=jjc
6240 zapas(3,nn,iproc)=d_cont(j,i)
6244 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6249 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6257 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6268 & "Numbers of contacts to be sent to other processors",
6269 & (ncont_sent(i),i=1,ntask_cont_to)
6270 write (iout,*) "Contacts sent"
6271 do ii=1,ntask_cont_to
6273 iproc=itask_cont_to(ii)
6274 write (iout,*) nn," contacts to processor",iproc,
6275 & " of CONT_TO_COMM group"
6277 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6285 CorrelID1=nfgtasks+fg_rank+1
6287 C Receive the numbers of needed contacts from other processors
6288 do ii=1,ntask_cont_from
6289 iproc=itask_cont_from(ii)
6291 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6292 & FG_COMM,req(ireq),IERR)
6294 c write (iout,*) "IRECV ended"
6296 C Send the number of contacts needed by other processors
6297 do ii=1,ntask_cont_to
6298 iproc=itask_cont_to(ii)
6300 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6301 & FG_COMM,req(ireq),IERR)
6303 c write (iout,*) "ISEND ended"
6304 c write (iout,*) "number of requests (nn)",ireq
6307 & call MPI_Waitall(ireq,req,status_array,ierr)
6309 c & "Numbers of contacts to be received from other processors",
6310 c & (ncont_recv(i),i=1,ntask_cont_from)
6314 do ii=1,ntask_cont_from
6315 iproc=itask_cont_from(ii)
6317 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
6318 c & " of CONT_TO_COMM group"
6322 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6323 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6324 c write (iout,*) "ireq,req",ireq,req(ireq)
6327 C Send the contacts to processors that need them
6328 do ii=1,ntask_cont_to
6329 iproc=itask_cont_to(ii)
6331 c write (iout,*) nn," contacts to processor",iproc,
6332 c & " of CONT_TO_COMM group"
6335 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6336 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6337 c write (iout,*) "ireq,req",ireq,req(ireq)
6339 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6343 c write (iout,*) "number of requests (contacts)",ireq
6344 c write (iout,*) "req",(req(i),i=1,4)
6347 & call MPI_Waitall(ireq,req,status_array,ierr)
6348 do iii=1,ntask_cont_from
6349 iproc=itask_cont_from(iii)
6352 write (iout,*) "Received",nn," contacts from processor",iproc,
6353 & " of CONT_FROM_COMM group"
6356 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6361 ii=zapas_recv(1,i,iii)
6362 c Flag the received contacts to prevent double-counting
6363 jj=-zapas_recv(2,i,iii)
6364 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6366 nnn=num_cont_hb(ii)+1
6369 d_cont(nnn,ii)=zapas_recv(3,i,iii)
6373 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6378 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6386 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6395 write (iout,'(a)') 'Contact function values after receive:'
6397 write (iout,'(2i3,50(1x,i3,5f6.3))')
6398 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6399 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6406 write (iout,'(a)') 'Contact function values:'
6408 write (iout,'(2i3,50(1x,i2,5f6.3))')
6409 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6410 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6416 C Remove the loop below after debugging !!!
6423 C Calculate the dipole-dipole interaction energies
6424 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6425 do i=iatel_s,iatel_e+1
6426 num_conti=num_cont_hb(i)
6435 C Calculate the local-electrostatic correlation terms
6436 c write (iout,*) "gradcorr5 in eello5 before loop"
6438 c write (iout,'(i5,3f10.5)')
6439 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
6441 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6442 c write (iout,*) "corr loop i",i
6444 num_conti=num_cont_hb(i)
6445 num_conti1=num_cont_hb(i+1)
6452 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6453 c & ' jj=',jj,' kk=',kk
6454 c if (j1.eq.j+1 .or. j1.eq.j-1) then
6455 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6456 & .or. j.lt.0 .and. j1.gt.0) .and.
6457 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6458 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6459 C The system gains extra energy.
6461 sqd1=dsqrt(d_cont(jj,i))
6462 sqd2=dsqrt(d_cont(kk,i1))
6463 sred_geom = sqd1*sqd2
6464 IF (sred_geom.lt.cutoff_corr) THEN
6465 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6467 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6468 cd & ' jj=',jj,' kk=',kk
6469 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6470 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6472 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6473 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6476 cd write (iout,*) 'sred_geom=',sred_geom,
6477 cd & ' ekont=',ekont,' fprim=',fprimcont,
6478 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6479 cd write (iout,*) "g_contij",g_contij
6480 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6481 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6482 call calc_eello(i,jp,i+1,jp1,jj,kk)
6483 if (wcorr4.gt.0.0d0)
6484 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6485 if (energy_dec.and.wcorr4.gt.0.0d0)
6486 1 write (iout,'(a6,4i5,0pf7.3)')
6487 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6488 c write (iout,*) "gradcorr5 before eello5"
6490 c write (iout,'(i5,3f10.5)')
6491 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
6493 if (wcorr5.gt.0.0d0)
6494 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6495 c write (iout,*) "gradcorr5 after eello5"
6497 c write (iout,'(i5,3f10.5)')
6498 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
6500 if (energy_dec.and.wcorr5.gt.0.0d0)
6501 1 write (iout,'(a6,4i5,0pf7.3)')
6502 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6503 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6504 cd write(2,*)'ijkl',i,jp,i+1,jp1
6505 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6506 & .or. wturn6.eq.0.0d0))then
6507 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6508 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6509 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6510 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6511 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6512 cd & 'ecorr6=',ecorr6
6513 cd write (iout,'(4e15.5)') sred_geom,
6514 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6515 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6516 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
6517 else if (wturn6.gt.0.0d0
6518 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6519 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6520 eturn6=eturn6+eello_turn6(i,jj,kk)
6521 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6522 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6523 cd write (2,*) 'multibody_eello:eturn6',eturn6
6532 num_cont_hb(i)=num_cont_hb_old(i)
6534 c write (iout,*) "gradcorr5 in eello5"
6536 c write (iout,'(i5,3f10.5)')
6537 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
6541 c------------------------------------------------------------------------------
6542 subroutine add_hb_contact_eello(ii,jj,itask)
6543 implicit real*8 (a-h,o-z)
6544 include "DIMENSIONS"
6545 include "COMMON.IOUNITS"
6548 parameter (max_cont=maxconts)
6549 parameter (max_dim=70)
6550 include "COMMON.CONTACTS"
6551 double precision zapas(max_dim,maxconts,max_fg_procs),
6552 & zapas_recv(max_dim,maxconts,max_fg_procs)
6553 common /przechowalnia/ zapas
6554 integer i,j,ii,jj,iproc,itask(4),nn
6555 c write (iout,*) "itask",itask
6558 if (iproc.gt.0) then
6559 do j=1,num_cont_hb(ii)
6561 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6563 ncont_sent(iproc)=ncont_sent(iproc)+1
6564 nn=ncont_sent(iproc)
6565 zapas(1,nn,iproc)=ii
6566 zapas(2,nn,iproc)=jjc
6567 zapas(3,nn,iproc)=d_cont(j,ii)
6571 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6576 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6584 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6596 c------------------------------------------------------------------------------
6597 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6598 implicit real*8 (a-h,o-z)
6599 include 'DIMENSIONS'
6600 include 'COMMON.IOUNITS'
6601 include 'COMMON.DERIV'
6602 include 'COMMON.INTERACT'
6603 include 'COMMON.CONTACTS'
6604 double precision gx(3),gx1(3)
6614 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6615 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6616 C Following 4 lines for diagnostics.
6621 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6622 c & 'Contacts ',i,j,
6623 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6624 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6626 C Calculate the multi-body contribution to energy.
6627 c ecorr=ecorr+ekont*ees
6628 C Calculate multi-body contributions to the gradient.
6629 coeffpees0pij=coeffp*ees0pij
6630 coeffmees0mij=coeffm*ees0mij
6631 coeffpees0pkl=coeffp*ees0pkl
6632 coeffmees0mkl=coeffm*ees0mkl
6634 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6635 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6636 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6637 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
6638 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6639 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6640 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
6641 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6642 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6643 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6644 & coeffmees0mij*gacontm_hb1(ll,kk,k))
6645 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6646 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6647 & coeffmees0mij*gacontm_hb2(ll,kk,k))
6648 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6649 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6650 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
6651 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6652 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6653 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6654 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6655 & coeffmees0mij*gacontm_hb3(ll,kk,k))
6656 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6657 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6658 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6663 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
6664 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
6665 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6666 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6671 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
6672 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
6673 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6674 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6677 c write (iout,*) "ehbcorr",ekont*ees
6682 C---------------------------------------------------------------------------
6683 subroutine dipole(i,j,jj)
6684 implicit real*8 (a-h,o-z)
6685 include 'DIMENSIONS'
6686 include 'COMMON.IOUNITS'
6687 include 'COMMON.CHAIN'
6688 include 'COMMON.FFIELD'
6689 include 'COMMON.DERIV'
6690 include 'COMMON.INTERACT'
6691 include 'COMMON.CONTACTS'
6692 include 'COMMON.TORSION'
6693 include 'COMMON.VAR'
6694 include 'COMMON.GEO'
6695 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6697 iti1 = itortyp(itype(i+1))
6698 if (j.lt.nres-1) then
6699 itj1 = itortyp(itype(j+1))
6704 dipi(iii,1)=Ub2(iii,i)
6705 dipderi(iii)=Ub2der(iii,i)
6706 dipi(iii,2)=b1(iii,iti1)
6707 dipj(iii,1)=Ub2(iii,j)
6708 dipderj(iii)=Ub2der(iii,j)
6709 dipj(iii,2)=b1(iii,itj1)
6713 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6716 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6723 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6727 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6732 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6733 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6735 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6737 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6739 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6744 C---------------------------------------------------------------------------
6745 subroutine calc_eello(i,j,k,l,jj,kk)
6747 C This subroutine computes matrices and vectors needed to calculate
6748 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6750 implicit real*8 (a-h,o-z)
6751 include 'DIMENSIONS'
6752 include 'COMMON.IOUNITS'
6753 include 'COMMON.CHAIN'
6754 include 'COMMON.DERIV'
6755 include 'COMMON.INTERACT'
6756 include 'COMMON.CONTACTS'
6757 include 'COMMON.TORSION'
6758 include 'COMMON.VAR'
6759 include 'COMMON.GEO'
6760 include 'COMMON.FFIELD'
6761 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6762 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6765 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6766 cd & ' jj=',jj,' kk=',kk
6767 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6768 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6769 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6772 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6773 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6776 call transpose2(aa1(1,1),aa1t(1,1))
6777 call transpose2(aa2(1,1),aa2t(1,1))
6780 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6781 & aa1tder(1,1,lll,kkk))
6782 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6783 & aa2tder(1,1,lll,kkk))
6787 C parallel orientation of the two CA-CA-CA frames.
6789 iti=itortyp(itype(i))
6793 itk1=itortyp(itype(k+1))
6794 itj=itortyp(itype(j))
6795 if (l.lt.nres-1) then
6796 itl1=itortyp(itype(l+1))
6800 C A1 kernel(j+1) A2T
6802 cd write (iout,'(3f10.5,5x,3f10.5)')
6803 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6805 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6806 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6807 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6808 C Following matrices are needed only for 6-th order cumulants
6809 IF (wcorr6.gt.0.0d0) THEN
6810 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6811 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6812 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6813 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6814 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6815 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6816 & ADtEAderx(1,1,1,1,1,1))
6818 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6819 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6820 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6821 & ADtEA1derx(1,1,1,1,1,1))
6823 C End 6-th order cumulants
6826 cd write (2,*) 'In calc_eello6'
6828 cd write (2,*) 'iii=',iii
6830 cd write (2,*) 'kkk=',kkk
6832 cd write (2,'(3(2f10.5),5x)')
6833 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6838 call transpose2(EUgder(1,1,k),auxmat(1,1))
6839 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6840 call transpose2(EUg(1,1,k),auxmat(1,1))
6841 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6842 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6846 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6847 & EAEAderx(1,1,lll,kkk,iii,1))
6851 C A1T kernel(i+1) A2
6852 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6853 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6854 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6855 C Following matrices are needed only for 6-th order cumulants
6856 IF (wcorr6.gt.0.0d0) THEN
6857 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6858 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6859 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6860 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6861 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6862 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6863 & ADtEAderx(1,1,1,1,1,2))
6864 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6865 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6866 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6867 & ADtEA1derx(1,1,1,1,1,2))
6869 C End 6-th order cumulants
6870 call transpose2(EUgder(1,1,l),auxmat(1,1))
6871 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6872 call transpose2(EUg(1,1,l),auxmat(1,1))
6873 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6874 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6878 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6879 & EAEAderx(1,1,lll,kkk,iii,2))
6884 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6885 C They are needed only when the fifth- or the sixth-order cumulants are
6887 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6888 call transpose2(AEA(1,1,1),auxmat(1,1))
6889 call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6890 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6891 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6892 call transpose2(AEAderg(1,1,1),auxmat(1,1))
6893 call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6894 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6895 call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6896 call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6897 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6898 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6899 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6900 call transpose2(AEA(1,1,2),auxmat(1,1))
6901 call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6902 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6903 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6904 call transpose2(AEAderg(1,1,2),auxmat(1,1))
6905 call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6906 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6907 call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6908 call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6909 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6910 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6911 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6912 C Calculate the Cartesian derivatives of the vectors.
6916 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6917 call matvec2(auxmat(1,1),b1(1,iti),
6918 & AEAb1derx(1,lll,kkk,iii,1,1))
6919 call matvec2(auxmat(1,1),Ub2(1,i),
6920 & AEAb2derx(1,lll,kkk,iii,1,1))
6921 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6922 & AEAb1derx(1,lll,kkk,iii,2,1))
6923 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6924 & AEAb2derx(1,lll,kkk,iii,2,1))
6925 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6926 call matvec2(auxmat(1,1),b1(1,itj),
6927 & AEAb1derx(1,lll,kkk,iii,1,2))
6928 call matvec2(auxmat(1,1),Ub2(1,j),
6929 & AEAb2derx(1,lll,kkk,iii,1,2))
6930 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6931 & AEAb1derx(1,lll,kkk,iii,2,2))
6932 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6933 & AEAb2derx(1,lll,kkk,iii,2,2))
6940 C Antiparallel orientation of the two CA-CA-CA frames.
6942 iti=itortyp(itype(i))
6946 itk1=itortyp(itype(k+1))
6947 itl=itortyp(itype(l))
6948 itj=itortyp(itype(j))
6949 if (j.lt.nres-1) then
6950 itj1=itortyp(itype(j+1))
6954 C A2 kernel(j-1)T A1T
6955 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6956 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6957 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6958 C Following matrices are needed only for 6-th order cumulants
6959 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6960 & j.eq.i+4 .and. l.eq.i+3)) THEN
6961 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6962 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6963 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6964 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6965 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6966 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6967 & ADtEAderx(1,1,1,1,1,1))
6968 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6969 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6970 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6971 & ADtEA1derx(1,1,1,1,1,1))
6973 C End 6-th order cumulants
6974 call transpose2(EUgder(1,1,k),auxmat(1,1))
6975 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6976 call transpose2(EUg(1,1,k),auxmat(1,1))
6977 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6978 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6982 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6983 & EAEAderx(1,1,lll,kkk,iii,1))
6987 C A2T kernel(i+1)T A1
6988 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6989 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6990 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6991 C Following matrices are needed only for 6-th order cumulants
6992 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6993 & j.eq.i+4 .and. l.eq.i+3)) THEN
6994 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6995 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6996 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6997 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6998 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6999 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7000 & ADtEAderx(1,1,1,1,1,2))
7001 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7002 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7003 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7004 & ADtEA1derx(1,1,1,1,1,2))
7006 C End 6-th order cumulants
7007 call transpose2(EUgder(1,1,j),auxmat(1,1))
7008 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7009 call transpose2(EUg(1,1,j),auxmat(1,1))
7010 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7011 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7015 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7016 & EAEAderx(1,1,lll,kkk,iii,2))
7021 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7022 C They are needed only when the fifth- or the sixth-order cumulants are
7024 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7025 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7026 call transpose2(AEA(1,1,1),auxmat(1,1))
7027 call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7028 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7029 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7030 call transpose2(AEAderg(1,1,1),auxmat(1,1))
7031 call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7032 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7033 call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7034 call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7035 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7036 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7037 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7038 call transpose2(AEA(1,1,2),auxmat(1,1))
7039 call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7040 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7041 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7042 call transpose2(AEAderg(1,1,2),auxmat(1,1))
7043 call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7044 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7045 call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7046 call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7047 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7048 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7049 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7050 C Calculate the Cartesian derivatives of the vectors.
7054 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7055 call matvec2(auxmat(1,1),b1(1,iti),
7056 & AEAb1derx(1,lll,kkk,iii,1,1))
7057 call matvec2(auxmat(1,1),Ub2(1,i),
7058 & AEAb2derx(1,lll,kkk,iii,1,1))
7059 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7060 & AEAb1derx(1,lll,kkk,iii,2,1))
7061 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7062 & AEAb2derx(1,lll,kkk,iii,2,1))
7063 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7064 call matvec2(auxmat(1,1),b1(1,itl),
7065 & AEAb1derx(1,lll,kkk,iii,1,2))
7066 call matvec2(auxmat(1,1),Ub2(1,l),
7067 & AEAb2derx(1,lll,kkk,iii,1,2))
7068 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7069 & AEAb1derx(1,lll,kkk,iii,2,2))
7070 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7071 & AEAb2derx(1,lll,kkk,iii,2,2))
7080 C---------------------------------------------------------------------------
7081 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7082 & KK,KKderg,AKA,AKAderg,AKAderx)
7086 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7087 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7088 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7093 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7095 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7098 cd if (lprn) write (2,*) 'In kernel'
7100 cd if (lprn) write (2,*) 'kkk=',kkk
7102 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7103 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7105 cd write (2,*) 'lll=',lll
7106 cd write (2,*) 'iii=1'
7108 cd write (2,'(3(2f10.5),5x)')
7109 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7112 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7113 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7115 cd write (2,*) 'lll=',lll
7116 cd write (2,*) 'iii=2'
7118 cd write (2,'(3(2f10.5),5x)')
7119 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7126 C---------------------------------------------------------------------------
7127 double precision function eello4(i,j,k,l,jj,kk)
7128 implicit real*8 (a-h,o-z)
7129 include 'DIMENSIONS'
7130 include 'COMMON.IOUNITS'
7131 include 'COMMON.CHAIN'
7132 include 'COMMON.DERIV'
7133 include 'COMMON.INTERACT'
7134 include 'COMMON.CONTACTS'
7135 include 'COMMON.TORSION'
7136 include 'COMMON.VAR'
7137 include 'COMMON.GEO'
7138 double precision pizda(2,2),ggg1(3),ggg2(3)
7139 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7143 cd print *,'eello4:',i,j,k,l,jj,kk
7144 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
7145 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
7146 cold eij=facont_hb(jj,i)
7147 cold ekl=facont_hb(kk,k)
7149 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7150 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7151 gcorr_loc(k-1)=gcorr_loc(k-1)
7152 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7154 gcorr_loc(l-1)=gcorr_loc(l-1)
7155 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7157 gcorr_loc(j-1)=gcorr_loc(j-1)
7158 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7163 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7164 & -EAEAderx(2,2,lll,kkk,iii,1)
7165 cd derx(lll,kkk,iii)=0.0d0
7169 cd gcorr_loc(l-1)=0.0d0
7170 cd gcorr_loc(j-1)=0.0d0
7171 cd gcorr_loc(k-1)=0.0d0
7173 cd write (iout,*)'Contacts have occurred for peptide groups',
7174 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
7175 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7176 if (j.lt.nres-1) then
7183 if (l.lt.nres-1) then
7191 cgrad ggg1(ll)=eel4*g_contij(ll,1)
7192 cgrad ggg2(ll)=eel4*g_contij(ll,2)
7193 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7194 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7195 cgrad ghalf=0.5d0*ggg1(ll)
7196 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7197 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7198 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7199 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7200 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7201 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7202 cgrad ghalf=0.5d0*ggg2(ll)
7203 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7204 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7205 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7206 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7207 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7208 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7212 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7217 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7222 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7227 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7231 cd write (2,*) iii,gcorr_loc(iii)
7234 cd write (2,*) 'ekont',ekont
7235 cd write (iout,*) 'eello4',ekont*eel4
7238 C---------------------------------------------------------------------------
7239 double precision function eello5(i,j,k,l,jj,kk)
7240 implicit real*8 (a-h,o-z)
7241 include 'DIMENSIONS'
7242 include 'COMMON.IOUNITS'
7243 include 'COMMON.CHAIN'
7244 include 'COMMON.DERIV'
7245 include 'COMMON.INTERACT'
7246 include 'COMMON.CONTACTS'
7247 include 'COMMON.TORSION'
7248 include 'COMMON.VAR'
7249 include 'COMMON.GEO'
7250 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7251 double precision ggg1(3),ggg2(3)
7252 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7257 C /l\ / \ \ / \ / \ / C
7258 C / \ / \ \ / \ / \ / C
7259 C j| o |l1 | o | o| o | | o |o C
7260 C \ |/k\| |/ \| / |/ \| |/ \| C
7261 C \i/ \ / \ / / \ / \ C
7263 C (I) (II) (III) (IV) C
7265 C eello5_1 eello5_2 eello5_3 eello5_4 C
7267 C Antiparallel chains C
7270 C /j\ / \ \ / \ / \ / C
7271 C / \ / \ \ / \ / \ / C
7272 C j1| o |l | o | o| o | | o |o C
7273 C \ |/k\| |/ \| / |/ \| |/ \| C
7274 C \i/ \ / \ / / \ / \ C
7276 C (I) (II) (III) (IV) C
7278 C eello5_1 eello5_2 eello5_3 eello5_4 C
7280 C o denotes a local interaction, vertical lines an electrostatic interaction. C
7282 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7283 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7288 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
7290 itk=itortyp(itype(k))
7291 itl=itortyp(itype(l))
7292 itj=itortyp(itype(j))
7297 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7298 cd & eel5_3_num,eel5_4_num)
7302 derx(lll,kkk,iii)=0.0d0
7306 cd eij=facont_hb(jj,i)
7307 cd ekl=facont_hb(kk,k)
7309 cd write (iout,*)'Contacts have occurred for peptide groups',
7310 cd & i,j,' fcont:',eij,' eij',' and ',k,l
7312 C Contribution from the graph I.
7313 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7314 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7315 call transpose2(EUg(1,1,k),auxmat(1,1))
7316 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7317 vv(1)=pizda(1,1)-pizda(2,2)
7318 vv(2)=pizda(1,2)+pizda(2,1)
7319 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7320 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7321 C Explicit gradient in virtual-dihedral angles.
7322 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7323 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7324 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7325 call transpose2(EUgder(1,1,k),auxmat1(1,1))
7326 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7327 vv(1)=pizda(1,1)-pizda(2,2)
7328 vv(2)=pizda(1,2)+pizda(2,1)
7329 g_corr5_loc(k-1)=g_corr5_loc(k-1)
7330 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7331 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7332 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7333 vv(1)=pizda(1,1)-pizda(2,2)
7334 vv(2)=pizda(1,2)+pizda(2,1)
7336 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7337 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7338 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7340 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7341 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7342 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7344 C Cartesian gradient
7348 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7350 vv(1)=pizda(1,1)-pizda(2,2)
7351 vv(2)=pizda(1,2)+pizda(2,1)
7352 derx(lll,kkk,iii)=derx(lll,kkk,iii)
7353 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7354 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7360 C Contribution from graph II
7361 call transpose2(EE(1,1,itk),auxmat(1,1))
7362 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7363 vv(1)=pizda(1,1)+pizda(2,2)
7364 vv(2)=pizda(2,1)-pizda(1,2)
7365 eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7366 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7367 C Explicit gradient in virtual-dihedral angles.
7368 g_corr5_loc(k-1)=g_corr5_loc(k-1)
7369 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7370 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7371 vv(1)=pizda(1,1)+pizda(2,2)
7372 vv(2)=pizda(2,1)-pizda(1,2)
7374 g_corr5_loc(l-1)=g_corr5_loc(l-1)
7375 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7376 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7378 g_corr5_loc(j-1)=g_corr5_loc(j-1)
7379 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7380 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7382 C Cartesian gradient
7386 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7388 vv(1)=pizda(1,1)+pizda(2,2)
7389 vv(2)=pizda(2,1)-pizda(1,2)
7390 derx(lll,kkk,iii)=derx(lll,kkk,iii)
7391 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7392 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7400 C Parallel orientation
7401 C Contribution from graph III
7402 call transpose2(EUg(1,1,l),auxmat(1,1))
7403 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7404 vv(1)=pizda(1,1)-pizda(2,2)
7405 vv(2)=pizda(1,2)+pizda(2,1)
7406 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7407 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7408 C Explicit gradient in virtual-dihedral angles.
7409 g_corr5_loc(j-1)=g_corr5_loc(j-1)
7410 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7411 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7412 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7413 vv(1)=pizda(1,1)-pizda(2,2)
7414 vv(2)=pizda(1,2)+pizda(2,1)
7415 g_corr5_loc(k-1)=g_corr5_loc(k-1)
7416 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7417 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7418 call transpose2(EUgder(1,1,l),auxmat1(1,1))
7419 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7420 vv(1)=pizda(1,1)-pizda(2,2)
7421 vv(2)=pizda(1,2)+pizda(2,1)
7422 g_corr5_loc(l-1)=g_corr5_loc(l-1)
7423 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7424 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7425 C Cartesian gradient
7429 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7431 vv(1)=pizda(1,1)-pizda(2,2)
7432 vv(2)=pizda(1,2)+pizda(2,1)
7433 derx(lll,kkk,iii)=derx(lll,kkk,iii)
7434 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7435 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7440 C Contribution from graph IV
7442 call transpose2(EE(1,1,itl),auxmat(1,1))
7443 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7444 vv(1)=pizda(1,1)+pizda(2,2)
7445 vv(2)=pizda(2,1)-pizda(1,2)
7446 eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7447 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
7448 C Explicit gradient in virtual-dihedral angles.
7449 g_corr5_loc(l-1)=g_corr5_loc(l-1)
7450 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7451 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7452 vv(1)=pizda(1,1)+pizda(2,2)
7453 vv(2)=pizda(2,1)-pizda(1,2)
7454 g_corr5_loc(k-1)=g_corr5_loc(k-1)
7455 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7456 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7457 C Cartesian gradient
7461 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7463 vv(1)=pizda(1,1)+pizda(2,2)
7464 vv(2)=pizda(2,1)-pizda(1,2)
7465 derx(lll,kkk,iii)=derx(lll,kkk,iii)
7466 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7467 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
7472 C Antiparallel orientation
7473 C Contribution from graph III
7475 call transpose2(EUg(1,1,j),auxmat(1,1))
7476 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7477 vv(1)=pizda(1,1)-pizda(2,2)
7478 vv(2)=pizda(1,2)+pizda(2,1)
7479 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7480 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7481 C Explicit gradient in virtual-dihedral angles.
7482 g_corr5_loc(l-1)=g_corr5_loc(l-1)
7483 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7484 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7485 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7486 vv(1)=pizda(1,1)-pizda(2,2)
7487 vv(2)=pizda(1,2)+pizda(2,1)
7488 g_corr5_loc(k-1)=g_corr5_loc(k-1)
7489 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7490 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7491 call transpose2(EUgder(1,1,j),auxmat1(1,1))
7492 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7493 vv(1)=pizda(1,1)-pizda(2,2)
7494 vv(2)=pizda(1,2)+pizda(2,1)
7495 g_corr5_loc(j-1)=g_corr5_loc(j-1)
7496 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7497 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7498 C Cartesian gradient
7502 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7504 vv(1)=pizda(1,1)-pizda(2,2)
7505 vv(2)=pizda(1,2)+pizda(2,1)
7506 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7507 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7508 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7513 C Contribution from graph IV
7515 call transpose2(EE(1,1,itj),auxmat(1,1))
7516 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7517 vv(1)=pizda(1,1)+pizda(2,2)
7518 vv(2)=pizda(2,1)-pizda(1,2)
7519 eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7520 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
7521 C Explicit gradient in virtual-dihedral angles.
7522 g_corr5_loc(j-1)=g_corr5_loc(j-1)
7523 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7524 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7525 vv(1)=pizda(1,1)+pizda(2,2)
7526 vv(2)=pizda(2,1)-pizda(1,2)
7527 g_corr5_loc(k-1)=g_corr5_loc(k-1)
7528 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7529 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7530 C Cartesian gradient
7534 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7536 vv(1)=pizda(1,1)+pizda(2,2)
7537 vv(2)=pizda(2,1)-pizda(1,2)
7538 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7539 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7540 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
7546 eel5=eello5_1+eello5_2+eello5_3+eello5_4
7547 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7548 cd write (2,*) 'ijkl',i,j,k,l
7549 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7550 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
7552 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7553 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7554 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7555 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7556 if (j.lt.nres-1) then
7563 if (l.lt.nres-1) then
7573 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7574 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7575 C summed up outside the subrouine as for the other subroutines
7576 C handling long-range interactions. The old code is commented out
7577 C with "cgrad" to keep track of changes.
7579 cgrad ggg1(ll)=eel5*g_contij(ll,1)
7580 cgrad ggg2(ll)=eel5*g_contij(ll,2)
7581 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7582 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7583 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7584 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7585 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7586 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7587 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7588 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7590 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7591 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7592 cgrad ghalf=0.5d0*ggg1(ll)
7594 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7595 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7596 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7597 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7598 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7599 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7600 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7601 cgrad ghalf=0.5d0*ggg2(ll)
7603 gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7604 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7605 gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7606 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7607 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7608 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7613 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7614 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7619 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7620 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7626 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7631 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7635 cd write (2,*) iii,g_corr5_loc(iii)
7638 cd write (2,*) 'ekont',ekont
7639 cd write (iout,*) 'eello5',ekont*eel5
7642 c--------------------------------------------------------------------------
7643 double precision function eello6(i,j,k,l,jj,kk)
7644 implicit real*8 (a-h,o-z)
7645 include 'DIMENSIONS'
7646 include 'COMMON.IOUNITS'
7647 include 'COMMON.CHAIN'
7648 include 'COMMON.DERIV'
7649 include 'COMMON.INTERACT'
7650 include 'COMMON.CONTACTS'
7651 include 'COMMON.TORSION'
7652 include 'COMMON.VAR'
7653 include 'COMMON.GEO'
7654 include 'COMMON.FFIELD'
7655 double precision ggg1(3),ggg2(3)
7656 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7661 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
7669 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7670 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7674 derx(lll,kkk,iii)=0.0d0
7678 cd eij=facont_hb(jj,i)
7679 cd ekl=facont_hb(kk,k)
7685 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7686 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7687 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7688 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7689 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7690 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7692 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7693 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7694 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7695 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7696 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7697 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7701 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7703 C If turn contributions are considered, they will be handled separately.
7704 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7705 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7706 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7707 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7708 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7709 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7710 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7712 if (j.lt.nres-1) then
7719 if (l.lt.nres-1) then
7727 cgrad ggg1(ll)=eel6*g_contij(ll,1)
7728 cgrad ggg2(ll)=eel6*g_contij(ll,2)
7729 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7730 cgrad ghalf=0.5d0*ggg1(ll)
7732 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7733 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7734 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7735 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7736 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7737 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7738 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7739 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7740 cgrad ghalf=0.5d0*ggg2(ll)
7741 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7743 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7744 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7745 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7746 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7747 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7748 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7753 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7754 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7759 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7760 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7766 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7771 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7775 cd write (2,*) iii,g_corr6_loc(iii)
7778 cd write (2,*) 'ekont',ekont
7779 cd write (iout,*) 'eello6',ekont*eel6
7782 c--------------------------------------------------------------------------
7783 double precision function eello6_graph1(i,j,k,l,imat,swap)
7784 implicit real*8 (a-h,o-z)
7785 include 'DIMENSIONS'
7786 include 'COMMON.IOUNITS'
7787 include 'COMMON.CHAIN'
7788 include 'COMMON.DERIV'
7789 include 'COMMON.INTERACT'
7790 include 'COMMON.CONTACTS'
7791 include 'COMMON.TORSION'
7792 include 'COMMON.VAR'
7793 include 'COMMON.GEO'
7794 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7798 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7800 C Parallel Antiparallel
7806 C \ j|/k\| / \ |/k\|l /
7811 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7812 itk=itortyp(itype(k))
7813 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7814 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7815 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7816 call transpose2(EUgC(1,1,k),auxmat(1,1))
7817 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7818 vv1(1)=pizda1(1,1)-pizda1(2,2)
7819 vv1(2)=pizda1(1,2)+pizda1(2,1)
7820 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7821 vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7822 vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7823 s5=scalar2(vv(1),Dtobr2(1,i))
7824 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7825 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7826 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7827 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7828 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7829 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7830 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7831 & +scalar2(vv(1),Dtobr2der(1,i)))
7832 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7833 vv1(1)=pizda1(1,1)-pizda1(2,2)
7834 vv1(2)=pizda1(1,2)+pizda1(2,1)
7835 vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7836 vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7838 g_corr6_loc(l-1)=g_corr6_loc(l-1)
7839 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7840 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7841 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7842 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7844 g_corr6_loc(j-1)=g_corr6_loc(j-1)
7845 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7846 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7847 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7848 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7850 call transpose2(EUgCder(1,1,k),auxmat(1,1))
7851 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7852 vv1(1)=pizda1(1,1)-pizda1(2,2)
7853 vv1(2)=pizda1(1,2)+pizda1(2,1)
7854 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7855 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7856 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7857 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7866 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7867 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7868 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7869 call transpose2(EUgC(1,1,k),auxmat(1,1))
7870 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7872 vv1(1)=pizda1(1,1)-pizda1(2,2)
7873 vv1(2)=pizda1(1,2)+pizda1(2,1)
7874 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7875 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7876 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7877 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7878 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7879 s5=scalar2(vv(1),Dtobr2(1,i))
7880 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7886 c----------------------------------------------------------------------------
7887 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7888 implicit real*8 (a-h,o-z)
7889 include 'DIMENSIONS'
7890 include 'COMMON.IOUNITS'
7891 include 'COMMON.CHAIN'
7892 include 'COMMON.DERIV'
7893 include 'COMMON.INTERACT'
7894 include 'COMMON.CONTACTS'
7895 include 'COMMON.TORSION'
7896 include 'COMMON.VAR'
7897 include 'COMMON.GEO'
7899 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7900 & auxvec1(2),auxvec2(1),auxmat1(2,2)
7903 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7905 C Parallel Antiparallel
7916 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7917 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7918 C AL 7/4/01 s1 would occur in the sixth-order moment,
7919 C but not in a cluster cumulant
7921 s1=dip(1,jj,i)*dip(1,kk,k)
7923 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7924 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7925 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7926 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7927 call transpose2(EUg(1,1,k),auxmat(1,1))
7928 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7929 vv(1)=pizda(1,1)-pizda(2,2)
7930 vv(2)=pizda(1,2)+pizda(2,1)
7931 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7932 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7934 eello6_graph2=-(s1+s2+s3+s4)
7936 eello6_graph2=-(s2+s3+s4)
7939 C Derivatives in gamma(i-1)
7942 s1=dipderg(1,jj,i)*dip(1,kk,k)
7944 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7945 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7946 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7947 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7949 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7951 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7953 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7955 C Derivatives in gamma(k-1)
7957 s1=dip(1,jj,i)*dipderg(1,kk,k)
7959 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7960 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7961 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7962 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7963 call transpose2(EUgder(1,1,k),auxmat1(1,1))
7964 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7965 vv(1)=pizda(1,1)-pizda(2,2)
7966 vv(2)=pizda(1,2)+pizda(2,1)
7967 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7969 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7971 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7973 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7974 C Derivatives in gamma(j-1) or gamma(l-1)
7977 s1=dipderg(3,jj,i)*dip(1,kk,k)
7979 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7980 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7981 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7982 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7983 vv(1)=pizda(1,1)-pizda(2,2)
7984 vv(2)=pizda(1,2)+pizda(2,1)
7985 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7988 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7990 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7993 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7994 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7996 C Derivatives in gamma(l-1) or gamma(j-1)
7999 s1=dip(1,jj,i)*dipderg(3,kk,k)
8001 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8002 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8003 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8004 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8005 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8006 vv(1)=pizda(1,1)-pizda(2,2)
8007 vv(2)=pizda(1,2)+pizda(2,1)
8008 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8011 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8013 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8016 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8017 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8019 C Cartesian derivatives.
8021 write (2,*) 'In eello6_graph2'
8023 write (2,*) 'iii=',iii
8025 write (2,*) 'kkk=',kkk
8027 write (2,'(3(2f10.5),5x)')
8028 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8038 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8040 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8043 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8045 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8046 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8048 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8049 call transpose2(EUg(1,1,k),auxmat(1,1))
8050 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8052 vv(1)=pizda(1,1)-pizda(2,2)
8053 vv(2)=pizda(1,2)+pizda(2,1)
8054 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8055 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8057 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8059 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8062 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8064 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8071 c----------------------------------------------------------------------------
8072 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8073 implicit real*8 (a-h,o-z)
8074 include 'DIMENSIONS'
8075 include 'COMMON.IOUNITS'
8076 include 'COMMON.CHAIN'
8077 include 'COMMON.DERIV'
8078 include 'COMMON.INTERACT'
8079 include 'COMMON.CONTACTS'
8080 include 'COMMON.TORSION'
8081 include 'COMMON.VAR'
8082 include 'COMMON.GEO'
8083 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8085 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8087 C Parallel Antiparallel
8098 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8100 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8101 C energy moment and not to the cluster cumulant.
8102 iti=itortyp(itype(i))
8103 if (j.lt.nres-1) then
8104 itj1=itortyp(itype(j+1))
8108 itk=itortyp(itype(k))
8109 itk1=itortyp(itype(k+1))
8110 if (l.lt.nres-1) then
8111 itl1=itortyp(itype(l+1))
8116 s1=dip(4,jj,i)*dip(4,kk,k)
8118 call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8119 s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8120 call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8121 s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8122 call transpose2(EE(1,1,itk),auxmat(1,1))
8123 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8124 vv(1)=pizda(1,1)+pizda(2,2)
8125 vv(2)=pizda(2,1)-pizda(1,2)
8126 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8127 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8128 cd & "sum",-(s2+s3+s4)
8130 eello6_graph3=-(s1+s2+s3+s4)
8132 eello6_graph3=-(s2+s3+s4)
8135 C Derivatives in gamma(k-1)
8136 call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8137 s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8138 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8139 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8140 C Derivatives in gamma(l-1)
8141 call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8142 s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8143 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8144 vv(1)=pizda(1,1)+pizda(2,2)
8145 vv(2)=pizda(2,1)-pizda(1,2)
8146 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8147 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8148 C Cartesian derivatives.
8154 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8156 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8159 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8161 s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8162 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8164 s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8165 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8167 vv(1)=pizda(1,1)+pizda(2,2)
8168 vv(2)=pizda(2,1)-pizda(1,2)
8169 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8171 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8173 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8176 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8178 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8180 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8186 c----------------------------------------------------------------------------
8187 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8188 implicit real*8 (a-h,o-z)
8189 include 'DIMENSIONS'
8190 include 'COMMON.IOUNITS'
8191 include 'COMMON.CHAIN'
8192 include 'COMMON.DERIV'
8193 include 'COMMON.INTERACT'
8194 include 'COMMON.CONTACTS'
8195 include 'COMMON.TORSION'
8196 include 'COMMON.VAR'
8197 include 'COMMON.GEO'
8198 include 'COMMON.FFIELD'
8199 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8200 & auxvec1(2),auxmat1(2,2)
8202 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8204 C Parallel Antiparallel
8215 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8217 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8218 C energy moment and not to the cluster cumulant.
8219 cd write (2,*) 'eello_graph4: wturn6',wturn6
8220 iti=itortyp(itype(i))
8221 itj=itortyp(itype(j))
8222 if (j.lt.nres-1) then
8223 itj1=itortyp(itype(j+1))
8227 itk=itortyp(itype(k))
8228 if (k.lt.nres-1) then
8229 itk1=itortyp(itype(k+1))
8233 itl=itortyp(itype(l))
8234 if (l.lt.nres-1) then
8235 itl1=itortyp(itype(l+1))
8239 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8240 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8241 cd & ' itl',itl,' itl1',itl1
8244 s1=dip(3,jj,i)*dip(3,kk,k)
8246 s1=dip(2,jj,j)*dip(2,kk,l)
8249 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8250 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8252 call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8253 s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8255 call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8256 s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8258 call transpose2(EUg(1,1,k),auxmat(1,1))
8259 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8260 vv(1)=pizda(1,1)-pizda(2,2)
8261 vv(2)=pizda(2,1)+pizda(1,2)
8262 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8263 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8265 eello6_graph4=-(s1+s2+s3+s4)
8267 eello6_graph4=-(s2+s3+s4)
8269 C Derivatives in gamma(i-1)
8273 s1=dipderg(2,jj,i)*dip(3,kk,k)
8275 s1=dipderg(4,jj,j)*dip(2,kk,l)
8278 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8280 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8281 s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8283 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8284 s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8286 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8287 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8288 cd write (2,*) 'turn6 derivatives'
8290 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8292 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8296 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8298 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8302 C Derivatives in gamma(k-1)
8305 s1=dip(3,jj,i)*dipderg(2,kk,k)
8307 s1=dip(2,jj,j)*dipderg(4,kk,l)
8310 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8311 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8313 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8314 s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8316 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8317 s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8319 call transpose2(EUgder(1,1,k),auxmat1(1,1))
8320 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8321 vv(1)=pizda(1,1)-pizda(2,2)
8322 vv(2)=pizda(2,1)+pizda(1,2)
8323 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8324 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8326 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8328 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8332 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8334 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8337 C Derivatives in gamma(j-1) or gamma(l-1)
8338 if (l.eq.j+1 .and. l.gt.1) then
8339 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8340 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8341 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8342 vv(1)=pizda(1,1)-pizda(2,2)
8343 vv(2)=pizda(2,1)+pizda(1,2)
8344 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8345 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8346 else if (j.gt.1) then
8347 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8348 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8349 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8350 vv(1)=pizda(1,1)-pizda(2,2)
8351 vv(2)=pizda(2,1)+pizda(1,2)
8352 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8353 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8354 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8356 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8359 C Cartesian derivatives.
8366 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8368 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8372 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8374 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8378 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8380 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8382 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8383 & b1(1,itj1),auxvec(1))
8384 s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8386 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8387 & b1(1,itl1),auxvec(1))
8388 s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8390 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8392 vv(1)=pizda(1,1)-pizda(2,2)
8393 vv(2)=pizda(2,1)+pizda(1,2)
8394 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8396 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8398 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8401 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8404 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8407 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8409 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8411 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8415 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8417 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8420 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8422 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8430 c----------------------------------------------------------------------------
8431 double precision function eello_turn6(i,jj,kk)
8432 implicit real*8 (a-h,o-z)
8433 include 'DIMENSIONS'
8434 include 'COMMON.IOUNITS'
8435 include 'COMMON.CHAIN'
8436 include 'COMMON.DERIV'
8437 include 'COMMON.INTERACT'
8438 include 'COMMON.CONTACTS'
8439 include 'COMMON.TORSION'
8440 include 'COMMON.VAR'
8441 include 'COMMON.GEO'
8442 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8443 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8445 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8446 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8447 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8448 C the respective energy moment and not to the cluster cumulant.
8457 iti=itortyp(itype(i))
8458 itk=itortyp(itype(k))
8459 itk1=itortyp(itype(k+1))
8460 itl=itortyp(itype(l))
8461 itj=itortyp(itype(j))
8462 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8463 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
8464 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8469 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
8471 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
8475 derx_turn(lll,kkk,iii)=0.0d0
8482 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8484 cd write (2,*) 'eello6_5',eello6_5
8486 call transpose2(AEA(1,1,1),auxmat(1,1))
8487 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8488 ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8489 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8491 call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8492 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8493 s2 = scalar2(b1(1,itk),vtemp1(1))
8495 call transpose2(AEA(1,1,2),atemp(1,1))
8496 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8497 call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8498 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8500 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8501 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8502 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8504 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8505 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8506 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8507 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8508 ss13 = scalar2(b1(1,itk),vtemp4(1))
8509 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8511 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8517 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8518 C Derivatives in gamma(i+2)
8522 call transpose2(AEA(1,1,1),auxmatd(1,1))
8523 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8524 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8525 call transpose2(AEAderg(1,1,2),atempd(1,1))
8526 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8527 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8529 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8530 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8531 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8537 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8538 C Derivatives in gamma(i+3)
8540 call transpose2(AEA(1,1,1),auxmatd(1,1))
8541 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8542 ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8543 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8545 call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8546 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8547 s2d = scalar2(b1(1,itk),vtemp1d(1))
8549 call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8550 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8552 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8554 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8555 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8556 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8564 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8565 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8567 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8568 & -0.5d0*ekont*(s2d+s12d)
8570 C Derivatives in gamma(i+4)
8571 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8572 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8573 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8575 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8576 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8577 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8585 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8587 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8589 C Derivatives in gamma(i+5)
8591 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8592 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8593 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8595 call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8596 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8597 s2d = scalar2(b1(1,itk),vtemp1d(1))
8599 call transpose2(AEA(1,1,2),atempd(1,1))
8600 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8601 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8603 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8604 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8606 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8607 ss13d = scalar2(b1(1,itk),vtemp4d(1))
8608 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8616 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8617 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8619 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8620 & -0.5d0*ekont*(s2d+s12d)
8622 C Cartesian derivatives
8627 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8628 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8629 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8631 call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8632 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8634 s2d = scalar2(b1(1,itk),vtemp1d(1))
8636 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8637 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8638 s8d = -(atempd(1,1)+atempd(2,2))*
8639 & scalar2(cc(1,1,itl),vtemp2(1))
8641 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8643 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8644 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8651 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8654 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8658 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8659 & - 0.5d0*(s8d+s12d)
8661 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8670 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8672 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8673 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8674 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8675 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8676 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8678 ss13d = scalar2(b1(1,itk),vtemp4d(1))
8679 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8680 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8684 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8685 cd & 16*eel_turn6_num
8687 if (j.lt.nres-1) then
8694 if (l.lt.nres-1) then
8702 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
8703 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
8704 cgrad ghalf=0.5d0*ggg1(ll)
8706 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8707 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8708 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8709 & +ekont*derx_turn(ll,2,1)
8710 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8711 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8712 & +ekont*derx_turn(ll,4,1)
8713 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8714 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8715 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8716 cgrad ghalf=0.5d0*ggg2(ll)
8718 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8719 & +ekont*derx_turn(ll,2,2)
8720 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8721 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8722 & +ekont*derx_turn(ll,4,2)
8723 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8724 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8725 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8730 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8735 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8741 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8746 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8750 cd write (2,*) iii,g_corr6_loc(iii)
8752 eello_turn6=ekont*eel_turn6
8753 cd write (2,*) 'ekont',ekont
8754 cd write (2,*) 'eel_turn6',ekont*eel_turn6
8758 C-----------------------------------------------------------------------------
8759 double precision function scalar(u,v)
8760 !DIR$ INLINEALWAYS scalar
8762 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8765 double precision u(3),v(3)
8766 cd double precision sc
8774 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8777 crc-------------------------------------------------
8778 SUBROUTINE MATVEC2(A1,V1,V2)
8779 !DIR$ INLINEALWAYS MATVEC2
8781 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8783 implicit real*8 (a-h,o-z)
8784 include 'DIMENSIONS'
8785 DIMENSION A1(2,2),V1(2),V2(2)
8789 c 3 VI=VI+A1(I,K)*V1(K)
8793 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8794 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8799 C---------------------------------------
8800 SUBROUTINE MATMAT2(A1,A2,A3)
8802 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8804 implicit real*8 (a-h,o-z)
8805 include 'DIMENSIONS'
8806 DIMENSION A1(2,2),A2(2,2),A3(2,2)
8807 c DIMENSION AI3(2,2)
8811 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
8817 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8818 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8819 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8820 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8828 c-------------------------------------------------------------------------
8829 double precision function scalar2(u,v)
8830 !DIR$ INLINEALWAYS scalar2
8832 double precision u(2),v(2)
8835 scalar2=u(1)*v(1)+u(2)*v(2)
8839 C-----------------------------------------------------------------------------
8841 subroutine transpose2(a,at)
8842 !DIR$ INLINEALWAYS transpose2
8844 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8847 double precision a(2,2),at(2,2)
8854 c--------------------------------------------------------------------------
8855 subroutine transpose(n,a,at)
8858 double precision a(n,n),at(n,n)
8866 C---------------------------------------------------------------------------
8867 subroutine prodmat3(a1,a2,kk,transp,prod)
8868 !DIR$ INLINEALWAYS prodmat3
8870 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8874 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8876 crc double precision auxmat(2,2),prod_(2,2)
8879 crc call transpose2(kk(1,1),auxmat(1,1))
8880 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8881 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8883 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8884 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8885 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8886 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8887 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8888 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8889 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8890 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8893 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8894 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8896 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8897 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8898 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8899 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8900 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8901 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8902 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8903 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8906 c call transpose2(a2(1,1),a2t(1,1))
8909 crc print *,((prod_(i,j),i=1,2),j=1,2)
8910 crc print *,((prod(i,j),i=1,2),j=1,2)