1 subroutine etotal(energia)
2 implicit real*8 (a-h,o-z)
7 cMS$ATTRIBUTES C :: proc_proc
12 double precision weights_(n_ene)
14 include 'COMMON.SETUP'
15 include 'COMMON.IOUNITS'
16 double precision energia(0:n_ene)
17 include 'COMMON.LOCAL'
18 include 'COMMON.FFIELD'
19 include 'COMMON.DERIV'
20 include 'COMMON.INTERACT'
21 include 'COMMON.SBRIDGE'
22 include 'COMMON.CHAIN'
25 include 'COMMON.CONTROL'
26 include 'COMMON.TIME1'
27 include 'COMMON.SPLITELE'
29 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
30 c & " nfgtasks",nfgtasks
31 if (nfgtasks.gt.1) then
33 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
34 if (fg_rank.eq.0) then
35 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
36 c print *,"Processor",myrank," BROADCAST iorder"
37 C FG master sets up the WEIGHTS_ array which will be broadcast to the
38 C FG slaves as WEIGHTS array.
58 C FG Master broadcasts the WEIGHTS_ array
59 call MPI_Bcast(weights_(1),n_ene,
60 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
62 C FG slaves receive the WEIGHTS array
63 call MPI_Bcast(weights(1),n_ene,
64 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
85 time_Bcast=time_Bcast+MPI_Wtime()-time00
86 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
87 c call chainbuild_cart
89 c print *,'Processor',myrank,' calling etotal ipot=',ipot
90 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
92 c if (modecalc.eq.12.or.modecalc.eq.14) then
93 c call int_from_cart1(.false.)
100 C Compute the side-chain and electrostatic interaction energy
102 goto (101,102,103,104,105,106) ipot
103 C Lennard-Jones potential.
105 cd print '(a)','Exit ELJ'
107 C Lennard-Jones-Kihara potential (shifted).
110 C Berne-Pechukas potential (dilated LJ, angular dependence).
113 C Gay-Berne potential (shifted LJ, angular dependence).
116 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
119 C Soft-sphere potential
120 106 call e_softsphere(evdw)
122 C Calculate electrostatic (H-bonding) energy of the main chain.
125 c print *,"Processor",myrank," computed USCSC"
131 time_vec=time_vec+MPI_Wtime()-time01
133 c print *,"Processor",myrank," left VEC_AND_DERIV"
136 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
137 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
138 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
139 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
141 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
142 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
143 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
144 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
146 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
155 c write (iout,*) "Soft-spheer ELEC potential"
156 call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
159 c print *,"Processor",myrank," computed UELEC"
161 C Calculate excluded-volume interaction energy between peptide groups
166 call escp(evdw2,evdw2_14)
172 c write (iout,*) "Soft-sphere SCP potential"
173 call escp_soft_sphere(evdw2,evdw2_14)
176 c Calculate the bond-stretching energy
180 C Calculate the disulfide-bridge and other energy and the contributions
181 C from other distance constraints.
182 cd print *,'Calling EHPB'
184 cd print *,'EHPB exitted succesfully.'
186 C Calculate the virtual-bond-angle energy.
188 if (wang.gt.0d0) then
193 c print *,"Processor",myrank," computed UB"
195 C Calculate the SC local energy.
198 c print *,"Processor",myrank," computed USC"
200 C Calculate the virtual-bond torsional energy.
202 cd print *,'nterm=',nterm
204 call etor(etors,edihcnstr)
209 c print *,"Processor",myrank," computed Utor"
211 C 6/23/01 Calculate double-torsional energy
213 if (wtor_d.gt.0) then
218 c print *,"Processor",myrank," computed Utord"
220 C 21/5/07 Calculate local sicdechain correlation energy
222 if (wsccor.gt.0.0d0) then
223 call eback_sc_corr(esccor)
227 c print *,"Processor",myrank," computed Usccorr"
229 C 12/1/95 Multi-body terms
233 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
234 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
235 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
236 cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
237 cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
244 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
245 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
246 cd write (iout,*) "multibody_hb ecorr",ecorr
248 c print *,"Processor",myrank," computed Ucorr"
250 C If performing constraint dynamics, call the constraint energy
251 C after the equilibration time
252 if(usampl.and.totT.gt.eq_time) then
260 time_enecalc=time_enecalc+MPI_Wtime()-time00
262 c print *,"Processor",myrank," computed Uconstr"
271 energia(2)=evdw2-evdw2_14
288 energia(8)=eello_turn3
289 energia(9)=eello_turn4
296 energia(19)=edihcnstr
298 energia(20)=Uconst+Uconst_back
300 c Here are the energies showed per procesor if the are more processors
301 c per molecule then we sum it up in sum_energy subroutine
302 c print *," Processor",myrank," calls SUM_ENERGY"
303 call sum_energy(energia,.true.)
304 c print *," Processor",myrank," left SUM_ENERGY"
306 time_sumene=time_sumene+MPI_Wtime()-time00
310 c-------------------------------------------------------------------------------
311 subroutine sum_energy(energia,reduce)
312 implicit real*8 (a-h,o-z)
317 cMS$ATTRIBUTES C :: proc_proc
323 include 'COMMON.SETUP'
324 include 'COMMON.IOUNITS'
325 double precision energia(0:n_ene),enebuff(0:n_ene+1)
326 include 'COMMON.FFIELD'
327 include 'COMMON.DERIV'
328 include 'COMMON.INTERACT'
329 include 'COMMON.SBRIDGE'
330 include 'COMMON.CHAIN'
332 include 'COMMON.CONTROL'
333 include 'COMMON.TIME1'
336 if (nfgtasks.gt.1 .and. reduce) then
338 write (iout,*) "energies before REDUCE"
339 call enerprint(energia)
343 enebuff(i)=energia(i)
346 call MPI_Barrier(FG_COMM,IERR)
347 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
349 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
350 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
352 write (iout,*) "energies after REDUCE"
353 call enerprint(energia)
356 time_Reduce=time_Reduce+MPI_Wtime()-time00
358 if (fg_rank.eq.0) then
362 evdw2=energia(2)+energia(18)
378 eello_turn3=energia(8)
379 eello_turn4=energia(9)
386 edihcnstr=energia(19)
391 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
392 & +wang*ebe+wtor*etors+wscloc*escloc
393 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
394 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
395 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
396 & +wbond*estr+Uconst+wsccor*esccor
398 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
399 & +wang*ebe+wtor*etors+wscloc*escloc
400 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
401 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
402 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
403 & +wbond*estr+Uconst+wsccor*esccor
409 if (isnan(etot).ne.0) energia(0)=1.0d+99
411 if (isnan(etot)) energia(0)=1.0d+99
416 idumm=proc_proc(etot,i)
418 call proc_proc(etot,i)
420 if(i.eq.1)energia(0)=1.0d+99
427 c-------------------------------------------------------------------------------
428 subroutine sum_gradient
429 implicit real*8 (a-h,o-z)
434 cMS$ATTRIBUTES C :: proc_proc
439 double precision gradbufc(3,maxres),gradbufx(3,maxres),
440 & glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
442 include 'COMMON.SETUP'
443 include 'COMMON.IOUNITS'
444 include 'COMMON.FFIELD'
445 include 'COMMON.DERIV'
446 include 'COMMON.INTERACT'
447 include 'COMMON.SBRIDGE'
448 include 'COMMON.CHAIN'
450 include 'COMMON.CONTROL'
451 include 'COMMON.TIME1'
452 include 'COMMON.MAXGRAD'
453 include 'COMMON.SCCOR'
458 write (iout,*) "sum_gradient gvdwc, gvdwx"
460 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
461 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
466 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
467 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
468 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
471 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
472 C in virtual-bond-vector coordinates
475 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
477 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
478 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
480 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
482 c write (iout,'(i5,3f10.5,2x,f10.5)')
483 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
485 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
487 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
488 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
496 gradbufc(j,i)=wsc*gvdwc(j,i)+
497 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
498 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
499 & wel_loc*gel_loc_long(j,i)+
500 & wcorr*gradcorr_long(j,i)+
501 & wcorr5*gradcorr5_long(j,i)+
502 & wcorr6*gradcorr6_long(j,i)+
503 & wturn6*gcorr6_turn_long(j,i)+
510 gradbufc(j,i)=wsc*gvdwc(j,i)+
511 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
512 & welec*gelc_long(j,i)+
514 & wel_loc*gel_loc_long(j,i)+
515 & wcorr*gradcorr_long(j,i)+
516 & wcorr5*gradcorr5_long(j,i)+
517 & wcorr6*gradcorr6_long(j,i)+
518 & wturn6*gcorr6_turn_long(j,i)+
524 if (nfgtasks.gt.1) then
527 write (iout,*) "gradbufc before allreduce"
529 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
535 gradbufc_sum(j,i)=gradbufc(j,i)
538 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
539 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
540 c time_reduce=time_reduce+MPI_Wtime()-time00
542 c write (iout,*) "gradbufc_sum after allreduce"
544 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
549 c time_allreduce=time_allreduce+MPI_Wtime()-time00
557 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
558 write (iout,*) (i," jgrad_start",jgrad_start(i),
559 & " jgrad_end ",jgrad_end(i),
560 & i=igrad_start,igrad_end)
563 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
564 c do not parallelize this part.
566 c do i=igrad_start,igrad_end
567 c do j=jgrad_start(i),jgrad_end(i)
569 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
574 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
578 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
582 write (iout,*) "gradbufc after summing"
584 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
591 write (iout,*) "gradbufc"
593 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
599 gradbufc_sum(j,i)=gradbufc(j,i)
604 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
608 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
613 c gradbufc(k,i)=0.0d0
617 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
622 write (iout,*) "gradbufc after summing"
624 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
632 gradbufc(k,nres)=0.0d0
637 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
638 & wel_loc*gel_loc(j,i)+
639 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
640 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
641 & wel_loc*gel_loc_long(j,i)+
642 & wcorr*gradcorr_long(j,i)+
643 & wcorr5*gradcorr5_long(j,i)+
644 & wcorr6*gradcorr6_long(j,i)+
645 & wturn6*gcorr6_turn_long(j,i))+
647 & wcorr*gradcorr(j,i)+
648 & wturn3*gcorr3_turn(j,i)+
649 & wturn4*gcorr4_turn(j,i)+
650 & wcorr5*gradcorr5(j,i)+
651 & wcorr6*gradcorr6(j,i)+
652 & wturn6*gcorr6_turn(j,i)+
653 & wsccor*gsccorc(j,i)
654 & +wscloc*gscloc(j,i)
656 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
657 & wel_loc*gel_loc(j,i)+
658 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
659 & welec*gelc_long(j,i)
660 & wel_loc*gel_loc_long(j,i)+
661 & wcorr*gcorr_long(j,i)+
662 & wcorr5*gradcorr5_long(j,i)+
663 & wcorr6*gradcorr6_long(j,i)+
664 & wturn6*gcorr6_turn_long(j,i))+
666 & wcorr*gradcorr(j,i)+
667 & wturn3*gcorr3_turn(j,i)+
668 & wturn4*gcorr4_turn(j,i)+
669 & wcorr5*gradcorr5(j,i)+
670 & wcorr6*gradcorr6(j,i)+
671 & wturn6*gcorr6_turn(j,i)+
672 & wsccor*gsccorc(j,i)
673 & +wscloc*gscloc(j,i)
675 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
677 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
678 & wsccor*gsccorx(j,i)
679 & +wscloc*gsclocx(j,i)
683 write (iout,*) "gloc before adding corr"
685 write (iout,*) i,gloc(i,icg)
689 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
690 & +wcorr5*g_corr5_loc(i)
691 & +wcorr6*g_corr6_loc(i)
692 & +wturn4*gel_loc_turn4(i)
693 & +wturn3*gel_loc_turn3(i)
694 & +wturn6*gel_loc_turn6(i)
695 & +wel_loc*gel_loc_loc(i)
698 write (iout,*) "gloc after adding corr"
700 write (iout,*) i,gloc(i,icg)
704 if (nfgtasks.gt.1) then
707 gradbufc(j,i)=gradc(j,i,icg)
708 gradbufx(j,i)=gradx(j,i,icg)
712 glocbuf(i)=gloc(i,icg)
716 write (iout,*) "gloc_sc before reduce"
719 write (iout,*) i,j,gloc_sc(j,i,icg)
726 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
730 call MPI_Barrier(FG_COMM,IERR)
731 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
733 call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
734 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
735 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
736 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
737 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
738 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
739 time_reduce=time_reduce+MPI_Wtime()-time00
740 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
741 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
742 time_reduce=time_reduce+MPI_Wtime()-time00
745 write (iout,*) "gloc_sc after reduce"
748 write (iout,*) i,j,gloc_sc(j,i,icg)
754 write (iout,*) "gloc after reduce"
756 write (iout,*) i,gloc(i,icg)
761 if (gnorm_check) then
763 c Compute the maximum elements of the gradient
773 gcorr3_turn_max=0.0d0
774 gcorr4_turn_max=0.0d0
777 gcorr6_turn_max=0.0d0
787 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
788 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
789 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
790 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
791 & gvdwc_scp_max=gvdwc_scp_norm
792 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
793 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
794 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
795 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
796 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
797 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
798 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
799 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
800 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
801 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
802 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
803 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
804 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
806 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
807 & gcorr3_turn_max=gcorr3_turn_norm
808 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
810 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
811 & gcorr4_turn_max=gcorr4_turn_norm
812 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
813 if (gradcorr5_norm.gt.gradcorr5_max)
814 & gradcorr5_max=gradcorr5_norm
815 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
816 if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
817 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
819 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
820 & gcorr6_turn_max=gcorr6_turn_norm
821 gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
822 if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
823 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
824 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
825 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
826 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
827 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
828 if (gradx_scp_norm.gt.gradx_scp_max)
829 & gradx_scp_max=gradx_scp_norm
830 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
831 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
832 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
833 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
834 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
835 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
836 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
837 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
841 open(istat,file=statname,position="append")
843 open(istat,file=statname,access="append")
845 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
846 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
847 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
848 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
849 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
850 & gsccorx_max,gsclocx_max
852 if (gvdwc_max.gt.1.0d4) then
853 write (iout,*) "gvdwc gvdwx gradb gradbx"
855 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
856 & gradb(j,i),gradbx(j,i),j=1,3)
858 call pdbout(0.0d0,'cipiszcze',iout)
864 write (iout,*) "gradc gradx gloc"
866 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
867 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
871 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
875 c-------------------------------------------------------------------------------
876 subroutine rescale_weights(t_bath)
877 implicit real*8 (a-h,o-z)
879 include 'COMMON.IOUNITS'
880 include 'COMMON.FFIELD'
881 include 'COMMON.SBRIDGE'
882 double precision kfac /2.4d0/
883 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
885 c facT=2*temp0/(t_bath+temp0)
886 if (rescale_mode.eq.0) then
892 else if (rescale_mode.eq.1) then
893 facT=kfac/(kfac-1.0d0+t_bath/temp0)
894 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
895 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
896 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
897 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
898 else if (rescale_mode.eq.2) then
904 facT=licznik/dlog(dexp(x)+dexp(-x))
905 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
906 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
907 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
908 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
910 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
911 write (*,*) "Wrong RESCALE_MODE",rescale_mode
913 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
917 welec=weights(3)*fact
918 wcorr=weights(4)*fact3
919 wcorr5=weights(5)*fact4
920 wcorr6=weights(6)*fact5
921 wel_loc=weights(7)*fact2
922 wturn3=weights(8)*fact2
923 wturn4=weights(9)*fact3
924 wturn6=weights(10)*fact5
925 wtor=weights(13)*fact
926 wtor_d=weights(14)*fact2
927 wsccor=weights(21)*fact
931 C------------------------------------------------------------------------
932 subroutine enerprint(energia)
933 implicit real*8 (a-h,o-z)
935 include 'COMMON.IOUNITS'
936 include 'COMMON.FFIELD'
937 include 'COMMON.SBRIDGE'
939 double precision energia(0:n_ene)
944 evdw2=energia(2)+energia(18)
956 eello_turn3=energia(8)
957 eello_turn4=energia(9)
958 eello_turn6=energia(10)
964 edihcnstr=energia(19)
969 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
970 & estr,wbond,ebe,wang,
971 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
973 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
974 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
977 10 format (/'Virtual-chain energies:'//
978 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
979 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
980 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
981 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
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)')
1002 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1003 & estr,wbond,ebe,wang,
1004 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1006 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1007 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1008 & ebr*nss,Uconst,etot
1009 10 format (/'Virtual-chain energies:'//
1010 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1011 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1012 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1013 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1014 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1015 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1016 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1017 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1018 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
1019 & ' (SS bridges & dist. cnstr.)'/
1020 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1021 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1022 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1023 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1024 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1025 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1026 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1027 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1028 & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1029 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1030 & 'UCONST=',1pE16.6,' (Constraint energy)'/
1031 & 'ETOT= ',1pE16.6,' (total)')
1035 C-----------------------------------------------------------------------
1036 subroutine elj(evdw)
1038 C This subroutine calculates the interaction energy of nonbonded side chains
1039 C assuming the LJ potential of interaction.
1041 implicit real*8 (a-h,o-z)
1042 include 'DIMENSIONS'
1043 parameter (accur=1.0d-10)
1044 include 'COMMON.GEO'
1045 include 'COMMON.VAR'
1046 include 'COMMON.LOCAL'
1047 include 'COMMON.CHAIN'
1048 include 'COMMON.DERIV'
1049 include 'COMMON.INTERACT'
1050 include 'COMMON.TORSION'
1051 include 'COMMON.SBRIDGE'
1052 include 'COMMON.NAMES'
1053 include 'COMMON.IOUNITS'
1054 include 'COMMON.CONTACTS'
1056 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1058 do i=iatsc_s,iatsc_e
1059 itypi=iabs(itype(i))
1060 if (itypi.eq.ntyp1) cycle
1061 itypi1=iabs(itype(i+1))
1068 C Calculate SC interaction energy.
1070 do iint=1,nint_gr(i)
1071 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1072 cd & 'iend=',iend(i,iint)
1073 do j=istart(i,iint),iend(i,iint)
1074 itypj=iabs(itype(j))
1075 if (itypj.eq.ntyp1) cycle
1079 C Change 12/1/95 to calculate four-body interactions
1080 rij=xj*xj+yj*yj+zj*zj
1082 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1083 eps0ij=eps(itypi,itypj)
1085 e1=fac*fac*aa(itypi,itypj)
1086 e2=fac*bb(itypi,itypj)
1088 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1089 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1090 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1091 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1092 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1093 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1096 C Calculate the components of the gradient in DC and X
1098 fac=-rrij*(e1+evdwij)
1103 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1104 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1105 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1106 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1110 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1114 C 12/1/95, revised on 5/20/97
1116 C Calculate the contact function. The ith column of the array JCONT will
1117 C contain the numbers of atoms that make contacts with the atom I (of numbers
1118 C greater than I). The arrays FACONT and GACONT will contain the values of
1119 C the contact function and its derivative.
1121 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1122 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1123 C Uncomment next line, if the correlation interactions are contact function only
1124 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1126 sigij=sigma(itypi,itypj)
1127 r0ij=rs0(itypi,itypj)
1129 C Check whether the SC's are not too far to make a contact.
1132 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1133 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1135 if (fcont.gt.0.0D0) then
1136 C If the SC-SC distance if close to sigma, apply spline.
1137 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1138 cAdam & fcont1,fprimcont1)
1139 cAdam fcont1=1.0d0-fcont1
1140 cAdam if (fcont1.gt.0.0d0) then
1141 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1142 cAdam fcont=fcont*fcont1
1144 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1145 cga eps0ij=1.0d0/dsqrt(eps0ij)
1147 cga gg(k)=gg(k)*eps0ij
1149 cga eps0ij=-evdwij*eps0ij
1150 C Uncomment for AL's type of SC correlation interactions.
1151 cadam eps0ij=-evdwij
1152 num_conti=num_conti+1
1153 jcont(num_conti,i)=j
1154 facont(num_conti,i)=fcont*eps0ij
1155 fprimcont=eps0ij*fprimcont/rij
1157 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1158 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1159 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1160 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1161 gacont(1,num_conti,i)=-fprimcont*xj
1162 gacont(2,num_conti,i)=-fprimcont*yj
1163 gacont(3,num_conti,i)=-fprimcont*zj
1164 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1165 cd write (iout,'(2i3,3f10.5)')
1166 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1172 num_cont(i)=num_conti
1176 gvdwc(j,i)=expon*gvdwc(j,i)
1177 gvdwx(j,i)=expon*gvdwx(j,i)
1180 C******************************************************************************
1184 C To save time, the factor of EXPON has been extracted from ALL components
1185 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1188 C******************************************************************************
1191 C-----------------------------------------------------------------------------
1192 subroutine eljk(evdw)
1194 C This subroutine calculates the interaction energy of nonbonded side chains
1195 C assuming the LJK potential of interaction.
1197 implicit real*8 (a-h,o-z)
1198 include 'DIMENSIONS'
1199 include 'COMMON.GEO'
1200 include 'COMMON.VAR'
1201 include 'COMMON.LOCAL'
1202 include 'COMMON.CHAIN'
1203 include 'COMMON.DERIV'
1204 include 'COMMON.INTERACT'
1205 include 'COMMON.IOUNITS'
1206 include 'COMMON.NAMES'
1209 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1211 do i=iatsc_s,iatsc_e
1212 itypi=iabs(itype(i))
1213 if (itypi.eq.ntyp1) cycle
1214 itypi1=iabs(itype(i+1))
1219 C Calculate SC interaction energy.
1221 do iint=1,nint_gr(i)
1222 do j=istart(i,iint),iend(i,iint)
1223 itypj=iabs(itype(j))
1224 if (itypj.eq.ntyp1) cycle
1228 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1229 fac_augm=rrij**expon
1230 e_augm=augm(itypi,itypj)*fac_augm
1231 r_inv_ij=dsqrt(rrij)
1233 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1234 fac=r_shift_inv**expon
1235 e1=fac*fac*aa(itypi,itypj)
1236 e2=fac*bb(itypi,itypj)
1238 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1239 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1240 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1241 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1242 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1243 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1244 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1247 C Calculate the components of the gradient in DC and X
1249 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1254 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1255 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1256 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1257 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1261 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1269 gvdwc(j,i)=expon*gvdwc(j,i)
1270 gvdwx(j,i)=expon*gvdwx(j,i)
1275 C-----------------------------------------------------------------------------
1276 subroutine ebp(evdw)
1278 C This subroutine calculates the interaction energy of nonbonded side chains
1279 C assuming the Berne-Pechukas potential of interaction.
1281 implicit real*8 (a-h,o-z)
1282 include 'DIMENSIONS'
1283 include 'COMMON.GEO'
1284 include 'COMMON.VAR'
1285 include 'COMMON.LOCAL'
1286 include 'COMMON.CHAIN'
1287 include 'COMMON.DERIV'
1288 include 'COMMON.NAMES'
1289 include 'COMMON.INTERACT'
1290 include 'COMMON.IOUNITS'
1291 include 'COMMON.CALC'
1292 common /srutu/ icall
1293 c double precision rrsave(maxdim)
1296 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1298 c if (icall.eq.0) then
1304 do i=iatsc_s,iatsc_e
1305 itypi=iabs(itype(i))
1306 if (itypi.eq.ntyp1) cycle
1307 itypi1=iabs(itype(i+1))
1311 dxi=dc_norm(1,nres+i)
1312 dyi=dc_norm(2,nres+i)
1313 dzi=dc_norm(3,nres+i)
1314 c dsci_inv=dsc_inv(itypi)
1315 dsci_inv=vbld_inv(i+nres)
1317 C Calculate SC interaction energy.
1319 do iint=1,nint_gr(i)
1320 do j=istart(i,iint),iend(i,iint)
1322 itypj=iabs(itype(j))
1323 if (itypj.eq.ntyp1) cycle
1324 c dscj_inv=dsc_inv(itypj)
1325 dscj_inv=vbld_inv(j+nres)
1326 chi1=chi(itypi,itypj)
1327 chi2=chi(itypj,itypi)
1334 alf12=0.5D0*(alf1+alf2)
1335 C For diagnostics only!!!
1348 dxj=dc_norm(1,nres+j)
1349 dyj=dc_norm(2,nres+j)
1350 dzj=dc_norm(3,nres+j)
1351 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1352 cd if (icall.eq.0) then
1358 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1360 C Calculate whole angle-dependent part of epsilon and contributions
1361 C to its derivatives
1362 fac=(rrij*sigsq)**expon2
1363 e1=fac*fac*aa(itypi,itypj)
1364 e2=fac*bb(itypi,itypj)
1365 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1366 eps2der=evdwij*eps3rt
1367 eps3der=evdwij*eps2rt
1368 evdwij=evdwij*eps2rt*eps3rt
1371 sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1372 epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1373 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1374 cd & restyp(itypi),i,restyp(itypj),j,
1375 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1376 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1377 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1380 C Calculate gradient components.
1381 e1=e1*eps1*eps2rt**2*eps3rt**2
1382 fac=-expon*(e1+evdwij)
1385 C Calculate radial part of the gradient
1389 C Calculate the angular part of the gradient and sum add the contributions
1390 C to the appropriate components of the Cartesian gradient.
1398 C-----------------------------------------------------------------------------
1399 subroutine egb(evdw)
1401 C This subroutine calculates the interaction energy of nonbonded side chains
1402 C assuming the Gay-Berne potential of interaction.
1404 implicit real*8 (a-h,o-z)
1405 include 'DIMENSIONS'
1406 include 'COMMON.GEO'
1407 include 'COMMON.VAR'
1408 include 'COMMON.LOCAL'
1409 include 'COMMON.CHAIN'
1410 include 'COMMON.DERIV'
1411 include 'COMMON.NAMES'
1412 include 'COMMON.INTERACT'
1413 include 'COMMON.IOUNITS'
1414 include 'COMMON.CALC'
1415 include 'COMMON.CONTROL'
1416 include 'COMMON.SPLITELE'
1418 integer xshift,yshift,zshift
1420 ccccc energy_dec=.false.
1421 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1424 c if (icall.eq.0) lprn=.false.
1426 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1427 C we have the original box)
1431 do i=iatsc_s,iatsc_e
1432 itypi=iabs(itype(i))
1433 if (itypi.eq.ntyp1) cycle
1434 itypi1=iabs(itype(i+1))
1438 C Return atom into box, boxxsize is size of box in x dimension
1440 if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1441 if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1442 C Condition for being inside the proper box
1443 if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1444 & (xi.lt.((xshift-0.5d0)*boxxsize))) then
1448 if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1449 if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1450 C Condition for being inside the proper box
1451 if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1452 & (yi.lt.((yshift-0.5d0)*boxysize))) then
1456 if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1457 if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1458 C Condition for being inside the proper box
1459 if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1460 & (zi.lt.((zshift-0.5d0)*boxzsize))) then
1464 dxi=dc_norm(1,nres+i)
1465 dyi=dc_norm(2,nres+i)
1466 dzi=dc_norm(3,nres+i)
1467 c dsci_inv=dsc_inv(itypi)
1468 dsci_inv=vbld_inv(i+nres)
1469 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1470 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1472 C Calculate SC interaction energy.
1474 do iint=1,nint_gr(i)
1475 do j=istart(i,iint),iend(i,iint)
1477 itypj=iabs(itype(j))
1478 if (itypj.eq.ntyp1) cycle
1479 c dscj_inv=dsc_inv(itypj)
1480 dscj_inv=vbld_inv(j+nres)
1481 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1482 c & 1.0d0/vbld(j+nres)
1483 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1484 sig0ij=sigma(itypi,itypj)
1485 chi1=chi(itypi,itypj)
1486 chi2=chi(itypj,itypi)
1493 alf12=0.5D0*(alf1+alf2)
1494 C For diagnostics only!!!
1507 C Return atom J into box the original box
1509 if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1510 if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1511 C Condition for being inside the proper box
1512 if ((xj.gt.((0.5d0)*boxxsize)).or.
1513 & (xj.lt.((-0.5d0)*boxxsize))) then
1517 if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1518 if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1519 C Condition for being inside the proper box
1520 if ((yj.gt.((0.5d0)*boxysize)).or.
1521 & (yj.lt.((-0.5d0)*boxysize))) then
1525 if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1526 if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1527 C Condition for being inside the proper box
1528 if ((zj.gt.((0.5d0)*boxzsize)).or.
1529 & (zj.lt.((-0.5d0)*boxzsize))) then
1533 dxj=dc_norm(1,nres+j)
1534 dyj=dc_norm(2,nres+j)
1535 dzj=dc_norm(3,nres+j)
1539 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1540 c write (iout,*) "j",j," dc_norm",
1541 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1542 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1544 sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1545 sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1547 c write (iout,'(a7,4f8.3)')
1548 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1549 if (sss.gt.0.0d0) then
1550 C Calculate angle-dependent terms of energy and contributions to their
1554 sig=sig0ij*dsqrt(sigsq)
1555 rij_shift=1.0D0/rij-sig+sig0ij
1556 c for diagnostics; uncomment
1557 c rij_shift=1.2*sig0ij
1558 C I hate to put IF's in the loops, but here don't have another choice!!!!
1559 if (rij_shift.le.0.0D0) then
1561 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1562 cd & restyp(itypi),i,restyp(itypj),j,
1563 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1567 c---------------------------------------------------------------
1568 rij_shift=1.0D0/rij_shift
1569 fac=rij_shift**expon
1570 e1=fac*fac*aa(itypi,itypj)
1571 e2=fac*bb(itypi,itypj)
1572 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1573 eps2der=evdwij*eps3rt
1574 eps3der=evdwij*eps2rt
1575 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1576 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1577 evdwij=evdwij*eps2rt*eps3rt
1578 evdw=evdw+evdwij*sss
1580 sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1581 epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1582 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1583 & restyp(itypi),i,restyp(itypj),j,
1584 & epsi,sigm,chi1,chi2,chip1,chip2,
1585 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1586 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1590 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1593 C Calculate gradient components.
1594 e1=e1*eps1*eps2rt**2*eps3rt**2
1595 fac=-expon*(e1+evdwij)*rij_shift
1598 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
1599 c & evdwij,fac,sigma(itypi,itypj),expon
1600 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1602 C Calculate the radial part of the gradient
1606 C Calculate angular part of the gradient.
1615 c write (iout,*) "Number of loop steps in EGB:",ind
1616 cccc energy_dec=.false.
1619 C-----------------------------------------------------------------------------
1620 subroutine egbv(evdw)
1622 C This subroutine calculates the interaction energy of nonbonded side chains
1623 C assuming the Gay-Berne-Vorobjev potential of interaction.
1625 implicit real*8 (a-h,o-z)
1626 include 'DIMENSIONS'
1627 include 'COMMON.GEO'
1628 include 'COMMON.VAR'
1629 include 'COMMON.LOCAL'
1630 include 'COMMON.CHAIN'
1631 include 'COMMON.DERIV'
1632 include 'COMMON.NAMES'
1633 include 'COMMON.INTERACT'
1634 include 'COMMON.IOUNITS'
1635 include 'COMMON.CALC'
1636 common /srutu/ icall
1639 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1642 c if (icall.eq.0) lprn=.true.
1644 do i=iatsc_s,iatsc_e
1645 itypi=iabs(itype(i))
1646 if (itypi.eq.ntyp1) cycle
1647 itypi1=iabs(itype(i+1))
1651 dxi=dc_norm(1,nres+i)
1652 dyi=dc_norm(2,nres+i)
1653 dzi=dc_norm(3,nres+i)
1654 c dsci_inv=dsc_inv(itypi)
1655 dsci_inv=vbld_inv(i+nres)
1657 C Calculate SC interaction energy.
1659 do iint=1,nint_gr(i)
1660 do j=istart(i,iint),iend(i,iint)
1662 itypj=iabs(itype(j))
1663 if (itypj.eq.ntyp1) cycle
1664 c dscj_inv=dsc_inv(itypj)
1665 dscj_inv=vbld_inv(j+nres)
1666 sig0ij=sigma(itypi,itypj)
1667 r0ij=r0(itypi,itypj)
1668 chi1=chi(itypi,itypj)
1669 chi2=chi(itypj,itypi)
1676 alf12=0.5D0*(alf1+alf2)
1677 C For diagnostics only!!!
1690 dxj=dc_norm(1,nres+j)
1691 dyj=dc_norm(2,nres+j)
1692 dzj=dc_norm(3,nres+j)
1693 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1695 C Calculate angle-dependent terms of energy and contributions to their
1699 sig=sig0ij*dsqrt(sigsq)
1700 rij_shift=1.0D0/rij-sig+r0ij
1701 C I hate to put IF's in the loops, but here don't have another choice!!!!
1702 if (rij_shift.le.0.0D0) then
1707 c---------------------------------------------------------------
1708 rij_shift=1.0D0/rij_shift
1709 fac=rij_shift**expon
1710 e1=fac*fac*aa(itypi,itypj)
1711 e2=fac*bb(itypi,itypj)
1712 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1713 eps2der=evdwij*eps3rt
1714 eps3der=evdwij*eps2rt
1715 fac_augm=rrij**expon
1716 e_augm=augm(itypi,itypj)*fac_augm
1717 evdwij=evdwij*eps2rt*eps3rt
1718 evdw=evdw+evdwij+e_augm
1720 sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1721 epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1722 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1723 & restyp(itypi),i,restyp(itypj),j,
1724 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1725 & chi1,chi2,chip1,chip2,
1726 & eps1,eps2rt**2,eps3rt**2,
1727 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1730 C Calculate gradient components.
1731 e1=e1*eps1*eps2rt**2*eps3rt**2
1732 fac=-expon*(e1+evdwij)*rij_shift
1734 fac=rij*fac-2*expon*rrij*e_augm
1735 C Calculate the radial part of the gradient
1739 C Calculate angular part of the gradient.
1745 C-----------------------------------------------------------------------------
1746 subroutine sc_angular
1747 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1748 C om12. Called by ebp, egb, and egbv.
1750 include 'COMMON.CALC'
1751 include 'COMMON.IOUNITS'
1755 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1756 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1757 om12=dxi*dxj+dyi*dyj+dzi*dzj
1759 C Calculate eps1(om12) and its derivative in om12
1760 faceps1=1.0D0-om12*chiom12
1761 faceps1_inv=1.0D0/faceps1
1762 eps1=dsqrt(faceps1_inv)
1763 C Following variable is eps1*deps1/dom12
1764 eps1_om12=faceps1_inv*chiom12
1769 c write (iout,*) "om12",om12," eps1",eps1
1770 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1775 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1776 sigsq=1.0D0-facsig*faceps1_inv
1777 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1778 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1779 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1785 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1786 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1788 C Calculate eps2 and its derivatives in om1, om2, and om12.
1791 chipom12=chip12*om12
1792 facp=1.0D0-om12*chipom12
1794 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1795 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1796 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1797 C Following variable is the square root of eps2
1798 eps2rt=1.0D0-facp1*facp_inv
1799 C Following three variables are the derivatives of the square root of eps
1800 C in om1, om2, and om12.
1801 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1802 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1803 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1804 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1805 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1806 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1807 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1808 c & " eps2rt_om12",eps2rt_om12
1809 C Calculate whole angle-dependent part of epsilon and contributions
1810 C to its derivatives
1813 C----------------------------------------------------------------------------
1815 implicit real*8 (a-h,o-z)
1816 include 'DIMENSIONS'
1817 include 'COMMON.CHAIN'
1818 include 'COMMON.DERIV'
1819 include 'COMMON.CALC'
1820 include 'COMMON.IOUNITS'
1821 double precision dcosom1(3),dcosom2(3)
1822 cc print *,'sss=',sss
1823 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1824 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1825 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1826 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
1830 c eom12=evdwij*eps1_om12
1832 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1833 c & " sigder",sigder
1834 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1835 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1837 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1838 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1841 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
1843 c write (iout,*) "gg",(gg(k),k=1,3)
1845 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1846 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1847 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
1848 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1849 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1850 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
1851 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1852 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1853 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1854 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1857 C Calculate the components of the gradient in DC and X
1861 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1865 gvdwc(l,i)=gvdwc(l,i)-gg(l)
1866 gvdwc(l,j)=gvdwc(l,j)+gg(l)
1870 C-----------------------------------------------------------------------
1871 subroutine e_softsphere(evdw)
1873 C This subroutine calculates the interaction energy of nonbonded side chains
1874 C assuming the LJ potential of interaction.
1876 implicit real*8 (a-h,o-z)
1877 include 'DIMENSIONS'
1878 parameter (accur=1.0d-10)
1879 include 'COMMON.GEO'
1880 include 'COMMON.VAR'
1881 include 'COMMON.LOCAL'
1882 include 'COMMON.CHAIN'
1883 include 'COMMON.DERIV'
1884 include 'COMMON.INTERACT'
1885 include 'COMMON.TORSION'
1886 include 'COMMON.SBRIDGE'
1887 include 'COMMON.NAMES'
1888 include 'COMMON.IOUNITS'
1889 include 'COMMON.CONTACTS'
1891 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1893 do i=iatsc_s,iatsc_e
1894 itypi=iabs(itype(i))
1895 if (itypi.eq.ntyp1) cycle
1896 itypi1=iabs(itype(i+1))
1901 C Calculate SC interaction energy.
1903 do iint=1,nint_gr(i)
1904 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1905 cd & 'iend=',iend(i,iint)
1906 do j=istart(i,iint),iend(i,iint)
1907 itypj=iabs(itype(j))
1908 if (itypj.eq.ntyp1) cycle
1912 rij=xj*xj+yj*yj+zj*zj
1913 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1914 r0ij=r0(itypi,itypj)
1916 c print *,i,j,r0ij,dsqrt(rij)
1917 if (rij.lt.r0ijsq) then
1918 evdwij=0.25d0*(rij-r0ijsq)**2
1926 C Calculate the components of the gradient in DC and X
1932 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1933 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1934 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1935 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1939 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1947 C--------------------------------------------------------------------------
1948 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1951 C Soft-sphere potential of p-p interaction
1953 implicit real*8 (a-h,o-z)
1954 include 'DIMENSIONS'
1955 include 'COMMON.CONTROL'
1956 include 'COMMON.IOUNITS'
1957 include 'COMMON.GEO'
1958 include 'COMMON.VAR'
1959 include 'COMMON.LOCAL'
1960 include 'COMMON.CHAIN'
1961 include 'COMMON.DERIV'
1962 include 'COMMON.INTERACT'
1963 include 'COMMON.CONTACTS'
1964 include 'COMMON.TORSION'
1965 include 'COMMON.VECTORS'
1966 include 'COMMON.FFIELD'
1968 cd write(iout,*) 'In EELEC_soft_sphere'
1975 do i=iatel_s,iatel_e
1976 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1980 xmedi=c(1,i)+0.5d0*dxi
1981 ymedi=c(2,i)+0.5d0*dyi
1982 zmedi=c(3,i)+0.5d0*dzi
1984 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1985 do j=ielstart(i),ielend(i)
1986 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1990 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1991 r0ij=rpp(iteli,itelj)
1996 xj=c(1,j)+0.5D0*dxj-xmedi
1997 yj=c(2,j)+0.5D0*dyj-ymedi
1998 zj=c(3,j)+0.5D0*dzj-zmedi
1999 rij=xj*xj+yj*yj+zj*zj
2000 if (rij.lt.r0ijsq) then
2001 evdw1ij=0.25d0*(rij-r0ijsq)**2
2009 C Calculate contributions to the Cartesian gradient.
2015 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2016 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2019 * Loop over residues i+1 thru j-1.
2023 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2028 cgrad do i=nnt,nct-1
2030 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2032 cgrad do j=i+1,nct-1
2034 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2040 c------------------------------------------------------------------------------
2041 subroutine vec_and_deriv
2042 implicit real*8 (a-h,o-z)
2043 include 'DIMENSIONS'
2047 include 'COMMON.IOUNITS'
2048 include 'COMMON.GEO'
2049 include 'COMMON.VAR'
2050 include 'COMMON.LOCAL'
2051 include 'COMMON.CHAIN'
2052 include 'COMMON.VECTORS'
2053 include 'COMMON.SETUP'
2054 include 'COMMON.TIME1'
2055 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2056 C Compute the local reference systems. For reference system (i), the
2057 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2058 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2060 do i=ivec_start,ivec_end
2064 if (i.eq.nres-1) then
2065 C Case of the last full residue
2066 C Compute the Z-axis
2067 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2068 costh=dcos(pi-theta(nres))
2069 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2073 C Compute the derivatives of uz
2075 uzder(2,1,1)=-dc_norm(3,i-1)
2076 uzder(3,1,1)= dc_norm(2,i-1)
2077 uzder(1,2,1)= dc_norm(3,i-1)
2079 uzder(3,2,1)=-dc_norm(1,i-1)
2080 uzder(1,3,1)=-dc_norm(2,i-1)
2081 uzder(2,3,1)= dc_norm(1,i-1)
2084 uzder(2,1,2)= dc_norm(3,i)
2085 uzder(3,1,2)=-dc_norm(2,i)
2086 uzder(1,2,2)=-dc_norm(3,i)
2088 uzder(3,2,2)= dc_norm(1,i)
2089 uzder(1,3,2)= dc_norm(2,i)
2090 uzder(2,3,2)=-dc_norm(1,i)
2092 C Compute the Y-axis
2095 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2097 C Compute the derivatives of uy
2100 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2101 & -dc_norm(k,i)*dc_norm(j,i-1)
2102 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2104 uyder(j,j,1)=uyder(j,j,1)-costh
2105 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2110 uygrad(l,k,j,i)=uyder(l,k,j)
2111 uzgrad(l,k,j,i)=uzder(l,k,j)
2115 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2116 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2117 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2118 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2121 C Compute the Z-axis
2122 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2123 costh=dcos(pi-theta(i+2))
2124 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2128 C Compute the derivatives of uz
2130 uzder(2,1,1)=-dc_norm(3,i+1)
2131 uzder(3,1,1)= dc_norm(2,i+1)
2132 uzder(1,2,1)= dc_norm(3,i+1)
2134 uzder(3,2,1)=-dc_norm(1,i+1)
2135 uzder(1,3,1)=-dc_norm(2,i+1)
2136 uzder(2,3,1)= dc_norm(1,i+1)
2139 uzder(2,1,2)= dc_norm(3,i)
2140 uzder(3,1,2)=-dc_norm(2,i)
2141 uzder(1,2,2)=-dc_norm(3,i)
2143 uzder(3,2,2)= dc_norm(1,i)
2144 uzder(1,3,2)= dc_norm(2,i)
2145 uzder(2,3,2)=-dc_norm(1,i)
2147 C Compute the Y-axis
2150 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2152 C Compute the derivatives of uy
2155 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2156 & -dc_norm(k,i)*dc_norm(j,i+1)
2157 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2159 uyder(j,j,1)=uyder(j,j,1)-costh
2160 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2165 uygrad(l,k,j,i)=uyder(l,k,j)
2166 uzgrad(l,k,j,i)=uzder(l,k,j)
2170 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2171 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2172 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2173 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2177 vbld_inv_temp(1)=vbld_inv(i+1)
2178 if (i.lt.nres-1) then
2179 vbld_inv_temp(2)=vbld_inv(i+2)
2181 vbld_inv_temp(2)=vbld_inv(i)
2186 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2187 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2192 #if defined(PARVEC) && defined(MPI)
2193 if (nfgtasks1.gt.1) then
2195 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2196 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2197 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2198 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2199 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2201 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2202 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2204 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2205 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2206 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2207 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2208 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2209 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2210 time_gather=time_gather+MPI_Wtime()-time00
2212 c if (fg_rank.eq.0) then
2213 c write (iout,*) "Arrays UY and UZ"
2215 c write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2222 C-----------------------------------------------------------------------------
2223 subroutine check_vecgrad
2224 implicit real*8 (a-h,o-z)
2225 include 'DIMENSIONS'
2226 include 'COMMON.IOUNITS'
2227 include 'COMMON.GEO'
2228 include 'COMMON.VAR'
2229 include 'COMMON.LOCAL'
2230 include 'COMMON.CHAIN'
2231 include 'COMMON.VECTORS'
2232 dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2233 dimension uyt(3,maxres),uzt(3,maxres)
2234 dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2235 double precision delta /1.0d-7/
2238 crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2239 crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2240 crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2241 cd write(iout,'(2i5,2(3f10.5,5x))') i,1,
2242 cd & (dc_norm(if90,i),if90=1,3)
2243 cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2244 cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2245 cd write(iout,'(a)')
2251 uygradt(l,k,j,i)=uygrad(l,k,j,i)
2252 uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2265 cd write (iout,*) 'i=',i
2267 erij(k)=dc_norm(k,i)
2271 dc_norm(k,i)=erij(k)
2273 dc_norm(j,i)=dc_norm(j,i)+delta
2274 c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2276 c dc_norm(k,i)=dc_norm(k,i)/fac
2278 c write (iout,*) (dc_norm(k,i),k=1,3)
2279 c write (iout,*) (erij(k),k=1,3)
2282 uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2283 uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2284 uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2285 uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2287 c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2288 c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2289 c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2292 dc_norm(k,i)=erij(k)
2295 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2296 cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2297 cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2298 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2299 cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2300 cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2301 cd write (iout,'(a)')
2306 C--------------------------------------------------------------------------
2307 subroutine set_matrices
2308 implicit real*8 (a-h,o-z)
2309 include 'DIMENSIONS'
2312 include "COMMON.SETUP"
2314 integer status(MPI_STATUS_SIZE)
2316 include 'COMMON.IOUNITS'
2317 include 'COMMON.GEO'
2318 include 'COMMON.VAR'
2319 include 'COMMON.LOCAL'
2320 include 'COMMON.CHAIN'
2321 include 'COMMON.DERIV'
2322 include 'COMMON.INTERACT'
2323 include 'COMMON.CONTACTS'
2324 include 'COMMON.TORSION'
2325 include 'COMMON.VECTORS'
2326 include 'COMMON.FFIELD'
2327 double precision auxvec(2),auxmat(2,2)
2329 C Compute the virtual-bond-torsional-angle dependent quantities needed
2330 C to calculate the el-loc multibody terms of various order.
2333 do i=ivec_start+2,ivec_end+2
2337 if (i .lt. nres+1) then
2374 if (i .gt. 3 .and. i .lt. nres+1) then
2375 obrot_der(1,i-2)=-sin1
2376 obrot_der(2,i-2)= cos1
2377 Ugder(1,1,i-2)= sin1
2378 Ugder(1,2,i-2)=-cos1
2379 Ugder(2,1,i-2)=-cos1
2380 Ugder(2,2,i-2)=-sin1
2383 obrot2_der(1,i-2)=-dwasin2
2384 obrot2_der(2,i-2)= dwacos2
2385 Ug2der(1,1,i-2)= dwasin2
2386 Ug2der(1,2,i-2)=-dwacos2
2387 Ug2der(2,1,i-2)=-dwacos2
2388 Ug2der(2,2,i-2)=-dwasin2
2390 obrot_der(1,i-2)=0.0d0
2391 obrot_der(2,i-2)=0.0d0
2392 Ugder(1,1,i-2)=0.0d0
2393 Ugder(1,2,i-2)=0.0d0
2394 Ugder(2,1,i-2)=0.0d0
2395 Ugder(2,2,i-2)=0.0d0
2396 obrot2_der(1,i-2)=0.0d0
2397 obrot2_der(2,i-2)=0.0d0
2398 Ug2der(1,1,i-2)=0.0d0
2399 Ug2der(1,2,i-2)=0.0d0
2400 Ug2der(2,1,i-2)=0.0d0
2401 Ug2der(2,2,i-2)=0.0d0
2403 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2404 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2405 iti = itortyp(itype(i-2))
2409 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2410 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2411 iti1 = itortyp(itype(i-1))
2415 cd write (iout,*) '*******i',i,' iti1',iti
2416 cd write (iout,*) 'b1',b1(:,iti)
2417 cd write (iout,*) 'b2',b2(:,iti)
2418 cd write (iout,*) 'Ug',Ug(:,:,i-2)
2419 c if (i .gt. iatel_s+2) then
2420 if (i .gt. nnt+2) then
2421 call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2422 call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2423 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2425 call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2426 call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2427 call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2428 call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2429 call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2440 DtUg2(l,k,i-2)=0.0d0
2444 call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2445 call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2447 muder(k,i-2)=Ub2der(k,i-2)
2449 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2450 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2451 if (itype(i-1).le.ntyp) then
2452 iti1 = itortyp(itype(i-1))
2460 mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2462 cd write (iout,*) 'mu ',mu(:,i-2)
2463 cd write (iout,*) 'mu1',mu1(:,i-2)
2464 cd write (iout,*) 'mu2',mu2(:,i-2)
2465 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2467 call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2468 call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2469 call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2470 call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2471 call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2472 C Vectors and matrices dependent on a single virtual-bond dihedral.
2473 call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2474 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2475 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2476 call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2477 call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2478 call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2479 call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2480 call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2481 call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2484 C Matrices dependent on two consecutive virtual-bond dihedrals.
2485 C The order of matrices is from left to right.
2486 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2488 c do i=max0(ivec_start,2),ivec_end
2490 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2491 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2492 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2493 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2494 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2495 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2496 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2497 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2500 #if defined(MPI) && defined(PARMAT)
2502 c if (fg_rank.eq.0) then
2503 write (iout,*) "Arrays UG and UGDER before GATHER"
2505 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2506 & ((ug(l,k,i),l=1,2),k=1,2),
2507 & ((ugder(l,k,i),l=1,2),k=1,2)
2509 write (iout,*) "Arrays UG2 and UG2DER"
2511 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2512 & ((ug2(l,k,i),l=1,2),k=1,2),
2513 & ((ug2der(l,k,i),l=1,2),k=1,2)
2515 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2517 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2518 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2519 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2521 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2523 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2524 & costab(i),sintab(i),costab2(i),sintab2(i)
2526 write (iout,*) "Array MUDER"
2528 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2532 if (nfgtasks.gt.1) then
2534 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2535 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2536 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2538 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2539 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2541 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2542 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2544 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2545 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2547 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2548 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2550 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2551 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2553 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2554 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2556 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2557 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2558 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2559 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2560 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2561 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2562 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2563 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2564 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2565 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2566 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2567 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2568 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2570 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2571 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2573 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2574 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2576 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2577 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2579 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2580 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2582 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2583 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2585 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2586 & ivec_count(fg_rank1),
2587 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2589 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2590 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2592 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2593 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2595 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2596 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2598 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2599 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2601 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2602 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2604 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2605 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2607 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2608 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2610 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2611 & ivec_count(fg_rank1),
2612 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2614 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2615 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2617 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2618 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2620 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2621 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2623 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2624 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2626 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2627 & ivec_count(fg_rank1),
2628 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2630 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2631 & ivec_count(fg_rank1),
2632 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2634 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2635 & ivec_count(fg_rank1),
2636 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2637 & MPI_MAT2,FG_COMM1,IERR)
2638 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2639 & ivec_count(fg_rank1),
2640 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2641 & MPI_MAT2,FG_COMM1,IERR)
2644 c Passes matrix info through the ring
2647 if (irecv.lt.0) irecv=nfgtasks1-1
2650 if (inext.ge.nfgtasks1) inext=0
2652 c write (iout,*) "isend",isend," irecv",irecv
2654 lensend=lentyp(isend)
2655 lenrecv=lentyp(irecv)
2656 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
2657 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2658 c & MPI_ROTAT1(lensend),inext,2200+isend,
2659 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2660 c & iprev,2200+irecv,FG_COMM,status,IERR)
2661 c write (iout,*) "Gather ROTAT1"
2663 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2664 c & MPI_ROTAT2(lensend),inext,3300+isend,
2665 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2666 c & iprev,3300+irecv,FG_COMM,status,IERR)
2667 c write (iout,*) "Gather ROTAT2"
2669 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2670 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
2671 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2672 & iprev,4400+irecv,FG_COMM,status,IERR)
2673 c write (iout,*) "Gather ROTAT_OLD"
2675 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2676 & MPI_PRECOMP11(lensend),inext,5500+isend,
2677 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2678 & iprev,5500+irecv,FG_COMM,status,IERR)
2679 c write (iout,*) "Gather PRECOMP11"
2681 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2682 & MPI_PRECOMP12(lensend),inext,6600+isend,
2683 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2684 & iprev,6600+irecv,FG_COMM,status,IERR)
2685 c write (iout,*) "Gather PRECOMP12"
2687 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2689 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2690 & MPI_ROTAT2(lensend),inext,7700+isend,
2691 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2692 & iprev,7700+irecv,FG_COMM,status,IERR)
2693 c write (iout,*) "Gather PRECOMP21"
2695 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2696 & MPI_PRECOMP22(lensend),inext,8800+isend,
2697 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2698 & iprev,8800+irecv,FG_COMM,status,IERR)
2699 c write (iout,*) "Gather PRECOMP22"
2701 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2702 & MPI_PRECOMP23(lensend),inext,9900+isend,
2703 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2704 & MPI_PRECOMP23(lenrecv),
2705 & iprev,9900+irecv,FG_COMM,status,IERR)
2706 c write (iout,*) "Gather PRECOMP23"
2711 if (irecv.lt.0) irecv=nfgtasks1-1
2714 time_gather=time_gather+MPI_Wtime()-time00
2717 c if (fg_rank.eq.0) then
2718 write (iout,*) "Arrays UG and UGDER"
2720 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2721 & ((ug(l,k,i),l=1,2),k=1,2),
2722 & ((ugder(l,k,i),l=1,2),k=1,2)
2724 write (iout,*) "Arrays UG2 and UG2DER"
2726 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2727 & ((ug2(l,k,i),l=1,2),k=1,2),
2728 & ((ug2der(l,k,i),l=1,2),k=1,2)
2730 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2732 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2733 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2734 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2736 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2738 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2739 & costab(i),sintab(i),costab2(i),sintab2(i)
2741 write (iout,*) "Array MUDER"
2743 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2749 cd iti = itortyp(itype(i))
2752 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2753 cd & (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2758 C--------------------------------------------------------------------------
2759 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2761 C This subroutine calculates the average interaction energy and its gradient
2762 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2763 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2764 C The potential depends both on the distance of peptide-group centers and on
2765 C the orientation of the CA-CA virtual bonds.
2767 implicit real*8 (a-h,o-z)
2771 include 'DIMENSIONS'
2772 include 'COMMON.CONTROL'
2773 include 'COMMON.SETUP'
2774 include 'COMMON.IOUNITS'
2775 include 'COMMON.GEO'
2776 include 'COMMON.VAR'
2777 include 'COMMON.LOCAL'
2778 include 'COMMON.CHAIN'
2779 include 'COMMON.DERIV'
2780 include 'COMMON.INTERACT'
2781 include 'COMMON.CONTACTS'
2782 include 'COMMON.TORSION'
2783 include 'COMMON.VECTORS'
2784 include 'COMMON.FFIELD'
2785 include 'COMMON.TIME1'
2786 include 'COMMON.SPLITELE'
2787 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2788 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2789 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2790 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2791 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2792 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2794 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2796 double precision scal_el /1.0d0/
2798 double precision scal_el /0.5d0/
2801 C 13-go grudnia roku pamietnego...
2802 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2803 & 0.0d0,1.0d0,0.0d0,
2804 & 0.0d0,0.0d0,1.0d0/
2805 cd write(iout,*) 'In EELEC'
2807 cd write(iout,*) 'Type',i
2808 cd write(iout,*) 'B1',B1(:,i)
2809 cd write(iout,*) 'B2',B2(:,i)
2810 cd write(iout,*) 'CC',CC(:,:,i)
2811 cd write(iout,*) 'DD',DD(:,:,i)
2812 cd write(iout,*) 'EE',EE(:,:,i)
2814 cd call check_vecgrad
2816 if (icheckgrad.eq.1) then
2818 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2820 dc_norm(k,i)=dc(k,i)*fac
2822 c write (iout,*) 'i',i,' fac',fac
2825 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2826 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2827 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2828 c call vec_and_deriv
2834 time_mat=time_mat+MPI_Wtime()-time01
2838 cd write (iout,*) 'i=',i
2840 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2843 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2844 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2857 cd print '(a)','Enter EELEC'
2858 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2860 gel_loc_loc(i)=0.0d0
2865 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2867 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2869 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2870 do i=iturn3_start,iturn3_end
2871 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2872 & .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2876 dx_normi=dc_norm(1,i)
2877 dy_normi=dc_norm(2,i)
2878 dz_normi=dc_norm(3,i)
2879 xmedi=c(1,i)+0.5d0*dxi
2880 ymedi=c(2,i)+0.5d0*dyi
2881 zmedi=c(3,i)+0.5d0*dzi
2882 C Return atom into box, boxxsize is size of box in x dimension
2884 if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2885 if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2886 C Condition for being inside the proper box
2887 if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2888 & (xmedi.lt.((-0.5d0)*boxxsize))) then
2892 if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2893 if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2894 C Condition for being inside the proper box
2895 if ((ymedi.gt.((0.5d0)*boxysize)).or.
2896 & (ymedi.lt.((-0.5d0)*boxysize))) then
2900 if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2901 if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2902 C Condition for being inside the proper box
2903 if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2904 & (zmedi.lt.((-0.5d0)*boxzsize))) then
2908 call eelecij(i,i+2,ees,evdw1,eel_loc)
2909 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2910 num_cont_hb(i)=num_conti
2912 do i=iturn4_start,iturn4_end
2913 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2914 & .or. itype(i+3).eq.ntyp1
2915 & .or. itype(i+4).eq.ntyp1) cycle
2919 dx_normi=dc_norm(1,i)
2920 dy_normi=dc_norm(2,i)
2921 dz_normi=dc_norm(3,i)
2922 xmedi=c(1,i)+0.5d0*dxi
2923 ymedi=c(2,i)+0.5d0*dyi
2924 zmedi=c(3,i)+0.5d0*dzi
2925 C Return atom into box, boxxsize is size of box in x dimension
2927 if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2928 if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2929 C Condition for being inside the proper box
2930 if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2931 & (xmedi.lt.((-0.5d0)*boxxsize))) then
2935 if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2936 if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2937 C Condition for being inside the proper box
2938 if ((ymedi.gt.((0.5d0)*boxysize)).or.
2939 & (ymedi.lt.((-0.5d0)*boxysize))) then
2943 if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2944 if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2945 C Condition for being inside the proper box
2946 if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2947 & (zmedi.lt.((-0.5d0)*boxzsize))) then
2951 num_conti=num_cont_hb(i)
2952 call eelecij(i,i+3,ees,evdw1,eel_loc)
2953 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2954 & call eturn4(i,eello_turn4)
2955 num_cont_hb(i)=num_conti
2957 C Loop over all neighbouring boxes
2962 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2964 do i=iatel_s,iatel_e
2965 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2969 dx_normi=dc_norm(1,i)
2970 dy_normi=dc_norm(2,i)
2971 dz_normi=dc_norm(3,i)
2972 xmedi=c(1,i)+0.5d0*dxi
2973 ymedi=c(2,i)+0.5d0*dyi
2974 zmedi=c(3,i)+0.5d0*dzi
2975 C Return atom into box, boxxsize is size of box in x dimension
2977 if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2978 if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2979 C Condition for being inside the proper box
2980 if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2981 & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2985 if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2986 if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2987 C Condition for being inside the proper box
2988 if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2989 & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2993 if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2994 if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2995 C Condition for being inside the proper box
2996 if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2997 & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3001 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3002 num_conti=num_cont_hb(i)
3003 do j=ielstart(i),ielend(i)
3004 c write (iout,*) i,j,itype(i),itype(j)
3005 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
3006 call eelecij(i,j,ees,evdw1,eel_loc)
3008 num_cont_hb(i)=num_conti
3014 c write (iout,*) "Number of loop steps in EELEC:",ind
3016 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3017 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3019 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3020 ccc eel_loc=eel_loc+eello_turn3
3021 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3024 C-------------------------------------------------------------------------------
3025 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3026 implicit real*8 (a-h,o-z)
3027 include 'DIMENSIONS'
3031 include 'COMMON.CONTROL'
3032 include 'COMMON.IOUNITS'
3033 include 'COMMON.GEO'
3034 include 'COMMON.VAR'
3035 include 'COMMON.LOCAL'
3036 include 'COMMON.CHAIN'
3037 include 'COMMON.DERIV'
3038 include 'COMMON.INTERACT'
3039 include 'COMMON.CONTACTS'
3040 include 'COMMON.TORSION'
3041 include 'COMMON.VECTORS'
3042 include 'COMMON.FFIELD'
3043 include 'COMMON.TIME1'
3044 include 'COMMON.SPLITELE'
3045 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3046 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3047 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3048 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3049 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3050 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3052 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3054 double precision scal_el /1.0d0/
3056 double precision scal_el /0.5d0/
3059 C 13-go grudnia roku pamietnego...
3060 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3061 & 0.0d0,1.0d0,0.0d0,
3062 & 0.0d0,0.0d0,1.0d0/
3063 c time00=MPI_Wtime()
3064 cd write (iout,*) "eelecij",i,j
3068 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3069 aaa=app(iteli,itelj)
3070 bbb=bpp(iteli,itelj)
3071 ael6i=ael6(iteli,itelj)
3072 ael3i=ael3(iteli,itelj)
3076 dx_normj=dc_norm(1,j)
3077 dy_normj=dc_norm(2,j)
3078 dz_normj=dc_norm(3,j)
3079 C xj=c(1,j)+0.5D0*dxj-xmedi
3080 C yj=c(2,j)+0.5D0*dyj-ymedi
3081 C zj=c(3,j)+0.5D0*dzj-zmedi
3085 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3087 if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3088 if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3089 C Condition for being inside the proper box
3090 if ((xj.gt.((0.5d0)*boxxsize)).or.
3091 & (xj.lt.((-0.5d0)*boxxsize))) then
3095 if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3096 if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3097 C Condition for being inside the proper box
3098 if ((yj.gt.((0.5d0)*boxysize)).or.
3099 & (yj.lt.((-0.5d0)*boxysize))) then
3103 if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3104 if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3105 C Condition for being inside the proper box
3106 if ((zj.gt.((0.5d0)*boxzsize)).or.
3107 & (zj.lt.((-0.5d0)*boxzsize))) then
3110 C endif !endPBC condintion
3114 rij=xj*xj+yj*yj+zj*zj
3116 sss=sscale(sqrt(rij))
3117 sssgrad=sscagrad(sqrt(rij))
3118 c if (sss.gt.0.0d0) then
3124 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3125 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3126 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3127 fac=cosa-3.0D0*cosb*cosg
3129 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3130 if (j.eq.i+2) ev1=scal_el*ev1
3135 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3139 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3140 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3142 evdw1=evdw1+evdwij*sss
3143 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3144 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3145 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
3146 cd & xmedi,ymedi,zmedi,xj,yj,zj
3148 if (energy_dec) then
3149 write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3151 &,iteli,itelj,aaa,evdw1
3152 write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3156 C Calculate contributions to the Cartesian gradient.
3159 facvdw=-6*rrmij*(ev1+evdwij)*sss
3160 facel=-3*rrmij*(el1+eesij)
3166 * Radial derivatives. First process both termini of the fragment (i,j)
3172 c ghalf=0.5D0*ggg(k)
3173 c gelc(k,i)=gelc(k,i)+ghalf
3174 c gelc(k,j)=gelc(k,j)+ghalf
3176 c 9/28/08 AL Gradient compotents will be summed only at the end
3178 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3179 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3182 * Loop over residues i+1 thru j-1.
3186 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
3193 c ghalf=0.5D0*ggg(k)
3194 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3195 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3197 c 9/28/08 AL Gradient compotents will be summed only at the end
3199 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3200 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3203 * Loop over residues i+1 thru j-1.
3207 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3212 facvdw=(ev1+evdwij)*sss
3215 fac=-3*rrmij*(facvdw+facvdw+facel)+sssgrad*rmij*evdwij
3220 * Radial derivatives. First process both termini of the fragment (i,j)
3226 c ghalf=0.5D0*ggg(k)
3227 c gelc(k,i)=gelc(k,i)+ghalf
3228 c gelc(k,j)=gelc(k,j)+ghalf
3230 c 9/28/08 AL Gradient compotents will be summed only at the end
3232 gelc_long(k,j)=gelc(k,j)+ggg(k)
3233 gelc_long(k,i)=gelc(k,i)-ggg(k)
3236 * Loop over residues i+1 thru j-1.
3240 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
3243 c 9/28/08 AL Gradient compotents will be summed only at the end
3244 ggg(1)=facvdw*xj*sss
3245 ggg(2)=facvdw*yj*sss
3246 ggg(3)=facvdw*zj*sss
3248 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3249 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3255 ecosa=2.0D0*fac3*fac1+fac4
3258 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3259 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3261 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3262 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3264 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3265 cd & (dcosg(k),k=1,3)
3267 ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3270 c ghalf=0.5D0*ggg(k)
3271 c gelc(k,i)=gelc(k,i)+ghalf
3272 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3273 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3274 c gelc(k,j)=gelc(k,j)+ghalf
3275 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3276 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3280 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
3285 & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3286 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3288 & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3289 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3290 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3291 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3295 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3296 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3297 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3299 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3300 C energy of a peptide unit is assumed in the form of a second-order
3301 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3302 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3303 C are computed for EVERY pair of non-contiguous peptide groups.
3305 if (j.lt.nres-1) then
3316 muij(kkk)=mu(k,i)*mu(l,j)
3319 cd write (iout,*) 'EELEC: i',i,' j',j
3320 cd write (iout,*) 'j',j,' j1',j1,' j2',j2
3321 cd write(iout,*) 'muij',muij
3322 ury=scalar(uy(1,i),erij)
3323 urz=scalar(uz(1,i),erij)
3324 vry=scalar(uy(1,j),erij)
3325 vrz=scalar(uz(1,j),erij)
3326 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3327 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3328 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3329 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3330 fac=dsqrt(-ael6i)*r3ij
3335 cd write (iout,'(4i5,4f10.5)')
3336 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3337 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3338 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3339 cd & uy(:,j),uz(:,j)
3340 cd write (iout,'(4f10.5)')
3341 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3342 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3343 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
3344 cd write (iout,'(9f10.5/)')
3345 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3346 C Derivatives of the elements of A in virtual-bond vectors
3347 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3349 uryg(k,1)=scalar(erder(1,k),uy(1,i))
3350 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3351 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3352 urzg(k,1)=scalar(erder(1,k),uz(1,i))
3353 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3354 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3355 vryg(k,1)=scalar(erder(1,k),uy(1,j))
3356 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3357 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3358 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3359 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3360 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3362 C Compute radial contributions to the gradient
3380 C Add the contributions coming from er
3383 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3384 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3385 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3386 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3389 C Derivatives in DC(i)
3390 cgrad ghalf1=0.5d0*agg(k,1)
3391 cgrad ghalf2=0.5d0*agg(k,2)
3392 cgrad ghalf3=0.5d0*agg(k,3)
3393 cgrad ghalf4=0.5d0*agg(k,4)
3394 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3395 & -3.0d0*uryg(k,2)*vry)!+ghalf1
3396 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3397 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
3398 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3399 & -3.0d0*urzg(k,2)*vry)!+ghalf3
3400 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3401 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
3402 C Derivatives in DC(i+1)
3403 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3404 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3405 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3406 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3407 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3408 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3409 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3410 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3411 C Derivatives in DC(j)
3412 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3413 & -3.0d0*vryg(k,2)*ury)!+ghalf1
3414 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3415 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
3416 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3417 & -3.0d0*vryg(k,2)*urz)!+ghalf3
3418 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3419 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
3420 C Derivatives in DC(j+1) or DC(nres-1)
3421 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3422 & -3.0d0*vryg(k,3)*ury)
3423 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3424 & -3.0d0*vrzg(k,3)*ury)
3425 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3426 & -3.0d0*vryg(k,3)*urz)
3427 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3428 & -3.0d0*vrzg(k,3)*urz)
3429 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
3431 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
3444 aggi(k,l)=-aggi(k,l)
3445 aggi1(k,l)=-aggi1(k,l)
3446 aggj(k,l)=-aggj(k,l)
3447 aggj1(k,l)=-aggj1(k,l)
3450 if (j.lt.nres-1) then
3456 aggi(k,l)=-aggi(k,l)
3457 aggi1(k,l)=-aggi1(k,l)
3458 aggj(k,l)=-aggj(k,l)
3459 aggj1(k,l)=-aggj1(k,l)
3470 aggi(k,l)=-aggi(k,l)
3471 aggi1(k,l)=-aggi1(k,l)
3472 aggj(k,l)=-aggj(k,l)
3473 aggj1(k,l)=-aggj1(k,l)
3478 IF (wel_loc.gt.0.0d0) THEN
3479 C Contribution to the local-electrostatic energy coming from the i-j pair
3480 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3482 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3484 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3485 & 'eelloc',i,j,eel_loc_ij
3486 c if (eel_loc_ij.ne.0)
3487 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
3488 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3490 eel_loc=eel_loc+eel_loc_ij
3491 C Partial derivatives in virtual-bond dihedral angles gamma
3493 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3494 & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3495 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3496 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3497 & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3498 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3499 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3501 ggg(l)=agg(l,1)*muij(1)+
3502 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3503 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3504 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3505 cgrad ghalf=0.5d0*ggg(l)
3506 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
3507 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
3511 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3514 C Remaining derivatives of eello
3516 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3517 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3518 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3519 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3520 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3521 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3522 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3523 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3526 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3527 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
3528 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3529 & .and. num_conti.le.maxconts) then
3530 c write (iout,*) i,j," entered corr"
3532 C Calculate the contact function. The ith column of the array JCONT will
3533 C contain the numbers of atoms that make contacts with the atom I (of numbers
3534 C greater than I). The arrays FACONT and GACONT will contain the values of
3535 C the contact function and its derivative.
3536 c r0ij=1.02D0*rpp(iteli,itelj)
3537 c r0ij=1.11D0*rpp(iteli,itelj)
3538 r0ij=2.20D0*rpp(iteli,itelj)
3539 c r0ij=1.55D0*rpp(iteli,itelj)
3540 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3541 if (fcont.gt.0.0D0) then
3542 num_conti=num_conti+1
3543 if (num_conti.gt.maxconts) then
3544 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3545 & ' will skip next contacts for this conf.'
3547 jcont_hb(num_conti,i)=j
3548 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
3549 cd & " jcont_hb",jcont_hb(num_conti,i)
3550 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3551 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3552 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3554 d_cont(num_conti,i)=rij
3555 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3556 C --- Electrostatic-interaction matrix ---
3557 a_chuj(1,1,num_conti,i)=a22
3558 a_chuj(1,2,num_conti,i)=a23
3559 a_chuj(2,1,num_conti,i)=a32
3560 a_chuj(2,2,num_conti,i)=a33
3561 C --- Gradient of rij
3563 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3570 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3571 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3572 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3573 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3574 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3579 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3580 C Calculate contact energies
3582 wij=cosa-3.0D0*cosb*cosg
3585 c fac3=dsqrt(-ael6i)/r0ij**3
3586 fac3=dsqrt(-ael6i)*r3ij
3587 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3588 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3589 if (ees0tmp.gt.0) then
3590 ees0pij=dsqrt(ees0tmp)
3594 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3595 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3596 if (ees0tmp.gt.0) then
3597 ees0mij=dsqrt(ees0tmp)
3602 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3603 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3604 C Diagnostics. Comment out or remove after debugging!
3605 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3606 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3607 c ees0m(num_conti,i)=0.0D0
3609 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3610 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3611 C Angular derivatives of the contact function
3612 ees0pij1=fac3/ees0pij
3613 ees0mij1=fac3/ees0mij
3614 fac3p=-3.0D0*fac3*rrmij
3615 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3616 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3618 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
3619 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3620 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3621 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
3622 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3623 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3624 ecosap=ecosa1+ecosa2
3625 ecosbp=ecosb1+ecosb2
3626 ecosgp=ecosg1+ecosg2
3627 ecosam=ecosa1-ecosa2
3628 ecosbm=ecosb1-ecosb2
3629 ecosgm=ecosg1-ecosg2
3638 facont_hb(num_conti,i)=fcont
3639 fprimcont=fprimcont/rij
3640 cd facont_hb(num_conti,i)=1.0D0
3641 C Following line is for diagnostics.
3644 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3645 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3648 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3649 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3651 gggp(1)=gggp(1)+ees0pijp*xj
3652 gggp(2)=gggp(2)+ees0pijp*yj
3653 gggp(3)=gggp(3)+ees0pijp*zj
3654 gggm(1)=gggm(1)+ees0mijp*xj
3655 gggm(2)=gggm(2)+ees0mijp*yj
3656 gggm(3)=gggm(3)+ees0mijp*zj
3657 C Derivatives due to the contact function
3658 gacont_hbr(1,num_conti,i)=fprimcont*xj
3659 gacont_hbr(2,num_conti,i)=fprimcont*yj
3660 gacont_hbr(3,num_conti,i)=fprimcont*zj
3663 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3664 c following the change of gradient-summation algorithm.
3666 cgrad ghalfp=0.5D0*gggp(k)
3667 cgrad ghalfm=0.5D0*gggm(k)
3668 gacontp_hb1(k,num_conti,i)=!ghalfp
3669 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3670 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3671 gacontp_hb2(k,num_conti,i)=!ghalfp
3672 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3673 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3674 gacontp_hb3(k,num_conti,i)=gggp(k)
3675 gacontm_hb1(k,num_conti,i)=!ghalfm
3676 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3677 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3678 gacontm_hb2(k,num_conti,i)=!ghalfm
3679 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3680 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3681 gacontm_hb3(k,num_conti,i)=gggm(k)
3683 C Diagnostics. Comment out or remove after debugging!
3685 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
3686 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
3687 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
3688 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
3689 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
3690 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
3693 endif ! num_conti.le.maxconts
3696 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3699 ghalf=0.5d0*agg(l,k)
3700 aggi(l,k)=aggi(l,k)+ghalf
3701 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3702 aggj(l,k)=aggj(l,k)+ghalf
3705 if (j.eq.nres-1 .and. i.lt.j-2) then
3708 aggj1(l,k)=aggj1(l,k)+agg(l,k)
3713 c t_eelecij=t_eelecij+MPI_Wtime()-time00
3716 C-----------------------------------------------------------------------------
3717 subroutine eturn3(i,eello_turn3)
3718 C Third- and fourth-order contributions from turns
3719 implicit real*8 (a-h,o-z)
3720 include 'DIMENSIONS'
3721 include 'COMMON.IOUNITS'
3722 include 'COMMON.GEO'
3723 include 'COMMON.VAR'
3724 include 'COMMON.LOCAL'
3725 include 'COMMON.CHAIN'
3726 include 'COMMON.DERIV'
3727 include 'COMMON.INTERACT'
3728 include 'COMMON.CONTACTS'
3729 include 'COMMON.TORSION'
3730 include 'COMMON.VECTORS'
3731 include 'COMMON.FFIELD'
3732 include 'COMMON.CONTROL'
3734 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3735 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3736 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3737 double precision agg(3,4),aggi(3,4),aggi1(3,4),
3738 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3739 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3740 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3743 c write (iout,*) "eturn3",i,j,j1,j2
3748 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3750 C Third-order contributions
3757 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3758 cd call checkint_turn3(i,a_temp,eello_turn3_num)
3759 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3760 call transpose2(auxmat(1,1),auxmat1(1,1))
3761 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3762 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3763 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3764 & 'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3765 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
3766 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
3767 cd & ' eello_turn3_num',4*eello_turn3_num
3768 C Derivatives in gamma(i)
3769 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3770 call transpose2(auxmat2(1,1),auxmat3(1,1))
3771 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3772 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3773 C Derivatives in gamma(i+1)
3774 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3775 call transpose2(auxmat2(1,1),auxmat3(1,1))
3776 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3777 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3778 & +0.5d0*(pizda(1,1)+pizda(2,2))
3779 C Cartesian derivatives
3781 c ghalf1=0.5d0*agg(l,1)
3782 c ghalf2=0.5d0*agg(l,2)
3783 c ghalf3=0.5d0*agg(l,3)
3784 c ghalf4=0.5d0*agg(l,4)
3785 a_temp(1,1)=aggi(l,1)!+ghalf1
3786 a_temp(1,2)=aggi(l,2)!+ghalf2
3787 a_temp(2,1)=aggi(l,3)!+ghalf3
3788 a_temp(2,2)=aggi(l,4)!+ghalf4
3789 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3790 gcorr3_turn(l,i)=gcorr3_turn(l,i)
3791 & +0.5d0*(pizda(1,1)+pizda(2,2))
3792 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3793 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3794 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3795 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3796 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3797 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3798 & +0.5d0*(pizda(1,1)+pizda(2,2))
3799 a_temp(1,1)=aggj(l,1)!+ghalf1
3800 a_temp(1,2)=aggj(l,2)!+ghalf2
3801 a_temp(2,1)=aggj(l,3)!+ghalf3
3802 a_temp(2,2)=aggj(l,4)!+ghalf4
3803 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3804 gcorr3_turn(l,j)=gcorr3_turn(l,j)
3805 & +0.5d0*(pizda(1,1)+pizda(2,2))
3806 a_temp(1,1)=aggj1(l,1)
3807 a_temp(1,2)=aggj1(l,2)
3808 a_temp(2,1)=aggj1(l,3)
3809 a_temp(2,2)=aggj1(l,4)
3810 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3811 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3812 & +0.5d0*(pizda(1,1)+pizda(2,2))
3816 C-------------------------------------------------------------------------------
3817 subroutine eturn4(i,eello_turn4)
3818 C Third- and fourth-order contributions from turns
3819 implicit real*8 (a-h,o-z)
3820 include 'DIMENSIONS'
3821 include 'COMMON.IOUNITS'
3822 include 'COMMON.GEO'
3823 include 'COMMON.VAR'
3824 include 'COMMON.LOCAL'
3825 include 'COMMON.CHAIN'
3826 include 'COMMON.DERIV'
3827 include 'COMMON.INTERACT'
3828 include 'COMMON.CONTACTS'
3829 include 'COMMON.TORSION'
3830 include 'COMMON.VECTORS'
3831 include 'COMMON.FFIELD'
3832 include 'COMMON.CONTROL'
3834 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3835 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3836 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3837 double precision agg(3,4),aggi(3,4),aggi1(3,4),
3838 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3839 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3840 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3843 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3845 C Fourth-order contributions
3853 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3854 cd call checkint_turn4(i,a_temp,eello_turn4_num)
3855 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3860 iti1=itortyp(itype(i+1))
3861 iti2=itortyp(itype(i+2))
3862 iti3=itortyp(itype(i+3))
3863 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3864 call transpose2(EUg(1,1,i+1),e1t(1,1))
3865 call transpose2(Eug(1,1,i+2),e2t(1,1))
3866 call transpose2(Eug(1,1,i+3),e3t(1,1))
3867 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3868 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3869 s1=scalar2(b1(1,iti2),auxvec(1))
3870 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3871 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3872 s2=scalar2(b1(1,iti1),auxvec(1))
3873 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3874 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3875 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3876 eello_turn4=eello_turn4-(s1+s2+s3)
3877 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3878 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3879 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3880 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3881 cd & ' eello_turn4_num',8*eello_turn4_num
3882 C Derivatives in gamma(i)
3883 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3884 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3885 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3886 s1=scalar2(b1(1,iti2),auxvec(1))
3887 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3888 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3889 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3890 C Derivatives in gamma(i+1)
3891 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3892 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3893 s2=scalar2(b1(1,iti1),auxvec(1))
3894 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3895 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3896 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3897 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3898 C Derivatives in gamma(i+2)
3899 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3900 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3901 s1=scalar2(b1(1,iti2),auxvec(1))
3902 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3903 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3904 s2=scalar2(b1(1,iti1),auxvec(1))
3905 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3906 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3907 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3908 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3909 C Cartesian derivatives
3910 C Derivatives of this turn contributions in DC(i+2)
3911 if (j.lt.nres-1) then
3913 a_temp(1,1)=agg(l,1)
3914 a_temp(1,2)=agg(l,2)
3915 a_temp(2,1)=agg(l,3)
3916 a_temp(2,2)=agg(l,4)
3917 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3918 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3919 s1=scalar2(b1(1,iti2),auxvec(1))
3920 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3921 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3922 s2=scalar2(b1(1,iti1),auxvec(1))
3923 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3924 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3925 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3927 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3930 C Remaining derivatives of this turn contribution
3932 a_temp(1,1)=aggi(l,1)
3933 a_temp(1,2)=aggi(l,2)
3934 a_temp(2,1)=aggi(l,3)
3935 a_temp(2,2)=aggi(l,4)
3936 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3937 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3938 s1=scalar2(b1(1,iti2),auxvec(1))
3939 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3940 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3941 s2=scalar2(b1(1,iti1),auxvec(1))
3942 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3943 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3944 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3945 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3946 a_temp(1,1)=aggi1(l,1)
3947 a_temp(1,2)=aggi1(l,2)
3948 a_temp(2,1)=aggi1(l,3)
3949 a_temp(2,2)=aggi1(l,4)
3950 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3951 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3952 s1=scalar2(b1(1,iti2),auxvec(1))
3953 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3954 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3955 s2=scalar2(b1(1,iti1),auxvec(1))
3956 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3957 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3958 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3959 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3960 a_temp(1,1)=aggj(l,1)
3961 a_temp(1,2)=aggj(l,2)
3962 a_temp(2,1)=aggj(l,3)
3963 a_temp(2,2)=aggj(l,4)
3964 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3965 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3966 s1=scalar2(b1(1,iti2),auxvec(1))
3967 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3968 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3969 s2=scalar2(b1(1,iti1),auxvec(1))
3970 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3971 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3972 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3973 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3974 a_temp(1,1)=aggj1(l,1)
3975 a_temp(1,2)=aggj1(l,2)
3976 a_temp(2,1)=aggj1(l,3)
3977 a_temp(2,2)=aggj1(l,4)
3978 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3979 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3980 s1=scalar2(b1(1,iti2),auxvec(1))
3981 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3982 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3983 s2=scalar2(b1(1,iti1),auxvec(1))
3984 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3985 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3986 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3987 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3988 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3992 C-----------------------------------------------------------------------------
3993 subroutine vecpr(u,v,w)
3994 implicit real*8(a-h,o-z)
3995 dimension u(3),v(3),w(3)
3996 w(1)=u(2)*v(3)-u(3)*v(2)
3997 w(2)=-u(1)*v(3)+u(3)*v(1)
3998 w(3)=u(1)*v(2)-u(2)*v(1)
4001 C-----------------------------------------------------------------------------
4002 subroutine unormderiv(u,ugrad,unorm,ungrad)
4003 C This subroutine computes the derivatives of a normalized vector u, given
4004 C the derivatives computed without normalization conditions, ugrad. Returns
4007 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4008 double precision vec(3)
4009 double precision scalar
4011 c write (2,*) 'ugrad',ugrad
4014 vec(i)=scalar(ugrad(1,i),u(1))
4016 c write (2,*) 'vec',vec
4019 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4022 c write (2,*) 'ungrad',ungrad
4025 C-----------------------------------------------------------------------------
4026 subroutine escp_soft_sphere(evdw2,evdw2_14)
4028 C This subroutine calculates the excluded-volume interaction energy between
4029 C peptide-group centers and side chains and its gradient in virtual-bond and
4030 C side-chain vectors.
4032 implicit real*8 (a-h,o-z)
4033 include 'DIMENSIONS'
4034 include 'COMMON.GEO'
4035 include 'COMMON.VAR'
4036 include 'COMMON.LOCAL'
4037 include 'COMMON.CHAIN'
4038 include 'COMMON.DERIV'
4039 include 'COMMON.INTERACT'
4040 include 'COMMON.FFIELD'
4041 include 'COMMON.IOUNITS'
4042 include 'COMMON.CONTROL'
4047 cd print '(a)','Enter ESCP'
4048 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4052 do i=iatscp_s,iatscp_e
4053 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4055 xi=0.5D0*(c(1,i)+c(1,i+1))
4056 yi=0.5D0*(c(2,i)+c(2,i+1))
4057 zi=0.5D0*(c(3,i)+c(3,i+1))
4058 C Return atom into box, boxxsize is size of box in x dimension
4060 if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4061 if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4062 C Condition for being inside the proper box
4063 if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4064 & (xi.lt.((xshift-0.5d0)*boxxsize))) then
4068 if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4069 if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4070 C Condition for being inside the proper box
4071 if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4072 & (yi.lt.((yshift-0.5d0)*boxysize))) then
4076 if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4077 if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4078 C Condition for being inside the proper box
4079 if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4080 & (zi.lt.((zshift-0.5d0)*boxzsize))) then
4083 do iint=1,nscp_gr(i)
4085 do j=iscpstart(i,iint),iscpend(i,iint)
4086 if (itype(j).eq.ntyp1) cycle
4087 itypj=iabs(itype(j))
4088 C Uncomment following three lines for SC-p interactions
4092 C Uncomment following three lines for Ca-p interactions
4097 if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4098 if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4099 C Condition for being inside the proper box
4100 if ((xj.gt.((0.5d0)*boxxsize)).or.
4101 & (xj.lt.((-0.5d0)*boxxsize))) then
4105 if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4106 if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4107 C Condition for being inside the proper box
4108 if ((yj.gt.((0.5d0)*boxysize)).or.
4109 & (yj.lt.((-0.5d0)*boxysize))) then
4113 if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4114 if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4115 C Condition for being inside the proper box
4116 if ((zj.gt.((0.5d0)*boxzsize)).or.
4117 & (zj.lt.((-0.5d0)*boxzsize))) then
4123 rij=xj*xj+yj*yj+zj*zj
4127 if (rij.lt.r0ijsq) then
4128 evdwij=0.25d0*(rij-r0ijsq)**2
4136 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4141 cgrad if (j.lt.i) then
4142 cd write (iout,*) 'j<i'
4143 C Uncomment following three lines for SC-p interactions
4145 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4148 cd write (iout,*) 'j>i'
4150 cgrad ggg(k)=-ggg(k)
4151 C Uncomment following line for SC-p interactions
4152 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4156 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4158 cgrad kstart=min0(i+1,j)
4159 cgrad kend=max0(i-1,j-1)
4160 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4161 cd write (iout,*) ggg(1),ggg(2),ggg(3)
4162 cgrad do k=kstart,kend
4164 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4168 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4169 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4180 C-----------------------------------------------------------------------------
4181 subroutine escp(evdw2,evdw2_14)
4183 C This subroutine calculates the excluded-volume interaction energy between
4184 C peptide-group centers and side chains and its gradient in virtual-bond and
4185 C side-chain vectors.
4187 implicit real*8 (a-h,o-z)
4188 include 'DIMENSIONS'
4189 include 'COMMON.GEO'
4190 include 'COMMON.VAR'
4191 include 'COMMON.LOCAL'
4192 include 'COMMON.CHAIN'
4193 include 'COMMON.DERIV'
4194 include 'COMMON.INTERACT'
4195 include 'COMMON.FFIELD'
4196 include 'COMMON.IOUNITS'
4197 include 'COMMON.CONTROL'
4198 include 'COMMON.SPLITELE'
4202 cd print '(a)','Enter ESCP'
4203 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4207 do i=iatscp_s,iatscp_e
4208 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
4210 xi=0.5D0*(c(1,i)+c(1,i+1))
4211 yi=0.5D0*(c(2,i)+c(2,i+1))
4212 zi=0.5D0*(c(3,i)+c(3,i+1))
4213 C Return atom into box, boxxsize is size of box in x dimension
4215 if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
4216 if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
4217 C Condition for being inside the proper box
4218 if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
4219 & (xi.lt.((xshift-0.5d0)*boxxsize))) then
4223 if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
4224 if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
4225 C Condition for being inside the proper box
4226 if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
4227 & (yi.lt.((yshift-0.5d0)*boxysize))) then
4231 if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
4232 if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
4233 C Condition for being inside the proper box
4234 if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
4235 & (zi.lt.((zshift-0.5d0)*boxzsize))) then
4238 do iint=1,nscp_gr(i)
4240 do j=iscpstart(i,iint),iscpend(i,iint)
4241 itypj=iabs(itype(j))
4242 if (itypj.eq.ntyp1) cycle
4243 C Uncomment following three lines for SC-p interactions
4247 C Uncomment following three lines for Ca-p interactions
4252 if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
4253 if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
4254 C Condition for being inside the proper box
4255 if ((xj.gt.((0.5d0)*boxxsize)).or.
4256 & (xj.lt.((-0.5d0)*boxxsize))) then
4260 if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
4261 if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
4262 C Condition for being inside the proper box
4263 if ((yj.gt.((0.5d0)*boxysize)).or.
4264 & (yj.lt.((-0.5d0)*boxysize))) then
4268 if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
4269 if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
4270 C Condition for being inside the proper box
4271 if ((zj.gt.((0.5d0)*boxzsize)).or.
4272 & (zj.lt.((-0.5d0)*boxzsize))) then
4278 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4279 sss=sscale(1.0d0/(dsqrt(rrij)))
4280 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
4281 if (sss.gt.0.0d0) then
4283 e1=fac*fac*aad(itypj,iteli)
4284 e2=fac*bad(itypj,iteli)
4285 if (iabs(j-i) .le. 2) then
4288 evdw2_14=evdw2_14+(e1+e2)*sss
4291 evdw2=evdw2+evdwij*sss
4292 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4293 & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4296 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4298 fac=-(evdwij+e1)*rrij*sss
4299 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4303 cgrad if (j.lt.i) then
4304 cd write (iout,*) 'j<i'
4305 C Uncomment following three lines for SC-p interactions
4307 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4310 cd write (iout,*) 'j>i'
4312 cgrad ggg(k)=-ggg(k)
4313 C Uncomment following line for SC-p interactions
4314 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4315 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4319 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4321 cgrad kstart=min0(i+1,j)
4322 cgrad kend=max0(i-1,j-1)
4323 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4324 cd write (iout,*) ggg(1),ggg(2),ggg(3)
4325 cgrad do k=kstart,kend
4327 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4331 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4332 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4334 endif !endif for sscale cutoff
4344 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4345 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4346 gradx_scp(j,i)=expon*gradx_scp(j,i)
4349 C******************************************************************************
4353 C To save time the factor EXPON has been extracted from ALL components
4354 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4357 C******************************************************************************
4360 C--------------------------------------------------------------------------
4361 subroutine edis(ehpb)
4363 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4365 implicit real*8 (a-h,o-z)
4366 include 'DIMENSIONS'
4367 include 'COMMON.SBRIDGE'
4368 include 'COMMON.CHAIN'
4369 include 'COMMON.DERIV'
4370 include 'COMMON.VAR'
4371 include 'COMMON.INTERACT'
4372 include 'COMMON.IOUNITS'
4375 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4376 cd write(iout,*)'link_start=',link_start,' link_end=',link_end
4377 if (link_end.eq.0) return
4378 do i=link_start,link_end
4379 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4380 C CA-CA distance used in regularization of structure.
4383 C iii and jjj point to the residues for which the distance is assigned.
4384 if (ii.gt.nres) then
4391 cd write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4392 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4393 C distance and angle dependent SS bond potential.
4394 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4395 & iabs(itype(jjj)).eq.1) then
4396 call ssbond_ene(iii,jjj,eij)
4398 cd write (iout,*) "eij",eij
4400 C Calculate the distance between the two points and its difference from the
4404 C Get the force constant corresponding to this distance.
4406 C Calculate the contribution to energy.
4407 ehpb=ehpb+waga*rdis*rdis
4409 C Evaluate gradient.
4412 cd print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4413 cd & ' waga=',waga,' fac=',fac
4415 ggg(j)=fac*(c(j,jj)-c(j,ii))
4417 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4418 C If this is a SC-SC distance, we need to calculate the contributions to the
4419 C Cartesian gradient in the SC vectors (ghpbx).
4422 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4423 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4426 cgrad do j=iii,jjj-1
4428 cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4432 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4433 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4440 C--------------------------------------------------------------------------
4441 subroutine ssbond_ene(i,j,eij)
4443 C Calculate the distance and angle dependent SS-bond potential energy
4444 C using a free-energy function derived based on RHF/6-31G** ab initio
4445 C calculations of diethyl disulfide.
4447 C A. Liwo and U. Kozlowska, 11/24/03
4449 implicit real*8 (a-h,o-z)
4450 include 'DIMENSIONS'
4451 include 'COMMON.SBRIDGE'
4452 include 'COMMON.CHAIN'
4453 include 'COMMON.DERIV'
4454 include 'COMMON.LOCAL'
4455 include 'COMMON.INTERACT'
4456 include 'COMMON.VAR'
4457 include 'COMMON.IOUNITS'
4458 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4459 itypi=iabs(itype(i))
4463 dxi=dc_norm(1,nres+i)
4464 dyi=dc_norm(2,nres+i)
4465 dzi=dc_norm(3,nres+i)
4466 c dsci_inv=dsc_inv(itypi)
4467 dsci_inv=vbld_inv(nres+i)
4468 itypj=iabs(itype(j))
4469 c dscj_inv=dsc_inv(itypj)
4470 dscj_inv=vbld_inv(nres+j)
4474 dxj=dc_norm(1,nres+j)
4475 dyj=dc_norm(2,nres+j)
4476 dzj=dc_norm(3,nres+j)
4477 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4482 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4483 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4484 om12=dxi*dxj+dyi*dyj+dzi*dzj
4486 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4487 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4493 deltat12=om2-om1+2.0d0
4495 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4496 & +akct*deltad*deltat12
4497 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4498 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4499 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4500 c & " deltat12",deltat12," eij",eij
4501 ed=2*akcm*deltad+akct*deltat12
4503 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4504 eom1=-2*akth*deltat1-pom1-om2*pom2
4505 eom2= 2*akth*deltat2+pom1-om1*pom2
4508 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4509 ghpbx(k,i)=ghpbx(k,i)-ggk
4510 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4511 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4512 ghpbx(k,j)=ghpbx(k,j)+ggk
4513 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4514 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4515 ghpbc(k,i)=ghpbc(k,i)-ggk
4516 ghpbc(k,j)=ghpbc(k,j)+ggk
4519 C Calculate the components of the gradient in DC and X
4523 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
4528 C--------------------------------------------------------------------------
4529 subroutine ebond(estr)
4531 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4533 implicit real*8 (a-h,o-z)
4534 include 'DIMENSIONS'
4535 include 'COMMON.LOCAL'
4536 include 'COMMON.GEO'
4537 include 'COMMON.INTERACT'
4538 include 'COMMON.DERIV'
4539 include 'COMMON.VAR'
4540 include 'COMMON.CHAIN'
4541 include 'COMMON.IOUNITS'
4542 include 'COMMON.NAMES'
4543 include 'COMMON.FFIELD'
4544 include 'COMMON.CONTROL'
4545 include 'COMMON.SETUP'
4546 double precision u(3),ud(3)
4549 do i=ibondp_start,ibondp_end
4550 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4551 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4553 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4554 c & *dc(j,i-1)/vbld(i)
4556 c if (energy_dec) write(iout,*)
4557 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4559 C Checking if it involves dummy (NH3+ or COO-) group
4560 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4561 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
4562 diff = vbld(i)-vbldpDUM
4564 C NO vbldp0 is the equlibrium lenght of spring for peptide group
4565 diff = vbld(i)-vbldp0
4567 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4568 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4571 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4573 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4576 estr=0.5d0*AKP*estr+estr1
4578 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4580 do i=ibond_start,ibond_end
4582 if (iti.ne.10 .and. iti.ne.ntyp1) then
4585 diff=vbld(i+nres)-vbldsc0(1,iti)
4586 if (energy_dec) write (iout,*)
4587 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4588 & AKSC(1,iti),AKSC(1,iti)*diff*diff
4589 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4591 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4595 diff=vbld(i+nres)-vbldsc0(j,iti)
4596 ud(j)=aksc(j,iti)*diff
4597 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4611 uprod2=uprod2*u(k)*u(k)
4615 usumsqder=usumsqder+ud(j)*uprod2
4617 estr=estr+uprod/usum
4619 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4627 C--------------------------------------------------------------------------
4628 subroutine ebend(etheta)
4630 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4631 C angles gamma and its derivatives in consecutive thetas and gammas.
4633 implicit real*8 (a-h,o-z)
4634 include 'DIMENSIONS'
4635 include 'COMMON.LOCAL'
4636 include 'COMMON.GEO'
4637 include 'COMMON.INTERACT'
4638 include 'COMMON.DERIV'
4639 include 'COMMON.VAR'
4640 include 'COMMON.CHAIN'
4641 include 'COMMON.IOUNITS'
4642 include 'COMMON.NAMES'
4643 include 'COMMON.FFIELD'
4644 include 'COMMON.CONTROL'
4645 common /calcthet/ term1,term2,termm,diffak,ratak,
4646 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4647 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4648 double precision y(2),z(2)
4650 c time11=dexp(-2*time)
4653 c write (*,'(a,i2)') 'EBEND ICG=',icg
4654 do i=ithet_start,ithet_end
4655 print *,i,itype(i-1),itype(i),itype(i-2)
4656 if (itype(i-1).eq.ntyp1) cycle
4657 print *,'wchodze',itype(i-1)
4658 C Zero the energy function and its derivative at 0 or pi.
4659 call splinthet(theta(i),0.5d0*delta,ss,ssd)
4661 ichir1=isign(1,itype(i-2))
4662 ichir2=isign(1,itype(i))
4663 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4664 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4665 if (itype(i-1).eq.10) then
4666 itype1=isign(10,itype(i-2))
4667 ichir11=isign(1,itype(i-2))
4668 ichir12=isign(1,itype(i-2))
4669 itype2=isign(10,itype(i))
4670 ichir21=isign(1,itype(i))
4671 ichir22=isign(1,itype(i))
4674 if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4677 if (phii.ne.phii) phii=150.0
4687 if (i.lt.nres .and. itype(i).ne.ntyp1) then
4690 if (phii1.ne.phii1) phii1=150.0
4702 C Calculate the "mean" value of theta from the part of the distribution
4703 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4704 C In following comments this theta will be referred to as t_c.
4705 thet_pred_mean=0.0d0
4707 athetk=athet(k,it,ichir1,ichir2)
4708 bthetk=bthet(k,it,ichir1,ichir2)
4710 athetk=athet(k,itype1,ichir11,ichir12)
4711 bthetk=bthet(k,itype2,ichir21,ichir22)
4713 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4714 c write(iout,*) 'chuj tu', y(k),z(k)
4716 dthett=thet_pred_mean*ssd
4717 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4718 C Derivatives of the "mean" values in gamma1 and gamma2.
4719 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4720 &+athet(2,it,ichir1,ichir2)*y(1))*ss
4721 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4722 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
4724 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4725 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4726 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4727 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4729 if (theta(i).gt.pi-delta) then
4730 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4732 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4733 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4734 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4736 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4738 else if (theta(i).lt.delta) then
4739 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4740 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4741 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4743 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4744 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4747 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4750 etheta=etheta+ethetai
4751 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4752 & 'ebend',i,ethetai,theta(i),itype(i)
4753 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4754 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4755 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4757 C Ufff.... We've done all this!!!
4760 C---------------------------------------------------------------------------
4761 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4763 implicit real*8 (a-h,o-z)
4764 include 'DIMENSIONS'
4765 include 'COMMON.LOCAL'
4766 include 'COMMON.IOUNITS'
4767 common /calcthet/ term1,term2,termm,diffak,ratak,
4768 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4769 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4770 C Calculate the contributions to both Gaussian lobes.
4771 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4772 C The "polynomial part" of the "standard deviation" of this part of
4773 C the distributioni.
4774 ccc write (iout,*) thetai,thet_pred_mean
4777 sig=sig*thet_pred_mean+polthet(j,it)
4779 C Derivative of the "interior part" of the "standard deviation of the"
4780 C gamma-dependent Gaussian lobe in t_c.
4781 sigtc=3*polthet(3,it)
4783 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4786 C Set the parameters of both Gaussian lobes of the distribution.
4787 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4788 fac=sig*sig+sigc0(it)
4791 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4792 sigsqtc=-4.0D0*sigcsq*sigtc
4793 c print *,i,sig,sigtc,sigsqtc
4794 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4795 sigtc=-sigtc/(fac*fac)
4796 C Following variable is sigma(t_c)**(-2)
4797 sigcsq=sigcsq*sigcsq
4799 sig0inv=1.0D0/sig0i**2
4800 delthec=thetai-thet_pred_mean
4801 delthe0=thetai-theta0i
4802 term1=-0.5D0*sigcsq*delthec*delthec
4803 term2=-0.5D0*sig0inv*delthe0*delthe0
4804 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
4805 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4806 C NaNs in taking the logarithm. We extract the largest exponent which is added
4807 C to the energy (this being the log of the distribution) at the end of energy
4808 C term evaluation for this virtual-bond angle.
4809 if (term1.gt.term2) then
4811 term2=dexp(term2-termm)
4815 term1=dexp(term1-termm)
4818 C The ratio between the gamma-independent and gamma-dependent lobes of
4819 C the distribution is a Gaussian function of thet_pred_mean too.
4820 diffak=gthet(2,it)-thet_pred_mean
4821 ratak=diffak/gthet(3,it)**2
4822 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4823 C Let's differentiate it in thet_pred_mean NOW.
4825 C Now put together the distribution terms to make complete distribution.
4826 termexp=term1+ak*term2
4827 termpre=sigc+ak*sig0i
4828 C Contribution of the bending energy from this theta is just the -log of
4829 C the sum of the contributions from the two lobes and the pre-exponential
4830 C factor. Simple enough, isn't it?
4831 ethetai=(-dlog(termexp)-termm+dlog(termpre))
4832 C write (iout,*) 'termexp',termexp,termm,termpre,i
4833 C NOW the derivatives!!!
4834 C 6/6/97 Take into account the deformation.
4835 E_theta=(delthec*sigcsq*term1
4836 & +ak*delthe0*sig0inv*term2)/termexp
4837 E_tc=((sigtc+aktc*sig0i)/termpre
4838 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4839 & aktc*term2)/termexp)
4842 c-----------------------------------------------------------------------------
4843 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4844 implicit real*8 (a-h,o-z)
4845 include 'DIMENSIONS'
4846 include 'COMMON.LOCAL'
4847 include 'COMMON.IOUNITS'
4848 common /calcthet/ term1,term2,termm,diffak,ratak,
4849 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4850 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4851 delthec=thetai-thet_pred_mean
4852 delthe0=thetai-theta0i
4853 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4854 t3 = thetai-thet_pred_mean
4858 t14 = t12+t6*sigsqtc
4860 t21 = thetai-theta0i
4866 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4867 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4868 & *(-t12*t9-ak*sig0inv*t27)
4872 C--------------------------------------------------------------------------
4873 subroutine ebend(etheta)
4875 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4876 C angles gamma and its derivatives in consecutive thetas and gammas.
4877 C ab initio-derived potentials from
4878 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4880 implicit real*8 (a-h,o-z)
4881 include 'DIMENSIONS'
4882 include 'COMMON.LOCAL'
4883 include 'COMMON.GEO'
4884 include 'COMMON.INTERACT'
4885 include 'COMMON.DERIV'
4886 include 'COMMON.VAR'
4887 include 'COMMON.CHAIN'
4888 include 'COMMON.IOUNITS'
4889 include 'COMMON.NAMES'
4890 include 'COMMON.FFIELD'
4891 include 'COMMON.CONTROL'
4892 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4893 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4894 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4895 & sinph1ph2(maxdouble,maxdouble)
4896 logical lprn /.false./, lprn1 /.false./
4898 do i=ithet_start,ithet_end
4899 c print *,i,itype(i-1),itype(i),itype(i-2)
4900 if ((itype(i-1).eq.ntyp1)) cycle
4901 if (iabs(itype(i+1)).eq.20) iblock=2
4902 if (iabs(itype(i+1)).ne.20) iblock=1
4906 theti2=0.5d0*theta(i)
4907 ityp2=ithetyp((itype(i-1)))
4909 coskt(k)=dcos(k*theti2)
4910 sinkt(k)=dsin(k*theti2)
4912 if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4915 if (phii.ne.phii) phii=150.0
4919 ityp1=ithetyp((itype(i-2)))
4920 C propagation of chirality for glycine type
4922 cosph1(k)=dcos(k*phii)
4923 sinph1(k)=dsin(k*phii)
4933 if (i.lt.nres .and. itype(i).ne.ntyp1) then
4936 if (phii1.ne.phii1) phii1=150.0
4941 ityp3=ithetyp((itype(i)))
4943 cosph2(k)=dcos(k*phii1)
4944 sinph2(k)=dsin(k*phii1)
4954 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4957 ccl=cosph1(l)*cosph2(k-l)
4958 ssl=sinph1(l)*sinph2(k-l)
4959 scl=sinph1(l)*cosph2(k-l)
4960 csl=cosph1(l)*sinph2(k-l)
4961 cosph1ph2(l,k)=ccl-ssl
4962 cosph1ph2(k,l)=ccl+ssl
4963 sinph1ph2(l,k)=scl+csl
4964 sinph1ph2(k,l)=scl-csl
4968 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4969 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4970 write (iout,*) "coskt and sinkt"
4972 write (iout,*) k,coskt(k),sinkt(k)
4976 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4977 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4980 & write (iout,*) "k",k,"
4981 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4982 & " ethetai",ethetai
4985 write (iout,*) "cosph and sinph"
4987 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4989 write (iout,*) "cosph1ph2 and sinph2ph2"
4992 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4993 & sinph1ph2(l,k),sinph1ph2(k,l)
4996 write(iout,*) "ethetai",ethetai
5000 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5001 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5002 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5003 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5004 ethetai=ethetai+sinkt(m)*aux
5005 dethetai=dethetai+0.5d0*m*aux*coskt(m)
5006 dephii=dephii+k*sinkt(m)*(
5007 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5008 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5009 dephii1=dephii1+k*sinkt(m)*(
5010 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5011 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5013 & write (iout,*) "m",m," k",k," bbthet",
5014 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5015 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5016 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5017 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5021 & write(iout,*) "ethetai",ethetai
5025 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5026 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5027 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5028 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5029 ethetai=ethetai+sinkt(m)*aux
5030 dethetai=dethetai+0.5d0*m*coskt(m)*aux
5031 dephii=dephii+l*sinkt(m)*(
5032 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5033 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5034 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5035 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5036 dephii1=dephii1+(k-l)*sinkt(m)*(
5037 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5038 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5039 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5040 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5042 write (iout,*) "m",m," k",k," l",l," ffthet",
5043 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5044 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5045 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5046 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5047 & " ethetai",ethetai
5048 write (iout,*) cosph1ph2(l,k)*sinkt(m),
5049 & cosph1ph2(k,l)*sinkt(m),
5050 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5058 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5059 & i,theta(i)*rad2deg,phii*rad2deg,
5060 & phii1*rad2deg,ethetai
5062 etheta=etheta+ethetai
5063 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5064 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5065 gloc(nphi+i-2,icg)=wang*dethetai+ gloc(nphi+i-2,icg)
5071 c-----------------------------------------------------------------------------
5072 subroutine esc(escloc)
5073 C Calculate the local energy of a side chain and its derivatives in the
5074 C corresponding virtual-bond valence angles THETA and the spherical angles
5076 implicit real*8 (a-h,o-z)
5077 include 'DIMENSIONS'
5078 include 'COMMON.GEO'
5079 include 'COMMON.LOCAL'
5080 include 'COMMON.VAR'
5081 include 'COMMON.INTERACT'
5082 include 'COMMON.DERIV'
5083 include 'COMMON.CHAIN'
5084 include 'COMMON.IOUNITS'
5085 include 'COMMON.NAMES'
5086 include 'COMMON.FFIELD'
5087 include 'COMMON.CONTROL'
5088 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5089 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
5090 common /sccalc/ time11,time12,time112,theti,it,nlobit
5093 c write (iout,'(a)') 'ESC'
5094 do i=loc_start,loc_end
5096 if (it.eq.ntyp1) cycle
5097 if (it.eq.10) goto 1
5098 nlobit=nlob(iabs(it))
5099 c print *,'i=',i,' it=',it,' nlobit=',nlobit
5100 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5101 theti=theta(i+1)-pipol
5106 if (x(2).gt.pi-delta) then
5110 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5112 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5113 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5115 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5116 & ddersc0(1),dersc(1))
5117 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5118 & ddersc0(3),dersc(3))
5120 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5122 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5123 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5124 & dersc0(2),esclocbi,dersc02)
5125 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5127 call splinthet(x(2),0.5d0*delta,ss,ssd)
5132 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5134 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5135 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5137 escloci=ss*escloci+(1.0d0-ss)*esclocbi
5139 c write (iout,*) escloci
5140 else if (x(2).lt.delta) then
5144 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5146 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5147 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5149 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5150 & ddersc0(1),dersc(1))
5151 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5152 & ddersc0(3),dersc(3))
5154 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5156 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5157 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5158 & dersc0(2),esclocbi,dersc02)
5159 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5164 call splinthet(x(2),0.5d0*delta,ss,ssd)
5166 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5168 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5169 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5171 escloci=ss*escloci+(1.0d0-ss)*esclocbi
5172 c write (iout,*) escloci
5174 call enesc(x,escloci,dersc,ddummy,.false.)
5177 escloc=escloc+escloci
5178 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5179 & 'escloc',i,escloci
5180 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5182 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5184 gloc(ialph(i,1),icg)=wscloc*dersc(2)
5185 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5190 C---------------------------------------------------------------------------
5191 subroutine enesc(x,escloci,dersc,ddersc,mixed)
5192 implicit real*8 (a-h,o-z)
5193 include 'DIMENSIONS'
5194 include 'COMMON.GEO'
5195 include 'COMMON.LOCAL'
5196 include 'COMMON.IOUNITS'
5197 common /sccalc/ time11,time12,time112,theti,it,nlobit
5198 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5199 double precision contr(maxlob,-1:1)
5201 c write (iout,*) 'it=',it,' nlobit=',nlobit
5205 if (mixed) ddersc(j)=0.0d0
5209 C Because of periodicity of the dependence of the SC energy in omega we have
5210 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5211 C To avoid underflows, first compute & store the exponents.
5219 z(k)=x(k)-censc(k,j,it)
5224 Axk=Axk+gaussc(l,k,j,it)*z(l)
5230 expfac=expfac+Ax(k,j,iii)*z(k)
5238 C As in the case of ebend, we want to avoid underflows in exponentiation and
5239 C subsequent NaNs and INFs in energy calculation.
5240 C Find the largest exponent
5244 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5248 cd print *,'it=',it,' emin=',emin
5250 C Compute the contribution to SC energy and derivatives
5255 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5256 if(adexp.ne.adexp) adexp=1.0
5259 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5261 cd print *,'j=',j,' expfac=',expfac
5262 escloc_i=escloc_i+expfac
5264 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5268 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5269 & +gaussc(k,2,j,it))*expfac
5276 dersc(1)=dersc(1)/cos(theti)**2
5277 ddersc(1)=ddersc(1)/cos(theti)**2
5280 escloci=-(dlog(escloc_i)-emin)
5282 dersc(j)=dersc(j)/escloc_i
5286 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5291 C------------------------------------------------------------------------------
5292 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5293 implicit real*8 (a-h,o-z)
5294 include 'DIMENSIONS'
5295 include 'COMMON.GEO'
5296 include 'COMMON.LOCAL'
5297 include 'COMMON.IOUNITS'
5298 common /sccalc/ time11,time12,time112,theti,it,nlobit
5299 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5300 double precision contr(maxlob)
5311 z(k)=x(k)-censc(k,j,it)
5317 Axk=Axk+gaussc(l,k,j,it)*z(l)
5323 expfac=expfac+Ax(k,j)*z(k)
5328 C As in the case of ebend, we want to avoid underflows in exponentiation and
5329 C subsequent NaNs and INFs in energy calculation.
5330 C Find the largest exponent
5333 if (emin.gt.contr(j)) emin=contr(j)
5337 C Compute the contribution to SC energy and derivatives
5341 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5342 escloc_i=escloc_i+expfac
5344 dersc(k)=dersc(k)+Ax(k,j)*expfac
5346 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5347 & +gaussc(1,2,j,it))*expfac
5351 dersc(1)=dersc(1)/cos(theti)**2
5352 dersc12=dersc12/cos(theti)**2
5353 escloci=-(dlog(escloc_i)-emin)
5355 dersc(j)=dersc(j)/escloc_i
5357 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5361 c----------------------------------------------------------------------------------
5362 subroutine esc(escloc)
5363 C Calculate the local energy of a side chain and its derivatives in the
5364 C corresponding virtual-bond valence angles THETA and the spherical angles
5365 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5366 C added by Urszula Kozlowska. 07/11/2007
5368 implicit real*8 (a-h,o-z)
5369 include 'DIMENSIONS'
5370 include 'COMMON.GEO'
5371 include 'COMMON.LOCAL'
5372 include 'COMMON.VAR'
5373 include 'COMMON.SCROT'
5374 include 'COMMON.INTERACT'
5375 include 'COMMON.DERIV'
5376 include 'COMMON.CHAIN'
5377 include 'COMMON.IOUNITS'
5378 include 'COMMON.NAMES'
5379 include 'COMMON.FFIELD'
5380 include 'COMMON.CONTROL'
5381 include 'COMMON.VECTORS'
5382 double precision x_prime(3),y_prime(3),z_prime(3)
5383 & , sumene,dsc_i,dp2_i,x(65),
5384 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5385 & de_dxx,de_dyy,de_dzz,de_dt
5386 double precision s1_t,s1_6_t,s2_t,s2_6_t
5388 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5389 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5390 & dt_dCi(3),dt_dCi1(3)
5391 common /sccalc/ time11,time12,time112,theti,it,nlobit
5394 do i=loc_start,loc_end
5395 if (itype(i).eq.ntyp1) cycle
5396 costtab(i+1) =dcos(theta(i+1))
5397 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5398 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5399 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5400 cosfac2=0.5d0/(1.0d0+costtab(i+1))
5401 cosfac=dsqrt(cosfac2)
5402 sinfac2=0.5d0/(1.0d0-costtab(i+1))
5403 sinfac=dsqrt(sinfac2)
5405 if (it.eq.10) goto 1
5407 C Compute the axes of tghe local cartesian coordinates system; store in
5408 c x_prime, y_prime and z_prime
5415 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5416 C & dc_norm(3,i+nres)
5418 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5419 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5422 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5425 c write (2,*) "x_prime",(x_prime(j),j=1,3)
5426 c write (2,*) "y_prime",(y_prime(j),j=1,3)
5427 c write (2,*) "z_prime",(z_prime(j),j=1,3)
5428 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5429 c & " xy",scalar(x_prime(1),y_prime(1)),
5430 c & " xz",scalar(x_prime(1),z_prime(1)),
5431 c & " yy",scalar(y_prime(1),y_prime(1)),
5432 c & " yz",scalar(y_prime(1),z_prime(1)),
5433 c & " zz",scalar(z_prime(1),z_prime(1))
5435 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5436 C to local coordinate system. Store in xx, yy, zz.
5442 xx = xx + x_prime(j)*dc_norm(j,i+nres)
5443 yy = yy + y_prime(j)*dc_norm(j,i+nres)
5444 zz = zz + z_prime(j)*dc_norm(j,i+nres)
5451 C Compute the energy of the ith side cbain
5453 c write (2,*) "xx",xx," yy",yy," zz",zz
5456 x(j) = sc_parmin(j,it)
5459 Cc diagnostics - remove later
5461 yy1 = dsin(alph(2))*dcos(omeg(2))
5462 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5463 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5464 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5466 C," --- ", xx_w,yy_w,zz_w
5469 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
5470 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
5472 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5473 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5475 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5476 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5477 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5478 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5479 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5481 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5482 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5483 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5484 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5485 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5487 dsc_i = 0.743d0+x(61)
5489 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5490 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5491 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5492 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5493 s1=(1+x(63))/(0.1d0 + dscp1)
5494 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5495 s2=(1+x(65))/(0.1d0 + dscp2)
5496 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5497 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5498 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5499 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5501 c & dscp1,dscp2,sumene
5502 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5503 escloc = escloc + sumene
5504 c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5509 C This section to check the numerical derivatives of the energy of ith side
5510 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5511 C #define DEBUG in the code to turn it on.
5513 write (2,*) "sumene =",sumene
5517 write (2,*) xx,yy,zz
5518 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5519 de_dxx_num=(sumenep-sumene)/aincr
5521 write (2,*) "xx+ sumene from enesc=",sumenep
5524 write (2,*) xx,yy,zz
5525 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5526 de_dyy_num=(sumenep-sumene)/aincr
5528 write (2,*) "yy+ sumene from enesc=",sumenep
5531 write (2,*) xx,yy,zz
5532 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5533 de_dzz_num=(sumenep-sumene)/aincr
5535 write (2,*) "zz+ sumene from enesc=",sumenep
5536 costsave=cost2tab(i+1)
5537 sintsave=sint2tab(i+1)
5538 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5539 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5540 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5541 de_dt_num=(sumenep-sumene)/aincr
5542 write (2,*) " t+ sumene from enesc=",sumenep
5543 cost2tab(i+1)=costsave
5544 sint2tab(i+1)=sintsave
5545 C End of diagnostics section.
5548 C Compute the gradient of esc
5550 c zz=zz*dsign(1.0,dfloat(itype(i)))
5551 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5552 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5553 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5554 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5555 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5556 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5557 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5558 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5559 pom1=(sumene3*sint2tab(i+1)+sumene1)
5560 & *(pom_s1/dscp1+pom_s16*dscp1**4)
5561 pom2=(sumene4*cost2tab(i+1)+sumene2)
5562 & *(pom_s2/dscp2+pom_s26*dscp2**4)
5563 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5564 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5565 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5567 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5568 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5569 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5571 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5572 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5573 & +(pom1+pom2)*pom_dx
5575 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5578 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5579 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5580 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5582 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5583 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5584 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5585 & +x(59)*zz**2 +x(60)*xx*zz
5586 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5587 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5588 & +(pom1-pom2)*pom_dy
5590 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5593 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5594 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5595 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5596 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
5597 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
5598 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5599 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5600 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
5602 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5605 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5606 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5607 & +pom1*pom_dt1+pom2*pom_dt2
5609 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5614 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5615 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5616 cosfac2xx=cosfac2*xx
5617 sinfac2yy=sinfac2*yy
5619 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5621 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5623 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5624 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5625 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5626 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5627 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5628 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5629 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5630 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5631 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5632 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5636 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5637 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5638 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5639 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5642 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5643 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5644 dZZ_XYZ(k)=vbld_inv(i+nres)*
5645 & (z_prime(k)-zz*dC_norm(k,i+nres))
5647 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5648 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5652 dXX_Ctab(k,i)=dXX_Ci(k)
5653 dXX_C1tab(k,i)=dXX_Ci1(k)
5654 dYY_Ctab(k,i)=dYY_Ci(k)
5655 dYY_C1tab(k,i)=dYY_Ci1(k)
5656 dZZ_Ctab(k,i)=dZZ_Ci(k)
5657 dZZ_C1tab(k,i)=dZZ_Ci1(k)
5658 dXX_XYZtab(k,i)=dXX_XYZ(k)
5659 dYY_XYZtab(k,i)=dYY_XYZ(k)
5660 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5664 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5665 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5666 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5667 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
5668 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5670 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5671 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5672 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5673 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5674 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5675 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5676 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
5677 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5679 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5680 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5682 C to check gradient call subroutine check_grad
5688 c------------------------------------------------------------------------------
5689 double precision function enesc(x,xx,yy,zz,cost2,sint2)
5691 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5692 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5693 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
5694 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
5696 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5697 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5699 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5700 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5701 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5702 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5703 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5705 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5706 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5707 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5708 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5709 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5711 dsc_i = 0.743d0+x(61)
5713 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5714 & *(xx*cost2+yy*sint2))
5715 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5716 & *(xx*cost2-yy*sint2))
5717 s1=(1+x(63))/(0.1d0 + dscp1)
5718 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5719 s2=(1+x(65))/(0.1d0 + dscp2)
5720 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5721 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5722 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5727 c------------------------------------------------------------------------------
5728 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5730 C This procedure calculates two-body contact function g(rij) and its derivative:
5733 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
5736 C where x=(rij-r0ij)/delta
5738 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5741 double precision rij,r0ij,eps0ij,fcont,fprimcont
5742 double precision x,x2,x4,delta
5746 if (x.lt.-1.0D0) then
5749 else if (x.le.1.0D0) then
5752 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5753 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5760 c------------------------------------------------------------------------------
5761 subroutine splinthet(theti,delta,ss,ssder)
5762 implicit real*8 (a-h,o-z)
5763 include 'DIMENSIONS'
5764 include 'COMMON.VAR'
5765 include 'COMMON.GEO'
5768 if (theti.gt.pipol) then
5769 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5771 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5776 c------------------------------------------------------------------------------
5777 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5779 double precision x,x0,delta,f0,f1,fprim0,f,fprim
5780 double precision ksi,ksi2,ksi3,a1,a2,a3
5781 a1=fprim0*delta/(f1-f0)
5787 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5788 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5791 c------------------------------------------------------------------------------
5792 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5794 double precision x,x0,delta,f0x,f1x,fprim0x,fx
5795 double precision ksi,ksi2,ksi3,a1,a2,a3
5800 a2=3*(f1x-f0x)-2*fprim0x*delta
5801 a3=fprim0x*delta-2*(f1x-f0x)
5802 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5805 C-----------------------------------------------------------------------------
5807 C-----------------------------------------------------------------------------
5808 subroutine etor(etors,edihcnstr)
5809 implicit real*8 (a-h,o-z)
5810 include 'DIMENSIONS'
5811 include 'COMMON.VAR'
5812 include 'COMMON.GEO'
5813 include 'COMMON.LOCAL'
5814 include 'COMMON.TORSION'
5815 include 'COMMON.INTERACT'
5816 include 'COMMON.DERIV'
5817 include 'COMMON.CHAIN'
5818 include 'COMMON.NAMES'
5819 include 'COMMON.IOUNITS'
5820 include 'COMMON.FFIELD'
5821 include 'COMMON.TORCNSTR'
5822 include 'COMMON.CONTROL'
5824 C Set lprn=.true. for debugging
5828 do i=iphi_start,iphi_end
5830 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5831 & .or. itype(i).eq.ntyp1) cycle
5832 itori=itortyp(itype(i-2))
5833 itori1=itortyp(itype(i-1))
5836 C Proline-Proline pair is a special case...
5837 if (itori.eq.3 .and. itori1.eq.3) then
5838 if (phii.gt.-dwapi3) then
5840 fac=1.0D0/(1.0D0-cosphi)
5841 etorsi=v1(1,3,3)*fac
5842 etorsi=etorsi+etorsi
5843 etors=etors+etorsi-v1(1,3,3)
5844 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5845 gloci=gloci-3*fac*etorsi*dsin(3*phii)
5848 v1ij=v1(j+1,itori,itori1)
5849 v2ij=v2(j+1,itori,itori1)
5852 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5853 if (energy_dec) etors_ii=etors_ii+
5854 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5855 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5859 v1ij=v1(j,itori,itori1)
5860 v2ij=v2(j,itori,itori1)
5863 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5864 if (energy_dec) etors_ii=etors_ii+
5865 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5866 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5869 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5872 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5873 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5874 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5875 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5876 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5878 ! 6/20/98 - dihedral angle constraints
5881 itori=idih_constr(i)
5884 if (difi.gt.drange(i)) then
5886 edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5887 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5888 else if (difi.lt.-drange(i)) then
5890 edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5891 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5893 ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5894 ! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5896 ! write (iout,*) 'edihcnstr',edihcnstr
5899 c------------------------------------------------------------------------------
5900 subroutine etor_d(etors_d)
5904 c----------------------------------------------------------------------------
5906 subroutine etor(etors,edihcnstr)
5907 implicit real*8 (a-h,o-z)
5908 include 'DIMENSIONS'
5909 include 'COMMON.VAR'
5910 include 'COMMON.GEO'
5911 include 'COMMON.LOCAL'
5912 include 'COMMON.TORSION'
5913 include 'COMMON.INTERACT'
5914 include 'COMMON.DERIV'
5915 include 'COMMON.CHAIN'
5916 include 'COMMON.NAMES'
5917 include 'COMMON.IOUNITS'
5918 include 'COMMON.FFIELD'
5919 include 'COMMON.TORCNSTR'
5920 include 'COMMON.CONTROL'
5922 C Set lprn=.true. for debugging
5926 do i=iphi_start,iphi_end
5927 C ANY TWO ARE DUMMY ATOMS in row CYCLE
5928 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
5929 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
5930 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
5931 if ((itype(i-3).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5932 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1)) cycle
5933 C For introducing the NH3+ and COO- group please check the etor_d for reference
5936 if (iabs(itype(i)).eq.20) then
5941 itori=itortyp(itype(i-2))
5942 itori1=itortyp(itype(i-1))
5945 C Regular cosine and sine terms
5946 do j=1,nterm(itori,itori1,iblock)
5947 v1ij=v1(j,itori,itori1,iblock)
5948 v2ij=v2(j,itori,itori1,iblock)
5951 etors=etors+v1ij*cosphi+v2ij*sinphi
5952 if (energy_dec) etors_ii=etors_ii+
5953 & v1ij*cosphi+v2ij*sinphi
5954 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5958 C E = SUM ----------------------------------- - v1
5959 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5961 cosphi=dcos(0.5d0*phii)
5962 sinphi=dsin(0.5d0*phii)
5963 do j=1,nlor(itori,itori1,iblock)
5964 vl1ij=vlor1(j,itori,itori1)
5965 vl2ij=vlor2(j,itori,itori1)
5966 vl3ij=vlor3(j,itori,itori1)
5967 pom=vl2ij*cosphi+vl3ij*sinphi
5968 pom1=1.0d0/(pom*pom+1.0d0)
5969 etors=etors+vl1ij*pom1
5970 if (energy_dec) etors_ii=etors_ii+
5973 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5975 C Subtract the constant term
5976 etors=etors-v0(itori,itori1,iblock)
5977 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5978 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
5980 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5981 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5982 & (v1(j,itori,itori1,iblock),j=1,6),
5983 & (v2(j,itori,itori1,iblock),j=1,6)
5984 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5985 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5987 ! 6/20/98 - dihedral angle constraints
5989 c do i=1,ndih_constr
5990 do i=idihconstr_start,idihconstr_end
5991 itori=idih_constr(i)
5993 difi=pinorm(phii-phi0(i))
5994 if (difi.gt.drange(i)) then
5996 edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5997 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5998 else if (difi.lt.-drange(i)) then
6000 edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6001 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6005 cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6006 cd & rad2deg*phi0(i), rad2deg*drange(i),
6007 cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6009 cd write (iout,*) 'edihcnstr',edihcnstr
6012 c----------------------------------------------------------------------------
6013 subroutine etor_d(etors_d)
6014 C 6/23/01 Compute double torsional energy
6015 implicit real*8 (a-h,o-z)
6016 include 'DIMENSIONS'
6017 include 'COMMON.VAR'
6018 include 'COMMON.GEO'
6019 include 'COMMON.LOCAL'
6020 include 'COMMON.TORSION'
6021 include 'COMMON.INTERACT'
6022 include 'COMMON.DERIV'
6023 include 'COMMON.CHAIN'
6024 include 'COMMON.NAMES'
6025 include 'COMMON.IOUNITS'
6026 include 'COMMON.FFIELD'
6027 include 'COMMON.TORCNSTR'
6029 C Set lprn=.true. for debugging
6033 c write(iout,*) "a tu??"
6034 do i=iphid_start,iphid_end
6035 C ANY TWO ARE DUMMY ATOMS in row CYCLE
6036 if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
6037 & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
6038 & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
6039 & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
6040 itori=itortyp(itype(i-2))
6041 itori1=itortyp(itype(i-1))
6042 itori2=itortyp(itype(i))
6048 if (iabs(itype(i+1)).eq.20) iblock=2
6049 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
6050 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
6051 C if (itype(i+1).eq.ntyp1) iblock=3
6052 C The problem of NH3+ group can be resolved by adding new parameters please note if there
6053 C IS or IS NOT need for this
6054 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
6055 C is (itype(i-3).eq.ntyp1) ntblock=2
6056 C ntblock is N-terminal blocking group
6058 C Regular cosine and sine terms
6059 do j=1,ntermd_1(itori,itori1,itori2,iblock)
6060 C Example of changes for NH3+ blocking group
6061 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
6062 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
6063 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6064 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6065 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6066 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6067 cosphi1=dcos(j*phii)
6068 sinphi1=dsin(j*phii)
6069 cosphi2=dcos(j*phii1)
6070 sinphi2=dsin(j*phii1)
6071 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6072 & v2cij*cosphi2+v2sij*sinphi2
6073 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6074 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6076 do k=2,ntermd_2(itori,itori1,itori2,iblock)
6078 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6079 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6080 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6081 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6082 cosphi1p2=dcos(l*phii+(k-l)*phii1)
6083 cosphi1m2=dcos(l*phii-(k-l)*phii1)
6084 sinphi1p2=dsin(l*phii+(k-l)*phii1)
6085 sinphi1m2=dsin(l*phii-(k-l)*phii1)
6086 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6087 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
6088 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6089 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6090 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6091 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6094 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6095 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6100 c------------------------------------------------------------------------------
6101 subroutine eback_sc_corr(esccor)
6102 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6103 c conformational states; temporarily implemented as differences
6104 c between UNRES torsional potentials (dependent on three types of
6105 c residues) and the torsional potentials dependent on all 20 types
6106 c of residues computed from AM1 energy surfaces of terminally-blocked
6107 c amino-acid residues.
6108 implicit real*8 (a-h,o-z)
6109 include 'DIMENSIONS'
6110 include 'COMMON.VAR'
6111 include 'COMMON.GEO'
6112 include 'COMMON.LOCAL'
6113 include 'COMMON.TORSION'
6114 include 'COMMON.SCCOR'
6115 include 'COMMON.INTERACT'
6116 include 'COMMON.DERIV'
6117 include 'COMMON.CHAIN'
6118 include 'COMMON.NAMES'
6119 include 'COMMON.IOUNITS'
6120 include 'COMMON.FFIELD'
6121 include 'COMMON.CONTROL'
6123 C Set lprn=.true. for debugging
6126 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6128 do i=itau_start,itau_end
6129 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6131 isccori=isccortyp(itype(i-2))
6132 isccori1=isccortyp(itype(i-1))
6133 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
6135 do intertyp=1,3 !intertyp
6136 cc Added 09 May 2012 (Adasko)
6137 cc Intertyp means interaction type of backbone mainchain correlation:
6138 c 1 = SC...Ca...Ca...Ca
6139 c 2 = Ca...Ca...Ca...SC
6140 c 3 = SC...Ca...Ca...SCi
6142 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6143 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6144 & (itype(i-1).eq.ntyp1)))
6145 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6146 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6147 & .or.(itype(i).eq.ntyp1)))
6148 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6149 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6150 & (itype(i-3).eq.ntyp1)))) cycle
6151 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6152 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6154 do j=1,nterm_sccor(isccori,isccori1)
6155 v1ij=v1sccor(j,intertyp,isccori,isccori1)
6156 v2ij=v2sccor(j,intertyp,isccori,isccori1)
6157 cosphi=dcos(j*tauangle(intertyp,i))
6158 sinphi=dsin(j*tauangle(intertyp,i))
6159 esccor=esccor+v1ij*cosphi+v2ij*sinphi
6160 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6162 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
6163 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6165 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6166 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6167 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6168 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6169 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6175 c----------------------------------------------------------------------------
6176 subroutine multibody(ecorr)
6177 C This subroutine calculates multi-body contributions to energy following
6178 C the idea of Skolnick et al. If side chains I and J make a contact and
6179 C at the same time side chains I+1 and J+1 make a contact, an extra
6180 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6181 implicit real*8 (a-h,o-z)
6182 include 'DIMENSIONS'
6183 include 'COMMON.IOUNITS'
6184 include 'COMMON.DERIV'
6185 include 'COMMON.INTERACT'
6186 include 'COMMON.CONTACTS'
6187 double precision gx(3),gx1(3)
6190 C Set lprn=.true. for debugging
6194 write (iout,'(a)') 'Contact function values:'
6196 write (iout,'(i2,20(1x,i2,f10.5))')
6197 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6212 num_conti=num_cont(i)
6213 num_conti1=num_cont(i1)
6218 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6219 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6220 cd & ' ishift=',ishift
6221 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6222 C The system gains extra energy.
6223 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6224 endif ! j1==j+-ishift
6233 c------------------------------------------------------------------------------
6234 double precision function esccorr(i,j,k,l,jj,kk)
6235 implicit real*8 (a-h,o-z)
6236 include 'DIMENSIONS'
6237 include 'COMMON.IOUNITS'
6238 include 'COMMON.DERIV'
6239 include 'COMMON.INTERACT'
6240 include 'COMMON.CONTACTS'
6241 double precision gx(3),gx1(3)
6246 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6247 C Calculate the multi-body contribution to energy.
6248 C Calculate multi-body contributions to the gradient.
6249 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6250 cd & k,l,(gacont(m,kk,k),m=1,3)
6252 gx(m) =ekl*gacont(m,jj,i)
6253 gx1(m)=eij*gacont(m,kk,k)
6254 gradxorr(m,i)=gradxorr(m,i)-gx(m)
6255 gradxorr(m,j)=gradxorr(m,j)+gx(m)
6256 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6257 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6261 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6266 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6272 c------------------------------------------------------------------------------
6273 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6274 C This subroutine calculates multi-body contributions to hydrogen-bonding
6275 implicit real*8 (a-h,o-z)
6276 include 'DIMENSIONS'
6277 include 'COMMON.IOUNITS'
6280 parameter (max_cont=maxconts)
6281 parameter (max_dim=26)
6282 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6283 double precision zapas(max_dim,maxconts,max_fg_procs),
6284 & zapas_recv(max_dim,maxconts,max_fg_procs)
6285 common /przechowalnia/ zapas
6286 integer status(MPI_STATUS_SIZE),req(maxconts*2),
6287 & status_array(MPI_STATUS_SIZE,maxconts*2)
6289 include 'COMMON.SETUP'
6290 include 'COMMON.FFIELD'
6291 include 'COMMON.DERIV'
6292 include 'COMMON.INTERACT'
6293 include 'COMMON.CONTACTS'
6294 include 'COMMON.CONTROL'
6295 include 'COMMON.LOCAL'
6296 double precision gx(3),gx1(3),time00
6299 C Set lprn=.true. for debugging
6304 if (nfgtasks.le.1) goto 30
6306 write (iout,'(a)') 'Contact function values before RECEIVE:'
6308 write (iout,'(2i3,50(1x,i2,f5.2))')
6309 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6310 & j=1,num_cont_hb(i))
6314 do i=1,ntask_cont_from
6317 do i=1,ntask_cont_to
6320 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6322 C Make the list of contacts to send to send to other procesors
6323 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6325 do i=iturn3_start,iturn3_end
6326 c write (iout,*) "make contact list turn3",i," num_cont",
6328 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6330 do i=iturn4_start,iturn4_end
6331 c write (iout,*) "make contact list turn4",i," num_cont",
6333 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6337 c write (iout,*) "make contact list longrange",i,ii," num_cont",
6339 do j=1,num_cont_hb(i)
6342 iproc=iint_sent_local(k,jjc,ii)
6343 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6344 if (iproc.gt.0) then
6345 ncont_sent(iproc)=ncont_sent(iproc)+1
6346 nn=ncont_sent(iproc)
6348 zapas(2,nn,iproc)=jjc
6349 zapas(3,nn,iproc)=facont_hb(j,i)
6350 zapas(4,nn,iproc)=ees0p(j,i)
6351 zapas(5,nn,iproc)=ees0m(j,i)
6352 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6353 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6354 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6355 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6356 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6357 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6358 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6359 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6360 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6361 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6362 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6363 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6364 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6365 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6366 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6367 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6368 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6369 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6370 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6371 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6372 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6379 & "Numbers of contacts to be sent to other processors",
6380 & (ncont_sent(i),i=1,ntask_cont_to)
6381 write (iout,*) "Contacts sent"
6382 do ii=1,ntask_cont_to
6384 iproc=itask_cont_to(ii)
6385 write (iout,*) nn," contacts to processor",iproc,
6386 & " of CONT_TO_COMM group"
6388 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6396 CorrelID1=nfgtasks+fg_rank+1
6398 C Receive the numbers of needed contacts from other processors
6399 do ii=1,ntask_cont_from
6400 iproc=itask_cont_from(ii)
6402 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6403 & FG_COMM,req(ireq),IERR)
6405 c write (iout,*) "IRECV ended"
6407 C Send the number of contacts needed by other processors
6408 do ii=1,ntask_cont_to
6409 iproc=itask_cont_to(ii)
6411 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6412 & FG_COMM,req(ireq),IERR)
6414 c write (iout,*) "ISEND ended"
6415 c write (iout,*) "number of requests (nn)",ireq
6418 & call MPI_Waitall(ireq,req,status_array,ierr)
6420 c & "Numbers of contacts to be received from other processors",
6421 c & (ncont_recv(i),i=1,ntask_cont_from)
6425 do ii=1,ntask_cont_from
6426 iproc=itask_cont_from(ii)
6428 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
6429 c & " of CONT_TO_COMM group"
6433 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6434 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6435 c write (iout,*) "ireq,req",ireq,req(ireq)
6438 C Send the contacts to processors that need them
6439 do ii=1,ntask_cont_to
6440 iproc=itask_cont_to(ii)
6442 c write (iout,*) nn," contacts to processor",iproc,
6443 c & " of CONT_TO_COMM group"
6446 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6447 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6448 c write (iout,*) "ireq,req",ireq,req(ireq)
6450 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6454 c write (iout,*) "number of requests (contacts)",ireq
6455 c write (iout,*) "req",(req(i),i=1,4)
6458 & call MPI_Waitall(ireq,req,status_array,ierr)
6459 do iii=1,ntask_cont_from
6460 iproc=itask_cont_from(iii)
6463 write (iout,*) "Received",nn," contacts from processor",iproc,
6464 & " of CONT_FROM_COMM group"
6467 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6472 ii=zapas_recv(1,i,iii)
6473 c Flag the received contacts to prevent double-counting
6474 jj=-zapas_recv(2,i,iii)
6475 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6477 nnn=num_cont_hb(ii)+1
6480 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6481 ees0p(nnn,ii)=zapas_recv(4,i,iii)
6482 ees0m(nnn,ii)=zapas_recv(5,i,iii)
6483 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6484 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6485 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6486 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6487 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6488 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6489 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6490 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6491 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6492 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6493 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6494 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6495 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6496 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6497 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6498 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6499 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6500 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6501 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6502 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6503 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6508 write (iout,'(a)') 'Contact function values after receive:'
6510 write (iout,'(2i3,50(1x,i3,f5.2))')
6511 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6512 & j=1,num_cont_hb(i))
6519 write (iout,'(a)') 'Contact function values:'
6521 write (iout,'(2i3,50(1x,i3,f5.2))')
6522 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6523 & j=1,num_cont_hb(i))
6527 C Remove the loop below after debugging !!!
6534 C Calculate the local-electrostatic correlation terms
6535 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6537 num_conti=num_cont_hb(i)
6538 num_conti1=num_cont_hb(i+1)
6545 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6546 c & ' jj=',jj,' kk=',kk
6547 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6548 & .or. j.lt.0 .and. j1.gt.0) .and.
6549 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6550 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6551 C The system gains extra energy.
6552 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6553 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6554 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6556 else if (j1.eq.j) then
6557 C Contacts I-J and I-(J+1) occur simultaneously.
6558 C The system loses extra energy.
6559 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6564 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6565 c & ' jj=',jj,' kk=',kk
6567 C Contacts I-J and (I+1)-J occur simultaneously.
6568 C The system loses extra energy.
6569 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6576 c------------------------------------------------------------------------------
6577 subroutine add_hb_contact(ii,jj,itask)
6578 implicit real*8 (a-h,o-z)
6579 include "DIMENSIONS"
6580 include "COMMON.IOUNITS"
6583 parameter (max_cont=maxconts)
6584 parameter (max_dim=26)
6585 include "COMMON.CONTACTS"
6586 double precision zapas(max_dim,maxconts,max_fg_procs),
6587 & zapas_recv(max_dim,maxconts,max_fg_procs)
6588 common /przechowalnia/ zapas
6589 integer i,j,ii,jj,iproc,itask(4),nn
6590 c write (iout,*) "itask",itask
6593 if (iproc.gt.0) then
6594 do j=1,num_cont_hb(ii)
6596 c write (iout,*) "i",ii," j",jj," jjc",jjc
6598 ncont_sent(iproc)=ncont_sent(iproc)+1
6599 nn=ncont_sent(iproc)
6600 zapas(1,nn,iproc)=ii
6601 zapas(2,nn,iproc)=jjc
6602 zapas(3,nn,iproc)=facont_hb(j,ii)
6603 zapas(4,nn,iproc)=ees0p(j,ii)
6604 zapas(5,nn,iproc)=ees0m(j,ii)
6605 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6606 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6607 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6608 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6609 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6610 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6611 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6612 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6613 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6614 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6615 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6616 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6617 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6618 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6619 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6620 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6621 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6622 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6623 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6624 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6625 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6633 c------------------------------------------------------------------------------
6634 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6636 C This subroutine calculates multi-body contributions to hydrogen-bonding
6637 implicit real*8 (a-h,o-z)
6638 include 'DIMENSIONS'
6639 include 'COMMON.IOUNITS'
6642 parameter (max_cont=maxconts)
6643 parameter (max_dim=70)
6644 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6645 double precision zapas(max_dim,maxconts,max_fg_procs),
6646 & zapas_recv(max_dim,maxconts,max_fg_procs)
6647 common /przechowalnia/ zapas
6648 integer status(MPI_STATUS_SIZE),req(maxconts*2),
6649 & status_array(MPI_STATUS_SIZE,maxconts*2)
6651 include 'COMMON.SETUP'
6652 include 'COMMON.FFIELD'
6653 include 'COMMON.DERIV'
6654 include 'COMMON.LOCAL'
6655 include 'COMMON.INTERACT'
6656 include 'COMMON.CONTACTS'
6657 include 'COMMON.CHAIN'
6658 include 'COMMON.CONTROL'
6659 double precision gx(3),gx1(3)
6660 integer num_cont_hb_old(maxres)
6662 double precision eello4,eello5,eelo6,eello_turn6
6663 external eello4,eello5,eello6,eello_turn6
6664 C Set lprn=.true. for debugging
6669 num_cont_hb_old(i)=num_cont_hb(i)
6673 if (nfgtasks.le.1) goto 30
6675 write (iout,'(a)') 'Contact function values before RECEIVE:'
6677 write (iout,'(2i3,50(1x,i2,f5.2))')
6678 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6679 & j=1,num_cont_hb(i))
6683 do i=1,ntask_cont_from
6686 do i=1,ntask_cont_to
6689 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6691 C Make the list of contacts to send to send to other procesors
6692 do i=iturn3_start,iturn3_end
6693 c write (iout,*) "make contact list turn3",i," num_cont",
6695 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6697 do i=iturn4_start,iturn4_end
6698 c write (iout,*) "make contact list turn4",i," num_cont",
6700 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6704 c write (iout,*) "make contact list longrange",i,ii," num_cont",
6706 do j=1,num_cont_hb(i)
6709 iproc=iint_sent_local(k,jjc,ii)
6710 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6711 if (iproc.ne.0) then
6712 ncont_sent(iproc)=ncont_sent(iproc)+1
6713 nn=ncont_sent(iproc)
6715 zapas(2,nn,iproc)=jjc
6716 zapas(3,nn,iproc)=d_cont(j,i)
6720 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6725 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6733 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6744 & "Numbers of contacts to be sent to other processors",
6745 & (ncont_sent(i),i=1,ntask_cont_to)
6746 write (iout,*) "Contacts sent"
6747 do ii=1,ntask_cont_to
6749 iproc=itask_cont_to(ii)
6750 write (iout,*) nn," contacts to processor",iproc,
6751 & " of CONT_TO_COMM group"
6753 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6761 CorrelID1=nfgtasks+fg_rank+1
6763 C Receive the numbers of needed contacts from other processors
6764 do ii=1,ntask_cont_from
6765 iproc=itask_cont_from(ii)
6767 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6768 & FG_COMM,req(ireq),IERR)
6770 c write (iout,*) "IRECV ended"
6772 C Send the number of contacts needed by other processors
6773 do ii=1,ntask_cont_to
6774 iproc=itask_cont_to(ii)
6776 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6777 & FG_COMM,req(ireq),IERR)
6779 c write (iout,*) "ISEND ended"
6780 c write (iout,*) "number of requests (nn)",ireq
6783 & call MPI_Waitall(ireq,req,status_array,ierr)
6785 c & "Numbers of contacts to be received from other processors",
6786 c & (ncont_recv(i),i=1,ntask_cont_from)
6790 do ii=1,ntask_cont_from
6791 iproc=itask_cont_from(ii)
6793 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
6794 c & " of CONT_TO_COMM group"
6798 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6799 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6800 c write (iout,*) "ireq,req",ireq,req(ireq)
6803 C Send the contacts to processors that need them
6804 do ii=1,ntask_cont_to
6805 iproc=itask_cont_to(ii)
6807 c write (iout,*) nn," contacts to processor",iproc,
6808 c & " of CONT_TO_COMM group"
6811 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6812 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6813 c write (iout,*) "ireq,req",ireq,req(ireq)
6815 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6819 c write (iout,*) "number of requests (contacts)",ireq
6820 c write (iout,*) "req",(req(i),i=1,4)
6823 & call MPI_Waitall(ireq,req,status_array,ierr)
6824 do iii=1,ntask_cont_from
6825 iproc=itask_cont_from(iii)
6828 write (iout,*) "Received",nn," contacts from processor",iproc,
6829 & " of CONT_FROM_COMM group"
6832 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6837 ii=zapas_recv(1,i,iii)
6838 c Flag the received contacts to prevent double-counting
6839 jj=-zapas_recv(2,i,iii)
6840 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6842 nnn=num_cont_hb(ii)+1
6845 d_cont(nnn,ii)=zapas_recv(3,i,iii)
6849 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6854 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6862 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6871 write (iout,'(a)') 'Contact function values after receive:'
6873 write (iout,'(2i3,50(1x,i3,5f6.3))')
6874 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6875 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6882 write (iout,'(a)') 'Contact function values:'
6884 write (iout,'(2i3,50(1x,i2,5f6.3))')
6885 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6886 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6892 C Remove the loop below after debugging !!!
6899 C Calculate the dipole-dipole interaction energies
6900 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6901 do i=iatel_s,iatel_e+1
6902 num_conti=num_cont_hb(i)
6911 C Calculate the local-electrostatic correlation terms
6912 c write (iout,*) "gradcorr5 in eello5 before loop"
6914 c write (iout,'(i5,3f10.5)')
6915 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
6917 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6918 c write (iout,*) "corr loop i",i
6920 num_conti=num_cont_hb(i)
6921 num_conti1=num_cont_hb(i+1)
6928 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6929 c & ' jj=',jj,' kk=',kk
6930 c if (j1.eq.j+1 .or. j1.eq.j-1) then
6931 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6932 & .or. j.lt.0 .and. j1.gt.0) .and.
6933 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6934 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6935 C The system gains extra energy.
6937 sqd1=dsqrt(d_cont(jj,i))
6938 sqd2=dsqrt(d_cont(kk,i1))
6939 sred_geom = sqd1*sqd2
6940 IF (sred_geom.lt.cutoff_corr) THEN
6941 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6943 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6944 cd & ' jj=',jj,' kk=',kk
6945 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6946 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6948 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6949 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6952 cd write (iout,*) 'sred_geom=',sred_geom,
6953 cd & ' ekont=',ekont,' fprim=',fprimcont,
6954 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6955 cd write (iout,*) "g_contij",g_contij
6956 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6957 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6958 call calc_eello(i,jp,i+1,jp1,jj,kk)
6959 if (wcorr4.gt.0.0d0)
6960 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6961 if (energy_dec.and.wcorr4.gt.0.0d0)
6962 1 write (iout,'(a6,4i5,0pf7.3)')
6963 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6964 c write (iout,*) "gradcorr5 before eello5"
6966 c write (iout,'(i5,3f10.5)')
6967 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
6969 if (wcorr5.gt.0.0d0)
6970 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6971 c write (iout,*) "gradcorr5 after eello5"
6973 c write (iout,'(i5,3f10.5)')
6974 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
6976 if (energy_dec.and.wcorr5.gt.0.0d0)
6977 1 write (iout,'(a6,4i5,0pf7.3)')
6978 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6979 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6980 cd write(2,*)'ijkl',i,jp,i+1,jp1
6981 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6982 & .or. wturn6.eq.0.0d0))then
6983 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6984 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6985 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6986 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6987 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6988 cd & 'ecorr6=',ecorr6
6989 cd write (iout,'(4e15.5)') sred_geom,
6990 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6991 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6992 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
6993 else if (wturn6.gt.0.0d0
6994 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6995 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6996 eturn6=eturn6+eello_turn6(i,jj,kk)
6997 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6998 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6999 cd write (2,*) 'multibody_eello:eturn6',eturn6
7008 num_cont_hb(i)=num_cont_hb_old(i)
7010 c write (iout,*) "gradcorr5 in eello5"
7012 c write (iout,'(i5,3f10.5)')
7013 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
7017 c------------------------------------------------------------------------------
7018 subroutine add_hb_contact_eello(ii,jj,itask)
7019 implicit real*8 (a-h,o-z)
7020 include "DIMENSIONS"
7021 include "COMMON.IOUNITS"
7024 parameter (max_cont=maxconts)
7025 parameter (max_dim=70)
7026 include "COMMON.CONTACTS"
7027 double precision zapas(max_dim,maxconts,max_fg_procs),
7028 & zapas_recv(max_dim,maxconts,max_fg_procs)
7029 common /przechowalnia/ zapas
7030 integer i,j,ii,jj,iproc,itask(4),nn
7031 c write (iout,*) "itask",itask
7034 if (iproc.gt.0) then
7035 do j=1,num_cont_hb(ii)
7037 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7039 ncont_sent(iproc)=ncont_sent(iproc)+1
7040 nn=ncont_sent(iproc)
7041 zapas(1,nn,iproc)=ii
7042 zapas(2,nn,iproc)=jjc
7043 zapas(3,nn,iproc)=d_cont(j,ii)
7047 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7052 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7060 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7072 c------------------------------------------------------------------------------
7073 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7074 implicit real*8 (a-h,o-z)
7075 include 'DIMENSIONS'
7076 include 'COMMON.IOUNITS'
7077 include 'COMMON.DERIV'
7078 include 'COMMON.INTERACT'
7079 include 'COMMON.CONTACTS'
7080 double precision gx(3),gx1(3)
7090 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7091 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7092 C Following 4 lines for diagnostics.
7097 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7098 c & 'Contacts ',i,j,
7099 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7100 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7102 C Calculate the multi-body contribution to energy.
7103 c ecorr=ecorr+ekont*ees
7104 C Calculate multi-body contributions to the gradient.
7105 coeffpees0pij=coeffp*ees0pij
7106 coeffmees0mij=coeffm*ees0mij
7107 coeffpees0pkl=coeffp*ees0pkl
7108 coeffmees0mkl=coeffm*ees0mkl
7110 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7111 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7112 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7113 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
7114 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7115 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7116 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
7117 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7118 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7119 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7120 & coeffmees0mij*gacontm_hb1(ll,kk,k))
7121 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7122 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7123 & coeffmees0mij*gacontm_hb2(ll,kk,k))
7124 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7125 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7126 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
7127 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7128 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7129 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7130 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7131 & coeffmees0mij*gacontm_hb3(ll,kk,k))
7132 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7133 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7134 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7139 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
7140 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
7141 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7142 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7147 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
7148 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
7149 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7150 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7153 c write (iout,*) "ehbcorr",ekont*ees
7158 C---------------------------------------------------------------------------
7159 subroutine dipole(i,j,jj)
7160 implicit real*8 (a-h,o-z)
7161 include 'DIMENSIONS'
7162 include 'COMMON.IOUNITS'
7163 include 'COMMON.CHAIN'
7164 include 'COMMON.FFIELD'
7165 include 'COMMON.DERIV'
7166 include 'COMMON.INTERACT'
7167 include 'COMMON.CONTACTS'
7168 include 'COMMON.TORSION'
7169 include 'COMMON.VAR'
7170 include 'COMMON.GEO'
7171 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7173 iti1 = itortyp(itype(i+1))
7174 if (j.lt.nres-1) then
7175 itj1 = itortyp(itype(j+1))
7180 dipi(iii,1)=Ub2(iii,i)
7181 dipderi(iii)=Ub2der(iii,i)
7182 dipi(iii,2)=b1(iii,iti1)
7183 dipj(iii,1)=Ub2(iii,j)
7184 dipderj(iii)=Ub2der(iii,j)
7185 dipj(iii,2)=b1(iii,itj1)
7189 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7192 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7199 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7203 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7208 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7209 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7211 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7213 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7215 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7220 C---------------------------------------------------------------------------
7221 subroutine calc_eello(i,j,k,l,jj,kk)
7223 C This subroutine computes matrices and vectors needed to calculate
7224 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7226 implicit real*8 (a-h,o-z)
7227 include 'DIMENSIONS'
7228 include 'COMMON.IOUNITS'
7229 include 'COMMON.CHAIN'
7230 include 'COMMON.DERIV'
7231 include 'COMMON.INTERACT'
7232 include 'COMMON.CONTACTS'
7233 include 'COMMON.TORSION'
7234 include 'COMMON.VAR'
7235 include 'COMMON.GEO'
7236 include 'COMMON.FFIELD'
7237 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7238 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7241 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7242 cd & ' jj=',jj,' kk=',kk
7243 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7244 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7245 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7248 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7249 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7252 call transpose2(aa1(1,1),aa1t(1,1))
7253 call transpose2(aa2(1,1),aa2t(1,1))
7256 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7257 & aa1tder(1,1,lll,kkk))
7258 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7259 & aa2tder(1,1,lll,kkk))
7263 C parallel orientation of the two CA-CA-CA frames.
7265 iti=itortyp(itype(i))
7269 itk1=itortyp(itype(k+1))
7270 itj=itortyp(itype(j))
7271 if (l.lt.nres-1) then
7272 itl1=itortyp(itype(l+1))
7276 C A1 kernel(j+1) A2T
7278 cd write (iout,'(3f10.5,5x,3f10.5)')
7279 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7281 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7282 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7283 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7284 C Following matrices are needed only for 6-th order cumulants
7285 IF (wcorr6.gt.0.0d0) THEN
7286 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7287 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7288 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7289 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7290 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7291 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7292 & ADtEAderx(1,1,1,1,1,1))
7294 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7295 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7296 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7297 & ADtEA1derx(1,1,1,1,1,1))
7299 C End 6-th order cumulants
7302 cd write (2,*) 'In calc_eello6'
7304 cd write (2,*) 'iii=',iii
7306 cd write (2,*) 'kkk=',kkk
7308 cd write (2,'(3(2f10.5),5x)')
7309 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7314 call transpose2(EUgder(1,1,k),auxmat(1,1))
7315 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7316 call transpose2(EUg(1,1,k),auxmat(1,1))
7317 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7318 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7322 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7323 & EAEAderx(1,1,lll,kkk,iii,1))
7327 C A1T kernel(i+1) A2
7328 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7329 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7330 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7331 C Following matrices are needed only for 6-th order cumulants
7332 IF (wcorr6.gt.0.0d0) THEN
7333 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7334 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7335 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7336 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7337 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7338 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7339 & ADtEAderx(1,1,1,1,1,2))
7340 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7341 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7342 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7343 & ADtEA1derx(1,1,1,1,1,2))
7345 C End 6-th order cumulants
7346 call transpose2(EUgder(1,1,l),auxmat(1,1))
7347 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7348 call transpose2(EUg(1,1,l),auxmat(1,1))
7349 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7350 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7354 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7355 & EAEAderx(1,1,lll,kkk,iii,2))
7360 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7361 C They are needed only when the fifth- or the sixth-order cumulants are
7363 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7364 call transpose2(AEA(1,1,1),auxmat(1,1))
7365 call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7366 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7367 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7368 call transpose2(AEAderg(1,1,1),auxmat(1,1))
7369 call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7370 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7371 call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7372 call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7373 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7374 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7375 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7376 call transpose2(AEA(1,1,2),auxmat(1,1))
7377 call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7378 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7379 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7380 call transpose2(AEAderg(1,1,2),auxmat(1,1))
7381 call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7382 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7383 call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7384 call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7385 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7386 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7387 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7388 C Calculate the Cartesian derivatives of the vectors.
7392 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7393 call matvec2(auxmat(1,1),b1(1,iti),
7394 & AEAb1derx(1,lll,kkk,iii,1,1))
7395 call matvec2(auxmat(1,1),Ub2(1,i),
7396 & AEAb2derx(1,lll,kkk,iii,1,1))
7397 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7398 & AEAb1derx(1,lll,kkk,iii,2,1))
7399 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7400 & AEAb2derx(1,lll,kkk,iii,2,1))
7401 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7402 call matvec2(auxmat(1,1),b1(1,itj),
7403 & AEAb1derx(1,lll,kkk,iii,1,2))
7404 call matvec2(auxmat(1,1),Ub2(1,j),
7405 & AEAb2derx(1,lll,kkk,iii,1,2))
7406 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7407 & AEAb1derx(1,lll,kkk,iii,2,2))
7408 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7409 & AEAb2derx(1,lll,kkk,iii,2,2))
7416 C Antiparallel orientation of the two CA-CA-CA frames.
7418 iti=itortyp(itype(i))
7422 itk1=itortyp(itype(k+1))
7423 itl=itortyp(itype(l))
7424 itj=itortyp(itype(j))
7425 if (j.lt.nres-1) then
7426 itj1=itortyp(itype(j+1))
7430 C A2 kernel(j-1)T A1T
7431 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7432 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7433 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7434 C Following matrices are needed only for 6-th order cumulants
7435 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7436 & j.eq.i+4 .and. l.eq.i+3)) THEN
7437 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7438 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7439 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7440 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7441 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7442 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7443 & ADtEAderx(1,1,1,1,1,1))
7444 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7445 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7446 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7447 & ADtEA1derx(1,1,1,1,1,1))
7449 C End 6-th order cumulants
7450 call transpose2(EUgder(1,1,k),auxmat(1,1))
7451 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7452 call transpose2(EUg(1,1,k),auxmat(1,1))
7453 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7454 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7458 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7459 & EAEAderx(1,1,lll,kkk,iii,1))
7463 C A2T kernel(i+1)T A1
7464 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7465 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7466 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7467 C Following matrices are needed only for 6-th order cumulants
7468 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7469 & j.eq.i+4 .and. l.eq.i+3)) THEN
7470 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7471 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7472 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7473 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7474 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7475 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7476 & ADtEAderx(1,1,1,1,1,2))
7477 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7478 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7479 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7480 & ADtEA1derx(1,1,1,1,1,2))
7482 C End 6-th order cumulants
7483 call transpose2(EUgder(1,1,j),auxmat(1,1))
7484 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7485 call transpose2(EUg(1,1,j),auxmat(1,1))
7486 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7487 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7491 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7492 & EAEAderx(1,1,lll,kkk,iii,2))
7497 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7498 C They are needed only when the fifth- or the sixth-order cumulants are
7500 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7501 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7502 call transpose2(AEA(1,1,1),auxmat(1,1))
7503 call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7504 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7505 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7506 call transpose2(AEAderg(1,1,1),auxmat(1,1))
7507 call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7508 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7509 call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7510 call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7511 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7512 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7513 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7514 call transpose2(AEA(1,1,2),auxmat(1,1))
7515 call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7516 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7517 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7518 call transpose2(AEAderg(1,1,2),auxmat(1,1))
7519 call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7520 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7521 call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7522 call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7523 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7524 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7525 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7526 C Calculate the Cartesian derivatives of the vectors.
7530 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7531 call matvec2(auxmat(1,1),b1(1,iti),
7532 & AEAb1derx(1,lll,kkk,iii,1,1))
7533 call matvec2(auxmat(1,1),Ub2(1,i),
7534 & AEAb2derx(1,lll,kkk,iii,1,1))
7535 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7536 & AEAb1derx(1,lll,kkk,iii,2,1))
7537 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7538 & AEAb2derx(1,lll,kkk,iii,2,1))
7539 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7540 call matvec2(auxmat(1,1),b1(1,itl),
7541 & AEAb1derx(1,lll,kkk,iii,1,2))
7542 call matvec2(auxmat(1,1),Ub2(1,l),
7543 & AEAb2derx(1,lll,kkk,iii,1,2))
7544 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7545 & AEAb1derx(1,lll,kkk,iii,2,2))
7546 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7547 & AEAb2derx(1,lll,kkk,iii,2,2))
7556 C---------------------------------------------------------------------------
7557 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7558 & KK,KKderg,AKA,AKAderg,AKAderx)
7562 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7563 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7564 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7569 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7571 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7574 cd if (lprn) write (2,*) 'In kernel'
7576 cd if (lprn) write (2,*) 'kkk=',kkk
7578 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7579 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7581 cd write (2,*) 'lll=',lll
7582 cd write (2,*) 'iii=1'
7584 cd write (2,'(3(2f10.5),5x)')
7585 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7588 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7589 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7591 cd write (2,*) 'lll=',lll
7592 cd write (2,*) 'iii=2'
7594 cd write (2,'(3(2f10.5),5x)')
7595 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7602 C---------------------------------------------------------------------------
7603 double precision function eello4(i,j,k,l,jj,kk)
7604 implicit real*8 (a-h,o-z)
7605 include 'DIMENSIONS'
7606 include 'COMMON.IOUNITS'
7607 include 'COMMON.CHAIN'
7608 include 'COMMON.DERIV'
7609 include 'COMMON.INTERACT'
7610 include 'COMMON.CONTACTS'
7611 include 'COMMON.TORSION'
7612 include 'COMMON.VAR'
7613 include 'COMMON.GEO'
7614 double precision pizda(2,2),ggg1(3),ggg2(3)
7615 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7619 cd print *,'eello4:',i,j,k,l,jj,kk
7620 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
7621 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
7622 cold eij=facont_hb(jj,i)
7623 cold ekl=facont_hb(kk,k)
7625 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7626 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7627 gcorr_loc(k-1)=gcorr_loc(k-1)
7628 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7630 gcorr_loc(l-1)=gcorr_loc(l-1)
7631 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7633 gcorr_loc(j-1)=gcorr_loc(j-1)
7634 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7639 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7640 & -EAEAderx(2,2,lll,kkk,iii,1)
7641 cd derx(lll,kkk,iii)=0.0d0
7645 cd gcorr_loc(l-1)=0.0d0
7646 cd gcorr_loc(j-1)=0.0d0
7647 cd gcorr_loc(k-1)=0.0d0
7649 cd write (iout,*)'Contacts have occurred for peptide groups',
7650 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
7651 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7652 if (j.lt.nres-1) then
7659 if (l.lt.nres-1) then
7667 cgrad ggg1(ll)=eel4*g_contij(ll,1)
7668 cgrad ggg2(ll)=eel4*g_contij(ll,2)
7669 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7670 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7671 cgrad ghalf=0.5d0*ggg1(ll)
7672 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7673 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7674 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7675 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7676 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7677 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7678 cgrad ghalf=0.5d0*ggg2(ll)
7679 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7680 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7681 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7682 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7683 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7684 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7688 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7693 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7698 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7703 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7707 cd write (2,*) iii,gcorr_loc(iii)
7710 cd write (2,*) 'ekont',ekont
7711 cd write (iout,*) 'eello4',ekont*eel4
7714 C---------------------------------------------------------------------------
7715 double precision function eello5(i,j,k,l,jj,kk)
7716 implicit real*8 (a-h,o-z)
7717 include 'DIMENSIONS'
7718 include 'COMMON.IOUNITS'
7719 include 'COMMON.CHAIN'
7720 include 'COMMON.DERIV'
7721 include 'COMMON.INTERACT'
7722 include 'COMMON.CONTACTS'
7723 include 'COMMON.TORSION'
7724 include 'COMMON.VAR'
7725 include 'COMMON.GEO'
7726 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7727 double precision ggg1(3),ggg2(3)
7728 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7733 C /l\ / \ \ / \ / \ / C
7734 C / \ / \ \ / \ / \ / C
7735 C j| o |l1 | o | o| o | | o |o C
7736 C \ |/k\| |/ \| / |/ \| |/ \| C
7737 C \i/ \ / \ / / \ / \ C
7739 C (I) (II) (III) (IV) C
7741 C eello5_1 eello5_2 eello5_3 eello5_4 C
7743 C Antiparallel chains C
7746 C /j\ / \ \ / \ / \ / C
7747 C / \ / \ \ / \ / \ / C
7748 C j1| o |l | o | o| o | | o |o C
7749 C \ |/k\| |/ \| / |/ \| |/ \| C
7750 C \i/ \ / \ / / \ / \ C
7752 C (I) (II) (III) (IV) C
7754 C eello5_1 eello5_2 eello5_3 eello5_4 C
7756 C o denotes a local interaction, vertical lines an electrostatic interaction. C
7758 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7759 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7764 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
7766 itk=itortyp(itype(k))
7767 itl=itortyp(itype(l))
7768 itj=itortyp(itype(j))
7773 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7774 cd & eel5_3_num,eel5_4_num)
7778 derx(lll,kkk,iii)=0.0d0
7782 cd eij=facont_hb(jj,i)
7783 cd ekl=facont_hb(kk,k)
7785 cd write (iout,*)'Contacts have occurred for peptide groups',
7786 cd & i,j,' fcont:',eij,' eij',' and ',k,l
7788 C Contribution from the graph I.
7789 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7790 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7791 call transpose2(EUg(1,1,k),auxmat(1,1))
7792 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7793 vv(1)=pizda(1,1)-pizda(2,2)
7794 vv(2)=pizda(1,2)+pizda(2,1)
7795 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7796 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7797 C Explicit gradient in virtual-dihedral angles.
7798 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7799 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7800 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7801 call transpose2(EUgder(1,1,k),auxmat1(1,1))
7802 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7803 vv(1)=pizda(1,1)-pizda(2,2)
7804 vv(2)=pizda(1,2)+pizda(2,1)
7805 g_corr5_loc(k-1)=g_corr5_loc(k-1)
7806 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7807 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7808 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7809 vv(1)=pizda(1,1)-pizda(2,2)
7810 vv(2)=pizda(1,2)+pizda(2,1)
7812 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7813 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7814 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7816 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7817 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7818 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7820 C Cartesian gradient
7824 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7826 vv(1)=pizda(1,1)-pizda(2,2)
7827 vv(2)=pizda(1,2)+pizda(2,1)
7828 derx(lll,kkk,iii)=derx(lll,kkk,iii)
7829 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7830 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7836 C Contribution from graph II
7837 call transpose2(EE(1,1,itk),auxmat(1,1))
7838 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7839 vv(1)=pizda(1,1)+pizda(2,2)
7840 vv(2)=pizda(2,1)-pizda(1,2)
7841 eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7842 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7843 C Explicit gradient in virtual-dihedral angles.
7844 g_corr5_loc(k-1)=g_corr5_loc(k-1)
7845 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7846 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7847 vv(1)=pizda(1,1)+pizda(2,2)
7848 vv(2)=pizda(2,1)-pizda(1,2)
7850 g_corr5_loc(l-1)=g_corr5_loc(l-1)
7851 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7852 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7854 g_corr5_loc(j-1)=g_corr5_loc(j-1)
7855 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7856 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7858 C Cartesian gradient
7862 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7864 vv(1)=pizda(1,1)+pizda(2,2)
7865 vv(2)=pizda(2,1)-pizda(1,2)
7866 derx(lll,kkk,iii)=derx(lll,kkk,iii)
7867 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7868 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7876 C Parallel orientation
7877 C Contribution from graph III
7878 call transpose2(EUg(1,1,l),auxmat(1,1))
7879 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7880 vv(1)=pizda(1,1)-pizda(2,2)
7881 vv(2)=pizda(1,2)+pizda(2,1)
7882 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7883 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7884 C Explicit gradient in virtual-dihedral angles.
7885 g_corr5_loc(j-1)=g_corr5_loc(j-1)
7886 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7887 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7888 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7889 vv(1)=pizda(1,1)-pizda(2,2)
7890 vv(2)=pizda(1,2)+pizda(2,1)
7891 g_corr5_loc(k-1)=g_corr5_loc(k-1)
7892 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7893 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7894 call transpose2(EUgder(1,1,l),auxmat1(1,1))
7895 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7896 vv(1)=pizda(1,1)-pizda(2,2)
7897 vv(2)=pizda(1,2)+pizda(2,1)
7898 g_corr5_loc(l-1)=g_corr5_loc(l-1)
7899 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7900 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7901 C Cartesian gradient
7905 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7907 vv(1)=pizda(1,1)-pizda(2,2)
7908 vv(2)=pizda(1,2)+pizda(2,1)
7909 derx(lll,kkk,iii)=derx(lll,kkk,iii)
7910 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7911 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7916 C Contribution from graph IV
7918 call transpose2(EE(1,1,itl),auxmat(1,1))
7919 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7920 vv(1)=pizda(1,1)+pizda(2,2)
7921 vv(2)=pizda(2,1)-pizda(1,2)
7922 eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7923 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
7924 C Explicit gradient in virtual-dihedral angles.
7925 g_corr5_loc(l-1)=g_corr5_loc(l-1)
7926 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7927 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7928 vv(1)=pizda(1,1)+pizda(2,2)
7929 vv(2)=pizda(2,1)-pizda(1,2)
7930 g_corr5_loc(k-1)=g_corr5_loc(k-1)
7931 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7932 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7933 C Cartesian gradient
7937 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7939 vv(1)=pizda(1,1)+pizda(2,2)
7940 vv(2)=pizda(2,1)-pizda(1,2)
7941 derx(lll,kkk,iii)=derx(lll,kkk,iii)
7942 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7943 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
7948 C Antiparallel orientation
7949 C Contribution from graph III
7951 call transpose2(EUg(1,1,j),auxmat(1,1))
7952 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7953 vv(1)=pizda(1,1)-pizda(2,2)
7954 vv(2)=pizda(1,2)+pizda(2,1)
7955 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7956 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7957 C Explicit gradient in virtual-dihedral angles.
7958 g_corr5_loc(l-1)=g_corr5_loc(l-1)
7959 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7960 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7961 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7962 vv(1)=pizda(1,1)-pizda(2,2)
7963 vv(2)=pizda(1,2)+pizda(2,1)
7964 g_corr5_loc(k-1)=g_corr5_loc(k-1)
7965 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7966 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7967 call transpose2(EUgder(1,1,j),auxmat1(1,1))
7968 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7969 vv(1)=pizda(1,1)-pizda(2,2)
7970 vv(2)=pizda(1,2)+pizda(2,1)
7971 g_corr5_loc(j-1)=g_corr5_loc(j-1)
7972 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7973 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7974 C Cartesian gradient
7978 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7980 vv(1)=pizda(1,1)-pizda(2,2)
7981 vv(2)=pizda(1,2)+pizda(2,1)
7982 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7983 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7984 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7989 C Contribution from graph IV
7991 call transpose2(EE(1,1,itj),auxmat(1,1))
7992 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7993 vv(1)=pizda(1,1)+pizda(2,2)
7994 vv(2)=pizda(2,1)-pizda(1,2)
7995 eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7996 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
7997 C Explicit gradient in virtual-dihedral angles.
7998 g_corr5_loc(j-1)=g_corr5_loc(j-1)
7999 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8000 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8001 vv(1)=pizda(1,1)+pizda(2,2)
8002 vv(2)=pizda(2,1)-pizda(1,2)
8003 g_corr5_loc(k-1)=g_corr5_loc(k-1)
8004 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8005 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8006 C Cartesian gradient
8010 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8012 vv(1)=pizda(1,1)+pizda(2,2)
8013 vv(2)=pizda(2,1)-pizda(1,2)
8014 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8015 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8016 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
8022 eel5=eello5_1+eello5_2+eello5_3+eello5_4
8023 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8024 cd write (2,*) 'ijkl',i,j,k,l
8025 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8026 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
8028 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8029 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8030 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8031 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8032 if (j.lt.nres-1) then
8039 if (l.lt.nres-1) then
8049 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8050 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8051 C summed up outside the subrouine as for the other subroutines
8052 C handling long-range interactions. The old code is commented out
8053 C with "cgrad" to keep track of changes.
8055 cgrad ggg1(ll)=eel5*g_contij(ll,1)
8056 cgrad ggg2(ll)=eel5*g_contij(ll,2)
8057 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8058 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8059 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8060 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8061 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8062 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8063 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8064 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8066 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8067 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8068 cgrad ghalf=0.5d0*ggg1(ll)
8070 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8071 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8072 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8073 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8074 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8075 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8076 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8077 cgrad ghalf=0.5d0*ggg2(ll)
8079 gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8080 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8081 gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8082 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8083 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8084 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8089 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8090 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8095 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8096 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8102 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8107 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8111 cd write (2,*) iii,g_corr5_loc(iii)
8114 cd write (2,*) 'ekont',ekont
8115 cd write (iout,*) 'eello5',ekont*eel5
8118 c--------------------------------------------------------------------------
8119 double precision function eello6(i,j,k,l,jj,kk)
8120 implicit real*8 (a-h,o-z)
8121 include 'DIMENSIONS'
8122 include 'COMMON.IOUNITS'
8123 include 'COMMON.CHAIN'
8124 include 'COMMON.DERIV'
8125 include 'COMMON.INTERACT'
8126 include 'COMMON.CONTACTS'
8127 include 'COMMON.TORSION'
8128 include 'COMMON.VAR'
8129 include 'COMMON.GEO'
8130 include 'COMMON.FFIELD'
8131 double precision ggg1(3),ggg2(3)
8132 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8137 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
8145 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8146 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8150 derx(lll,kkk,iii)=0.0d0
8154 cd eij=facont_hb(jj,i)
8155 cd ekl=facont_hb(kk,k)
8161 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8162 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8163 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8164 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8165 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8166 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8168 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8169 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8170 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8171 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8172 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8173 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8177 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8179 C If turn contributions are considered, they will be handled separately.
8180 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8181 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8182 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8183 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8184 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8185 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8186 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8188 if (j.lt.nres-1) then
8195 if (l.lt.nres-1) then
8203 cgrad ggg1(ll)=eel6*g_contij(ll,1)
8204 cgrad ggg2(ll)=eel6*g_contij(ll,2)
8205 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8206 cgrad ghalf=0.5d0*ggg1(ll)
8208 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8209 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8210 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8211 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8212 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8213 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8214 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8215 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8216 cgrad ghalf=0.5d0*ggg2(ll)
8217 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8219 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8220 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8221 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8222 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8223 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8224 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8229 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8230 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8235 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8236 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8242 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8247 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8251 cd write (2,*) iii,g_corr6_loc(iii)
8254 cd write (2,*) 'ekont',ekont
8255 cd write (iout,*) 'eello6',ekont*eel6
8258 c--------------------------------------------------------------------------
8259 double precision function eello6_graph1(i,j,k,l,imat,swap)
8260 implicit real*8 (a-h,o-z)
8261 include 'DIMENSIONS'
8262 include 'COMMON.IOUNITS'
8263 include 'COMMON.CHAIN'
8264 include 'COMMON.DERIV'
8265 include 'COMMON.INTERACT'
8266 include 'COMMON.CONTACTS'
8267 include 'COMMON.TORSION'
8268 include 'COMMON.VAR'
8269 include 'COMMON.GEO'
8270 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8274 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8276 C Parallel Antiparallel C
8282 C \ j|/k\| / \ |/k\|l / C
8287 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8288 itk=itortyp(itype(k))
8289 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8290 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8291 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8292 call transpose2(EUgC(1,1,k),auxmat(1,1))
8293 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8294 vv1(1)=pizda1(1,1)-pizda1(2,2)
8295 vv1(2)=pizda1(1,2)+pizda1(2,1)
8296 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8297 vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8298 vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8299 s5=scalar2(vv(1),Dtobr2(1,i))
8300 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8301 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8302 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8303 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8304 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8305 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8306 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8307 & +scalar2(vv(1),Dtobr2der(1,i)))
8308 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8309 vv1(1)=pizda1(1,1)-pizda1(2,2)
8310 vv1(2)=pizda1(1,2)+pizda1(2,1)
8311 vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8312 vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8314 g_corr6_loc(l-1)=g_corr6_loc(l-1)
8315 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8316 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8317 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8318 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8320 g_corr6_loc(j-1)=g_corr6_loc(j-1)
8321 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8322 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8323 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8324 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8326 call transpose2(EUgCder(1,1,k),auxmat(1,1))
8327 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8328 vv1(1)=pizda1(1,1)-pizda1(2,2)
8329 vv1(2)=pizda1(1,2)+pizda1(2,1)
8330 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8331 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8332 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8333 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8342 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8343 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8344 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8345 call transpose2(EUgC(1,1,k),auxmat(1,1))
8346 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8348 vv1(1)=pizda1(1,1)-pizda1(2,2)
8349 vv1(2)=pizda1(1,2)+pizda1(2,1)
8350 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8351 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8352 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8353 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8354 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8355 s5=scalar2(vv(1),Dtobr2(1,i))
8356 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8362 c----------------------------------------------------------------------------
8363 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8364 implicit real*8 (a-h,o-z)
8365 include 'DIMENSIONS'
8366 include 'COMMON.IOUNITS'
8367 include 'COMMON.CHAIN'
8368 include 'COMMON.DERIV'
8369 include 'COMMON.INTERACT'
8370 include 'COMMON.CONTACTS'
8371 include 'COMMON.TORSION'
8372 include 'COMMON.VAR'
8373 include 'COMMON.GEO'
8375 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8376 & auxvec1(2),auxvec2(2),auxmat1(2,2)
8379 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8381 C Parallel Antiparallel C
8387 C \ j|/k\| \ |/k\|l C
8392 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8393 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8394 C AL 7/4/01 s1 would occur in the sixth-order moment,
8395 C but not in a cluster cumulant
8397 s1=dip(1,jj,i)*dip(1,kk,k)
8399 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8400 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8401 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8402 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8403 call transpose2(EUg(1,1,k),auxmat(1,1))
8404 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8405 vv(1)=pizda(1,1)-pizda(2,2)
8406 vv(2)=pizda(1,2)+pizda(2,1)
8407 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8408 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8410 eello6_graph2=-(s1+s2+s3+s4)
8412 eello6_graph2=-(s2+s3+s4)
8415 C Derivatives in gamma(i-1)
8418 s1=dipderg(1,jj,i)*dip(1,kk,k)
8420 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8421 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8422 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8423 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8425 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8427 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8429 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8431 C Derivatives in gamma(k-1)
8433 s1=dip(1,jj,i)*dipderg(1,kk,k)
8435 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8436 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8437 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8438 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8439 call transpose2(EUgder(1,1,k),auxmat1(1,1))
8440 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8441 vv(1)=pizda(1,1)-pizda(2,2)
8442 vv(2)=pizda(1,2)+pizda(2,1)
8443 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8445 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8447 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8449 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8450 C Derivatives in gamma(j-1) or gamma(l-1)
8453 s1=dipderg(3,jj,i)*dip(1,kk,k)
8455 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8456 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8457 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8458 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8459 vv(1)=pizda(1,1)-pizda(2,2)
8460 vv(2)=pizda(1,2)+pizda(2,1)
8461 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8464 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8466 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8469 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8470 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8472 C Derivatives in gamma(l-1) or gamma(j-1)
8475 s1=dip(1,jj,i)*dipderg(3,kk,k)
8477 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8478 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8479 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8480 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8481 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8482 vv(1)=pizda(1,1)-pizda(2,2)
8483 vv(2)=pizda(1,2)+pizda(2,1)
8484 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8487 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8489 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8492 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8493 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8495 C Cartesian derivatives.
8497 write (2,*) 'In eello6_graph2'
8499 write (2,*) 'iii=',iii
8501 write (2,*) 'kkk=',kkk
8503 write (2,'(3(2f10.5),5x)')
8504 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8514 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8516 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8519 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8521 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8522 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8524 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8525 call transpose2(EUg(1,1,k),auxmat(1,1))
8526 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8528 vv(1)=pizda(1,1)-pizda(2,2)
8529 vv(2)=pizda(1,2)+pizda(2,1)
8530 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8531 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8533 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8535 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8538 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8540 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8547 c----------------------------------------------------------------------------
8548 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8549 implicit real*8 (a-h,o-z)
8550 include 'DIMENSIONS'
8551 include 'COMMON.IOUNITS'
8552 include 'COMMON.CHAIN'
8553 include 'COMMON.DERIV'
8554 include 'COMMON.INTERACT'
8555 include 'COMMON.CONTACTS'
8556 include 'COMMON.TORSION'
8557 include 'COMMON.VAR'
8558 include 'COMMON.GEO'
8559 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8561 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8563 C Parallel Antiparallel C
8569 C j|/k\| / |/k\|l / C
8574 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8576 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8577 C energy moment and not to the cluster cumulant.
8578 iti=itortyp(itype(i))
8579 if (j.lt.nres-1) then
8580 itj1=itortyp(itype(j+1))
8584 itk=itortyp(itype(k))
8585 itk1=itortyp(itype(k+1))
8586 if (l.lt.nres-1) then
8587 itl1=itortyp(itype(l+1))
8592 s1=dip(4,jj,i)*dip(4,kk,k)
8594 call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8595 s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8596 call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8597 s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8598 call transpose2(EE(1,1,itk),auxmat(1,1))
8599 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8600 vv(1)=pizda(1,1)+pizda(2,2)
8601 vv(2)=pizda(2,1)-pizda(1,2)
8602 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8603 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8604 cd & "sum",-(s2+s3+s4)
8606 eello6_graph3=-(s1+s2+s3+s4)
8608 eello6_graph3=-(s2+s3+s4)
8611 C Derivatives in gamma(k-1)
8612 call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8613 s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8614 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8615 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8616 C Derivatives in gamma(l-1)
8617 call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8618 s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8619 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8620 vv(1)=pizda(1,1)+pizda(2,2)
8621 vv(2)=pizda(2,1)-pizda(1,2)
8622 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8623 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8624 C Cartesian derivatives.
8630 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8632 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8635 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8637 s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8638 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8640 s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8641 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8643 vv(1)=pizda(1,1)+pizda(2,2)
8644 vv(2)=pizda(2,1)-pizda(1,2)
8645 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8647 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8649 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8652 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8654 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8656 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8662 c----------------------------------------------------------------------------
8663 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8664 implicit real*8 (a-h,o-z)
8665 include 'DIMENSIONS'
8666 include 'COMMON.IOUNITS'
8667 include 'COMMON.CHAIN'
8668 include 'COMMON.DERIV'
8669 include 'COMMON.INTERACT'
8670 include 'COMMON.CONTACTS'
8671 include 'COMMON.TORSION'
8672 include 'COMMON.VAR'
8673 include 'COMMON.GEO'
8674 include 'COMMON.FFIELD'
8675 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8676 & auxvec1(2),auxmat1(2,2)
8678 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8680 C Parallel Antiparallel C
8686 C \ j|/k\| \ |/k\|l C
8691 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8693 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8694 C energy moment and not to the cluster cumulant.
8695 cd write (2,*) 'eello_graph4: wturn6',wturn6
8696 iti=itortyp(itype(i))
8697 itj=itortyp(itype(j))
8698 if (j.lt.nres-1) then
8699 itj1=itortyp(itype(j+1))
8703 itk=itortyp(itype(k))
8704 if (k.lt.nres-1) then
8705 itk1=itortyp(itype(k+1))
8709 itl=itortyp(itype(l))
8710 if (l.lt.nres-1) then
8711 itl1=itortyp(itype(l+1))
8715 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8716 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8717 cd & ' itl',itl,' itl1',itl1
8720 s1=dip(3,jj,i)*dip(3,kk,k)
8722 s1=dip(2,jj,j)*dip(2,kk,l)
8725 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8726 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8728 call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8729 s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8731 call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8732 s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8734 call transpose2(EUg(1,1,k),auxmat(1,1))
8735 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8736 vv(1)=pizda(1,1)-pizda(2,2)
8737 vv(2)=pizda(2,1)+pizda(1,2)
8738 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8739 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8741 eello6_graph4=-(s1+s2+s3+s4)
8743 eello6_graph4=-(s2+s3+s4)
8745 C Derivatives in gamma(i-1)
8749 s1=dipderg(2,jj,i)*dip(3,kk,k)
8751 s1=dipderg(4,jj,j)*dip(2,kk,l)
8754 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8756 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8757 s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8759 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8760 s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8762 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8763 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8764 cd write (2,*) 'turn6 derivatives'
8766 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8768 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8772 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8774 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8778 C Derivatives in gamma(k-1)
8781 s1=dip(3,jj,i)*dipderg(2,kk,k)
8783 s1=dip(2,jj,j)*dipderg(4,kk,l)
8786 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8787 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8789 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8790 s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8792 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8793 s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8795 call transpose2(EUgder(1,1,k),auxmat1(1,1))
8796 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8797 vv(1)=pizda(1,1)-pizda(2,2)
8798 vv(2)=pizda(2,1)+pizda(1,2)
8799 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8800 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8802 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8804 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8808 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8810 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8813 C Derivatives in gamma(j-1) or gamma(l-1)
8814 if (l.eq.j+1 .and. l.gt.1) then
8815 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8816 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8817 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8818 vv(1)=pizda(1,1)-pizda(2,2)
8819 vv(2)=pizda(2,1)+pizda(1,2)
8820 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8821 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8822 else if (j.gt.1) then
8823 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8824 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8825 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8826 vv(1)=pizda(1,1)-pizda(2,2)
8827 vv(2)=pizda(2,1)+pizda(1,2)
8828 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8829 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8830 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8832 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8835 C Cartesian derivatives.
8842 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8844 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8848 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8850 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8854 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8856 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8858 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8859 & b1(1,itj1),auxvec(1))
8860 s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8862 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8863 & b1(1,itl1),auxvec(1))
8864 s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8866 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8868 vv(1)=pizda(1,1)-pizda(2,2)
8869 vv(2)=pizda(2,1)+pizda(1,2)
8870 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8872 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8874 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8877 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8880 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8883 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8885 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8887 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8891 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8893 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8896 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8898 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8906 c----------------------------------------------------------------------------
8907 double precision function eello_turn6(i,jj,kk)
8908 implicit real*8 (a-h,o-z)
8909 include 'DIMENSIONS'
8910 include 'COMMON.IOUNITS'
8911 include 'COMMON.CHAIN'
8912 include 'COMMON.DERIV'
8913 include 'COMMON.INTERACT'
8914 include 'COMMON.CONTACTS'
8915 include 'COMMON.TORSION'
8916 include 'COMMON.VAR'
8917 include 'COMMON.GEO'
8918 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8919 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8921 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8922 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8923 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8924 C the respective energy moment and not to the cluster cumulant.
8933 iti=itortyp(itype(i))
8934 itk=itortyp(itype(k))
8935 itk1=itortyp(itype(k+1))
8936 itl=itortyp(itype(l))
8937 itj=itortyp(itype(j))
8938 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8939 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
8940 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8945 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
8947 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
8951 derx_turn(lll,kkk,iii)=0.0d0
8958 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8960 cd write (2,*) 'eello6_5',eello6_5
8962 call transpose2(AEA(1,1,1),auxmat(1,1))
8963 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8964 ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8965 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8967 call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8968 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8969 s2 = scalar2(b1(1,itk),vtemp1(1))
8971 call transpose2(AEA(1,1,2),atemp(1,1))
8972 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8973 call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8974 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8976 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8977 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8978 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8980 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8981 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8982 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8983 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8984 ss13 = scalar2(b1(1,itk),vtemp4(1))
8985 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8987 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8993 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8994 C Derivatives in gamma(i+2)
8998 call transpose2(AEA(1,1,1),auxmatd(1,1))
8999 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9000 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9001 call transpose2(AEAderg(1,1,2),atempd(1,1))
9002 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9003 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9005 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9006 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9007 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9013 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9014 C Derivatives in gamma(i+3)
9016 call transpose2(AEA(1,1,1),auxmatd(1,1))
9017 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9018 ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9019 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9021 call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9022 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9023 s2d = scalar2(b1(1,itk),vtemp1d(1))
9025 call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9026 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9028 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9030 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9031 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9032 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9040 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9041 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9043 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9044 & -0.5d0*ekont*(s2d+s12d)
9046 C Derivatives in gamma(i+4)
9047 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9048 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9049 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9051 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9052 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9053 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9061 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9063 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9065 C Derivatives in gamma(i+5)
9067 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9068 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9069 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9071 call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9072 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9073 s2d = scalar2(b1(1,itk),vtemp1d(1))
9075 call transpose2(AEA(1,1,2),atempd(1,1))
9076 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9077 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9079 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9080 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9082 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9083 ss13d = scalar2(b1(1,itk),vtemp4d(1))
9084 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9092 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9093 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9095 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9096 & -0.5d0*ekont*(s2d+s12d)
9098 C Cartesian derivatives
9103 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9104 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9105 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9107 call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9108 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9110 s2d = scalar2(b1(1,itk),vtemp1d(1))
9112 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9113 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9114 s8d = -(atempd(1,1)+atempd(2,2))*
9115 & scalar2(cc(1,1,itl),vtemp2(1))
9117 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9119 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9120 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9127 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9130 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9134 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9135 & - 0.5d0*(s8d+s12d)
9137 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9146 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9148 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9149 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9150 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9151 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9152 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9154 ss13d = scalar2(b1(1,itk),vtemp4d(1))
9155 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9156 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9160 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9161 cd & 16*eel_turn6_num
9163 if (j.lt.nres-1) then
9170 if (l.lt.nres-1) then
9178 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
9179 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
9180 cgrad ghalf=0.5d0*ggg1(ll)
9182 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9183 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9184 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9185 & +ekont*derx_turn(ll,2,1)
9186 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9187 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9188 & +ekont*derx_turn(ll,4,1)
9189 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9190 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9191 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9192 cgrad ghalf=0.5d0*ggg2(ll)
9194 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9195 & +ekont*derx_turn(ll,2,2)
9196 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9197 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9198 & +ekont*derx_turn(ll,4,2)
9199 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9200 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9201 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9206 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9211 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9217 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9222 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9226 cd write (2,*) iii,g_corr6_loc(iii)
9228 eello_turn6=ekont*eel_turn6
9229 cd write (2,*) 'ekont',ekont
9230 cd write (2,*) 'eel_turn6',ekont*eel_turn6
9234 C-----------------------------------------------------------------------------
9235 double precision function scalar(u,v)
9236 !DIR$ INLINEALWAYS scalar
9238 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9241 double precision u(3),v(3)
9242 cd double precision sc
9250 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9253 crc-------------------------------------------------
9254 SUBROUTINE MATVEC2(A1,V1,V2)
9255 !DIR$ INLINEALWAYS MATVEC2
9257 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9259 implicit real*8 (a-h,o-z)
9260 include 'DIMENSIONS'
9261 DIMENSION A1(2,2),V1(2),V2(2)
9265 c 3 VI=VI+A1(I,K)*V1(K)
9269 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9270 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9275 C---------------------------------------
9276 SUBROUTINE MATMAT2(A1,A2,A3)
9278 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9280 implicit real*8 (a-h,o-z)
9281 include 'DIMENSIONS'
9282 DIMENSION A1(2,2),A2(2,2),A3(2,2)
9283 c DIMENSION AI3(2,2)
9287 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
9293 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9294 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9295 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9296 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9304 c-------------------------------------------------------------------------
9305 double precision function scalar2(u,v)
9306 !DIR$ INLINEALWAYS scalar2
9308 double precision u(2),v(2)
9311 scalar2=u(1)*v(1)+u(2)*v(2)
9315 C-----------------------------------------------------------------------------
9317 subroutine transpose2(a,at)
9318 !DIR$ INLINEALWAYS transpose2
9320 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9323 double precision a(2,2),at(2,2)
9330 c--------------------------------------------------------------------------
9331 subroutine transpose(n,a,at)
9334 double precision a(n,n),at(n,n)
9342 C---------------------------------------------------------------------------
9343 subroutine prodmat3(a1,a2,kk,transp,prod)
9344 !DIR$ INLINEALWAYS prodmat3
9346 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9350 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9352 crc double precision auxmat(2,2),prod_(2,2)
9355 crc call transpose2(kk(1,1),auxmat(1,1))
9356 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9357 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9359 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9360 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9361 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9362 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9363 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9364 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9365 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9366 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9369 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9370 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9372 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9373 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9374 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9375 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9376 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9377 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9378 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9379 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9382 c call transpose2(a2(1,1),a2t(1,1))
9385 crc print *,((prod_(i,j),i=1,2),j=1,2)
9386 crc print *,((prod(i,j),i=1,2),j=1,2)