1 subroutine etotal(energia)
2 implicit real*8 (a-h,o-z)
7 cMS$ATTRIBUTES C :: proc_proc
12 double precision weights_(n_ene)
14 include 'COMMON.SETUP'
15 include 'COMMON.IOUNITS'
16 double precision energia(0:n_ene)
17 include 'COMMON.LOCAL'
18 include 'COMMON.FFIELD'
19 include 'COMMON.DERIV'
20 include 'COMMON.INTERACT'
21 include 'COMMON.SBRIDGE'
22 include 'COMMON.CHAIN'
25 include 'COMMON.CONTROL'
26 include 'COMMON.TIME1'
28 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
29 c & " nfgtasks",nfgtasks
31 if (nfgtasks.gt.1) then
37 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
38 if (fg_rank.eq.0) then
39 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
40 c print *,"Processor",myrank," BROADCAST iorder"
41 C FG master sets up the WEIGHTS_ array which will be broadcast to the
42 C FG slaves as WEIGHTS array.
63 C FG Master broadcasts the WEIGHTS_ array
64 call MPI_Bcast(weights_(1),n_ene,
65 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
67 C FG slaves receive the WEIGHTS array
68 call MPI_Bcast(weights(1),n_ene,
69 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
91 time_Bcast=time_Bcast+MPI_Wtime()-time00
92 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
93 c call chainbuild_cart
95 c write(iout,*) 'Processor',myrank,' calling etotal ipot=',ipot
96 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
98 c if (modecalc.eq.12.or.modecalc.eq.14) then
99 c call int_from_cart1(.false.)
116 C Compute the side-chain and electrostatic interaction energy
118 goto (101,102,103,104,105,106) ipot
119 C Lennard-Jones potential.
120 101 call elj(evdw,evdw_p,evdw_m)
121 cd print '(a)','Exit ELJ'
123 C Lennard-Jones-Kihara potential (shifted).
124 102 call eljk(evdw,evdw_p,evdw_m)
126 C Berne-Pechukas potential (dilated LJ, angular dependence).
127 103 call ebp(evdw,evdw_p,evdw_m)
129 C Gay-Berne potential (shifted LJ, angular dependence).
130 104 call egb(evdw,evdw_p,evdw_m)
132 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
133 105 call egbv(evdw,evdw_p,evdw_m)
135 C Soft-sphere potential
136 106 call e_softsphere(evdw)
138 C Calculate electrostatic (H-bonding) energy of the main chain.
142 C BARTEK for dfa test!
143 if (wdfa_dist.gt.0) then
148 c print*, 'edfad is finished!', edfadis
149 if (wdfa_tor.gt.0) then
154 c print*, 'edfat is finished!', edfator
155 if (wdfa_nei.gt.0) then
160 c print*, 'edfan is finished!', edfanei
161 if (wdfa_beta.gt.0) then
167 c print*, 'edfab is finished!', edfabet
169 cmc Sep-06: egb takes care of dynamic ss bonds too
171 c if (dyn_ss) call dyn_set_nss
173 c print *,"Processor",myrank," computed USCSC"
184 time_vec=time_vec+MPI_Wtime()-time01
186 time_vec=time_vec+tcpu()-time01
189 c print *,"Processor",myrank," left VEC_AND_DERIV"
192 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
193 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
194 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
195 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
197 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
198 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
199 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
200 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
202 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
211 c write (iout,*) "Soft-spheer ELEC potential"
212 call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
215 c print *,"Processor",myrank," computed UELEC"
217 C Calculate excluded-volume interaction energy between peptide groups
222 call escp(evdw2,evdw2_14)
228 c write (iout,*) "Soft-sphere SCP potential"
229 call escp_soft_sphere(evdw2,evdw2_14)
232 c Calculate the bond-stretching energy
236 C Calculate the disulfide-bridge and other energy and the contributions
237 C from other distance constraints.
238 cd print *,'Calling EHPB'
240 cd print *,'EHPB exitted succesfully.'
242 C Calculate the virtual-bond-angle energy.
244 if (wang.gt.0d0) then
249 c print *,"Processor",myrank," computed UB"
251 C Calculate the SC local energy.
254 c print *,"Processor",myrank," computed USC"
256 C Calculate the virtual-bond torsional energy.
258 cd print *,'nterm=',nterm
260 call etor(etors,edihcnstr)
266 if (constr_homology.ge.1.and.waga_homology(iset).ne.0d0) then
267 call e_modeller(ehomology_constr)
268 c print *,'iset=',iset,'me=',me,ehomology_constr,
269 c & 'Processor',fg_rank,' CG group',kolor,
270 c & ' absolute rank',MyRank
272 ehomology_constr=0.0d0
276 c write(iout,*) ehomology_constr
277 c print *,"Processor",myrank," computed Utor"
279 C 6/23/01 Calculate double-torsional energy
281 if (wtor_d.gt.0) then
286 c print *,"Processor",myrank," computed Utord"
288 C 21/5/07 Calculate local sicdechain correlation energy
290 if (wsccor.gt.0.0d0) then
291 call eback_sc_corr(esccor)
295 c print *,"Processor",myrank," computed Usccorr"
297 C 12/1/95 Multi-body terms
301 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
302 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
303 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
304 cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
305 cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
312 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
313 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
314 cd write (iout,*) "multibody_hb ecorr",ecorr
316 c print *,"Processor",myrank," computed Ucorr"
318 C If performing constraint dynamics, call the constraint energy
319 C after the equilibration time
320 if(usampl.and.totT.gt.eq_time) then
321 c write (iout,*) "CALL TO ECONSTR_BACK"
330 time_enecalc=time_enecalc+MPI_Wtime()-time00
332 time_enecalc=time_enecalc+tcpu()-time00
335 c print *,"Processor",myrank," computed Uconstr"
348 energia(2)=evdw2-evdw2_14
365 energia(8)=eello_turn3
366 energia(9)=eello_turn4
373 energia(19)=edihcnstr
375 energia(20)=Uconst+Uconst_back
379 energia(24)=ehomology_constr
384 c print *," Processor",myrank," calls SUM_ENERGY"
385 call sum_energy(energia,.true.)
386 if (dyn_ss) call dyn_set_nss
387 c print *," Processor",myrank," left SUM_ENERGY"
390 time_sumene=time_sumene+MPI_Wtime()-time00
392 time_sumene=time_sumene+tcpu()-time00
397 c-------------------------------------------------------------------------------
398 subroutine sum_energy(energia,reduce)
399 implicit real*8 (a-h,o-z)
404 cMS$ATTRIBUTES C :: proc_proc
410 include 'COMMON.SETUP'
411 include 'COMMON.IOUNITS'
412 double precision energia(0:n_ene),enebuff(0:n_ene+1)
413 include 'COMMON.FFIELD'
414 include 'COMMON.DERIV'
415 include 'COMMON.INTERACT'
416 include 'COMMON.SBRIDGE'
417 include 'COMMON.CHAIN'
419 include 'COMMON.CONTROL'
420 include 'COMMON.TIME1'
423 if (nfgtasks.gt.1 .and. reduce) then
425 write (iout,*) "energies before REDUCE"
426 call enerprint(energia)
430 enebuff(i)=energia(i)
433 call MPI_Barrier(FG_COMM,IERR)
434 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
436 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
437 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
439 write (iout,*) "energies after REDUCE"
440 call enerprint(energia)
443 time_Reduce=time_Reduce+MPI_Wtime()-time00
445 if (fg_rank.eq.0) then
448 evdw=energia(22)+wsct*energia(23)
453 evdw2=energia(2)+energia(18)
469 eello_turn3=energia(8)
470 eello_turn4=energia(9)
477 edihcnstr=energia(19)
481 ehomology_constr=energia(24)
487 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
488 & +wang*ebe+wtor*etors+wscloc*escloc
489 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
490 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
491 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
492 & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
493 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
496 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
497 & +wang*ebe+wtor*etors+wscloc*escloc
498 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
499 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
500 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
501 & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
502 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
509 if (isnan(etot).ne.0) energia(0)=1.0d+99
511 if (isnan(etot)) energia(0)=1.0d+99
516 idumm=proc_proc(etot,i)
518 call proc_proc(etot,i)
520 if(i.eq.1)energia(0)=1.0d+99
527 c-------------------------------------------------------------------------------
528 subroutine sum_gradient
529 implicit real*8 (a-h,o-z)
534 cMS$ATTRIBUTES C :: proc_proc
540 double precision gradbufc(3,maxres),gradbufx(3,maxres),
541 & glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
542 include 'COMMON.SETUP'
543 include 'COMMON.IOUNITS'
544 include 'COMMON.FFIELD'
545 include 'COMMON.DERIV'
546 include 'COMMON.INTERACT'
547 include 'COMMON.SBRIDGE'
548 include 'COMMON.CHAIN'
550 include 'COMMON.CONTROL'
551 include 'COMMON.TIME1'
552 include 'COMMON.MAXGRAD'
553 include 'COMMON.SCCOR'
563 write (iout,*) "sum_gradient gvdwc, gvdwx"
565 write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
566 & i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
567 & (gvdwcT(j,i),j=1,3)
572 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
573 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
574 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
577 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
578 C in virtual-bond-vector coordinates
581 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
583 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
584 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
586 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
588 c write (iout,'(i5,3f10.5,2x,f10.5)')
589 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
591 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
593 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
594 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
603 gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
604 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
605 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
606 & wel_loc*gel_loc_long(j,i)+
607 & wcorr*gradcorr_long(j,i)+
608 & wcorr5*gradcorr5_long(j,i)+
609 & wcorr6*gradcorr6_long(j,i)+
610 & wturn6*gcorr6_turn_long(j,i)+
611 & wstrain*ghpbc(j,i)+
612 & wdfa_dist*gdfad(j,i)+
613 & wdfa_tor*gdfat(j,i)+
614 & wdfa_nei*gdfan(j,i)+
615 & wdfa_beta*gdfab(j,i)
621 gradbufc(j,i)=wsc*gvdwc(j,i)+
622 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
623 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
624 & wel_loc*gel_loc_long(j,i)+
625 & wcorr*gradcorr_long(j,i)+
626 & wcorr5*gradcorr5_long(j,i)+
627 & wcorr6*gradcorr6_long(j,i)+
628 & wturn6*gcorr6_turn_long(j,i)+
629 & wstrain*ghpbc(j,i)+
630 & wdfa_dist*gdfad(j,i)+
631 & wdfa_tor*gdfat(j,i)+
632 & wdfa_nei*gdfan(j,i)+
633 & wdfa_beta*gdfab(j,i)
640 gradbufc(j,i)=wsc*gvdwc(j,i)+
641 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
642 & welec*gelc_long(j,i)+
644 & wel_loc*gel_loc_long(j,i)+
645 & wcorr*gradcorr_long(j,i)+
646 & wcorr5*gradcorr5_long(j,i)+
647 & wcorr6*gradcorr6_long(j,i)+
648 & wturn6*gcorr6_turn_long(j,i)+
649 & wstrain*ghpbc(j,i)+
650 & wdfa_dist*gdfad(j,i)+
651 & wdfa_tor*gdfat(j,i)+
652 & wdfa_nei*gdfan(j,i)+
653 & wdfa_beta*gdfab(j,i)
658 if (nfgtasks.gt.1) then
661 write (iout,*) "gradbufc before allreduce"
663 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
669 gradbufc_sum(j,i)=gradbufc(j,i)
672 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
673 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
674 c time_reduce=time_reduce+MPI_Wtime()-time00
676 c write (iout,*) "gradbufc_sum after allreduce"
678 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
683 c time_allreduce=time_allreduce+MPI_Wtime()-time00
691 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
692 write (iout,*) (i," jgrad_start",jgrad_start(i),
693 & " jgrad_end ",jgrad_end(i),
694 & i=igrad_start,igrad_end)
697 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
698 c do not parallelize this part.
700 c do i=igrad_start,igrad_end
701 c do j=jgrad_start(i),jgrad_end(i)
703 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
708 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
712 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
716 write (iout,*) "gradbufc after summing"
718 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
725 write (iout,*) "gradbufc"
727 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
733 gradbufc_sum(j,i)=gradbufc(j,i)
738 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
742 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
747 c gradbufc(k,i)=0.0d0
751 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
756 write (iout,*) "gradbufc after summing"
758 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
766 gradbufc(k,nres)=0.0d0
771 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
772 & wel_loc*gel_loc(j,i)+
773 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
774 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
775 & wel_loc*gel_loc_long(j,i)+
776 & wcorr*gradcorr_long(j,i)+
777 & wcorr5*gradcorr5_long(j,i)+
778 & wcorr6*gradcorr6_long(j,i)+
779 & wturn6*gcorr6_turn_long(j,i))+
781 & wcorr*gradcorr(j,i)+
782 & wturn3*gcorr3_turn(j,i)+
783 & wturn4*gcorr4_turn(j,i)+
784 & wcorr5*gradcorr5(j,i)+
785 & wcorr6*gradcorr6(j,i)+
786 & wturn6*gcorr6_turn(j,i)+
787 & wsccor*gsccorc(j,i)
788 & +wscloc*gscloc(j,i)
790 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
791 & wel_loc*gel_loc(j,i)+
792 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
793 & welec*gelc_long(j,i)+
794 & wel_loc*gel_loc_long(j,i)+
795 & wcorr*gcorr_long(j,i)+
796 & wcorr5*gradcorr5_long(j,i)+
797 & wcorr6*gradcorr6_long(j,i)+
798 & wturn6*gcorr6_turn_long(j,i))+
800 & wcorr*gradcorr(j,i)+
801 & wturn3*gcorr3_turn(j,i)+
802 & wturn4*gcorr4_turn(j,i)+
803 & wcorr5*gradcorr5(j,i)+
804 & wcorr6*gradcorr6(j,i)+
805 & wturn6*gcorr6_turn(j,i)+
806 & wsccor*gsccorc(j,i)
807 & +wscloc*gscloc(j,i)
810 gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
811 & wscp*gradx_scp(j,i)+
813 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
814 & wsccor*gsccorx(j,i)
815 & +wscloc*gsclocx(j,i)
817 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
819 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
820 & wsccor*gsccorx(j,i)
821 & +wscloc*gsclocx(j,i)
825 if (constr_homology.gt.0.and.waga_homology(iset).ne.0d0) then
828 gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
829 gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
834 write (iout,*) "gloc before adding corr"
836 write (iout,*) i,gloc(i,icg)
840 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
841 & +wcorr5*g_corr5_loc(i)
842 & +wcorr6*g_corr6_loc(i)
843 & +wturn4*gel_loc_turn4(i)
844 & +wturn3*gel_loc_turn3(i)
845 & +wturn6*gel_loc_turn6(i)
846 & +wel_loc*gel_loc_loc(i)
849 write (iout,*) "gloc after adding corr"
851 write (iout,*) i,gloc(i,icg)
855 if (nfgtasks.gt.1) then
858 gradbufc(j,i)=gradc(j,i,icg)
859 gradbufx(j,i)=gradx(j,i,icg)
863 glocbuf(i)=gloc(i,icg)
866 write (iout,*) "gloc_sc before reduce"
869 write (iout,*) i,j,gloc_sc(j,i,icg)
875 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
879 call MPI_Barrier(FG_COMM,IERR)
880 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
882 call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
883 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
884 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
885 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
886 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
887 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
888 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
889 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
890 time_reduce=time_reduce+MPI_Wtime()-time00
892 write (iout,*) "gloc_sc after reduce"
895 write (iout,*) i,j,gloc_sc(j,i,icg)
900 write (iout,*) "gloc after reduce"
902 write (iout,*) i,gloc(i,icg)
907 if (gnorm_check) then
909 c Compute the maximum elements of the gradient
919 gcorr3_turn_max=0.0d0
920 gcorr4_turn_max=0.0d0
923 gcorr6_turn_max=0.0d0
933 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
934 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
936 gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
937 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
939 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
940 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
941 & gvdwc_scp_max=gvdwc_scp_norm
942 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
943 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
944 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
945 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
946 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
947 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
948 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
949 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
950 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
951 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
952 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
953 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
954 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
956 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
957 & gcorr3_turn_max=gcorr3_turn_norm
958 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
960 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
961 & gcorr4_turn_max=gcorr4_turn_norm
962 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
963 if (gradcorr5_norm.gt.gradcorr5_max)
964 & gradcorr5_max=gradcorr5_norm
965 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
966 if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
967 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
969 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
970 & gcorr6_turn_max=gcorr6_turn_norm
971 gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
972 if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
973 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
974 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
975 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
976 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
978 gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
979 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
981 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
982 if (gradx_scp_norm.gt.gradx_scp_max)
983 & gradx_scp_max=gradx_scp_norm
984 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
985 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
986 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
987 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
988 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
989 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
990 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
991 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
995 open(istat,file=statname,position="append")
997 open(istat,file=statname,access="append")
999 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1000 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1001 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1002 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1003 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1004 & gsccorx_max,gsclocx_max
1006 if (gvdwc_max.gt.1.0d4) then
1007 write (iout,*) "gvdwc gvdwx gradb gradbx"
1009 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1010 & gradb(j,i),gradbx(j,i),j=1,3)
1012 call pdbout(0.0d0,'cipiszcze',iout)
1018 write (iout,*) "gradc gradx gloc"
1020 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1021 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1026 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1028 time_sumgradient=time_sumgradient+tcpu()-time01
1033 c-------------------------------------------------------------------------------
1034 subroutine rescale_weights(t_bath)
1035 implicit real*8 (a-h,o-z)
1036 include 'DIMENSIONS'
1037 include 'COMMON.IOUNITS'
1038 include 'COMMON.FFIELD'
1039 include 'COMMON.SBRIDGE'
1040 double precision kfac /2.4d0/
1041 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1043 c facT=2*temp0/(t_bath+temp0)
1044 if (rescale_mode.eq.0) then
1050 else if (rescale_mode.eq.1) then
1051 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1052 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1053 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1054 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1055 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1056 else if (rescale_mode.eq.2) then
1062 facT=licznik/dlog(dexp(x)+dexp(-x))
1063 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1064 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1065 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1066 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1068 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1069 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1071 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1075 welec=weights(3)*fact
1076 wcorr=weights(4)*fact3
1077 wcorr5=weights(5)*fact4
1078 wcorr6=weights(6)*fact5
1079 wel_loc=weights(7)*fact2
1080 wturn3=weights(8)*fact2
1081 wturn4=weights(9)*fact3
1082 wturn6=weights(10)*fact5
1083 wtor=weights(13)*fact
1084 wtor_d=weights(14)*fact2
1085 wsccor=weights(21)*fact
1088 wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1092 C------------------------------------------------------------------------
1093 subroutine enerprint(energia)
1094 implicit real*8 (a-h,o-z)
1095 include 'DIMENSIONS'
1096 include 'COMMON.IOUNITS'
1097 include 'COMMON.FFIELD'
1098 include 'COMMON.SBRIDGE'
1100 double precision energia(0:n_ene)
1103 evdw=energia(22)+wsct*energia(23)
1109 evdw2=energia(2)+energia(18)
1121 eello_turn3=energia(8)
1122 eello_turn4=energia(9)
1123 eello_turn6=energia(10)
1129 edihcnstr=energia(19)
1133 ehomology_constr=energia(24)
1135 edfadis = energia(25)
1136 edfator = energia(26)
1137 edfanei = energia(27)
1138 edfabet = energia(28)
1141 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1142 & estr,wbond,ebe,wang,
1143 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1145 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1146 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1147 & edihcnstr,ehomology_constr, ebr*nss,
1148 & Uconst,edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1149 & edfabet,wdfa_beta,etot
1150 10 format (/'Virtual-chain energies:'//
1151 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1152 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1153 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1154 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1155 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1156 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1157 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1158 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1159 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1160 & 'EHPB= ',1pE16.6,' WEIGHT=',1pE16.6,
1161 & ' (SS bridges & dist. cnstr.)'/
1162 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1163 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1164 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1165 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1166 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1167 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1168 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1169 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1170 & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1171 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1172 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1173 & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1174 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1175 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1176 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1177 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1178 & 'ETOT= ',1pE16.6,' (total)')
1180 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1181 & estr,wbond,ebe,wang,
1182 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1184 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1185 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1186 & ehomology_constr,ebr*nss,Uconst,edfadis,wdfa_dist,edfator,
1187 & wdfa_tor,edfanei,wdfa_nei,edfabet,wdfa_beta,
1189 10 format (/'Virtual-chain energies:'//
1190 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1191 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1192 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1193 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1194 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1195 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1196 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1197 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1198 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
1199 & ' (SS bridges & dist. cnstr.)'/
1200 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1201 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1202 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1203 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1204 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1205 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1206 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1207 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1208 & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1209 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1210 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1211 & 'UCONST=',1pE16.6,' (Constraint energy)'/
1212 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
1213 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
1214 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
1215 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
1216 & 'ETOT= ',1pE16.6,' (total)')
1220 C-----------------------------------------------------------------------
1221 subroutine elj(evdw,evdw_p,evdw_m)
1223 C This subroutine calculates the interaction energy of nonbonded side chains
1224 C assuming the LJ potential of interaction.
1226 implicit real*8 (a-h,o-z)
1227 include 'DIMENSIONS'
1228 parameter (accur=1.0d-10)
1229 include 'COMMON.GEO'
1230 include 'COMMON.VAR'
1231 include 'COMMON.LOCAL'
1232 include 'COMMON.CHAIN'
1233 include 'COMMON.DERIV'
1234 include 'COMMON.INTERACT'
1235 include 'COMMON.TORSION'
1236 include 'COMMON.SBRIDGE'
1237 include 'COMMON.NAMES'
1238 include 'COMMON.IOUNITS'
1239 include 'COMMON.CONTACTS'
1241 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1243 do i=iatsc_s,iatsc_e
1252 C Calculate SC interaction energy.
1254 do iint=1,nint_gr(i)
1255 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1256 cd & 'iend=',iend(i,iint)
1257 do j=istart(i,iint),iend(i,iint)
1262 C Change 12/1/95 to calculate four-body interactions
1263 rij=xj*xj+yj*yj+zj*zj
1265 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1266 eps0ij=eps(itypi,itypj)
1268 e1=fac*fac*aa(itypi,itypj)
1269 e2=fac*bb(itypi,itypj)
1271 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1272 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1273 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1274 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1275 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1276 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1278 if (bb(itypi,itypj).gt.0) then
1279 evdw_p=evdw_p+evdwij
1281 evdw_m=evdw_m+evdwij
1287 C Calculate the components of the gradient in DC and X
1289 fac=-rrij*(e1+evdwij)
1294 if (bb(itypi,itypj).gt.0.0d0) then
1296 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1297 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1298 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1299 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1303 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1304 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1305 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1306 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1311 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1312 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1313 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1314 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1319 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1323 C 12/1/95, revised on 5/20/97
1325 C Calculate the contact function. The ith column of the array JCONT will
1326 C contain the numbers of atoms that make contacts with the atom I (of numbers
1327 C greater than I). The arrays FACONT and GACONT will contain the values of
1328 C the contact function and its derivative.
1330 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1331 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1332 C Uncomment next line, if the correlation interactions are contact function only
1333 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1335 sigij=sigma(itypi,itypj)
1336 r0ij=rs0(itypi,itypj)
1338 C Check whether the SC's are not too far to make a contact.
1341 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1342 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1344 if (fcont.gt.0.0D0) then
1345 C If the SC-SC distance if close to sigma, apply spline.
1346 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1347 cAdam & fcont1,fprimcont1)
1348 cAdam fcont1=1.0d0-fcont1
1349 cAdam if (fcont1.gt.0.0d0) then
1350 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1351 cAdam fcont=fcont*fcont1
1353 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1354 cga eps0ij=1.0d0/dsqrt(eps0ij)
1356 cga gg(k)=gg(k)*eps0ij
1358 cga eps0ij=-evdwij*eps0ij
1359 C Uncomment for AL's type of SC correlation interactions.
1360 cadam eps0ij=-evdwij
1361 num_conti=num_conti+1
1362 jcont(num_conti,i)=j
1363 facont(num_conti,i)=fcont*eps0ij
1364 fprimcont=eps0ij*fprimcont/rij
1366 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1367 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1368 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1369 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1370 gacont(1,num_conti,i)=-fprimcont*xj
1371 gacont(2,num_conti,i)=-fprimcont*yj
1372 gacont(3,num_conti,i)=-fprimcont*zj
1373 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1374 cd write (iout,'(2i3,3f10.5)')
1375 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1381 num_cont(i)=num_conti
1385 gvdwc(j,i)=expon*gvdwc(j,i)
1386 gvdwx(j,i)=expon*gvdwx(j,i)
1389 C******************************************************************************
1393 C To save time, the factor of EXPON has been extracted from ALL components
1394 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1397 C******************************************************************************
1400 C-----------------------------------------------------------------------------
1401 subroutine eljk(evdw,evdw_p,evdw_m)
1403 C This subroutine calculates the interaction energy of nonbonded side chains
1404 C assuming the LJK potential of interaction.
1406 implicit real*8 (a-h,o-z)
1407 include 'DIMENSIONS'
1408 include 'COMMON.GEO'
1409 include 'COMMON.VAR'
1410 include 'COMMON.LOCAL'
1411 include 'COMMON.CHAIN'
1412 include 'COMMON.DERIV'
1413 include 'COMMON.INTERACT'
1414 include 'COMMON.IOUNITS'
1415 include 'COMMON.NAMES'
1418 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1420 do i=iatsc_s,iatsc_e
1427 C Calculate SC interaction energy.
1429 do iint=1,nint_gr(i)
1430 do j=istart(i,iint),iend(i,iint)
1435 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1436 fac_augm=rrij**expon
1437 e_augm=augm(itypi,itypj)*fac_augm
1438 r_inv_ij=dsqrt(rrij)
1440 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1441 fac=r_shift_inv**expon
1442 e1=fac*fac*aa(itypi,itypj)
1443 e2=fac*bb(itypi,itypj)
1445 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1446 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1447 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1448 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1449 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1450 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1451 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1453 if (bb(itypi,itypj).gt.0) then
1454 evdw_p=evdw_p+evdwij
1456 evdw_m=evdw_m+evdwij
1462 C Calculate the components of the gradient in DC and X
1464 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1469 if (bb(itypi,itypj).gt.0.0d0) then
1471 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1472 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1473 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1474 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1478 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1479 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1480 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1481 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1486 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1487 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1488 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1489 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1494 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1502 gvdwc(j,i)=expon*gvdwc(j,i)
1503 gvdwx(j,i)=expon*gvdwx(j,i)
1508 C-----------------------------------------------------------------------------
1509 subroutine ebp(evdw,evdw_p,evdw_m)
1511 C This subroutine calculates the interaction energy of nonbonded side chains
1512 C assuming the Berne-Pechukas potential of interaction.
1514 implicit real*8 (a-h,o-z)
1515 include 'DIMENSIONS'
1516 include 'COMMON.GEO'
1517 include 'COMMON.VAR'
1518 include 'COMMON.LOCAL'
1519 include 'COMMON.CHAIN'
1520 include 'COMMON.DERIV'
1521 include 'COMMON.NAMES'
1522 include 'COMMON.INTERACT'
1523 include 'COMMON.IOUNITS'
1524 include 'COMMON.CALC'
1525 common /srutu/ icall
1526 c double precision rrsave(maxdim)
1529 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1531 c if (icall.eq.0) then
1537 do i=iatsc_s,iatsc_e
1543 dxi=dc_norm(1,nres+i)
1544 dyi=dc_norm(2,nres+i)
1545 dzi=dc_norm(3,nres+i)
1546 c dsci_inv=dsc_inv(itypi)
1547 dsci_inv=vbld_inv(i+nres)
1549 C Calculate SC interaction energy.
1551 do iint=1,nint_gr(i)
1552 do j=istart(i,iint),iend(i,iint)
1555 c dscj_inv=dsc_inv(itypj)
1556 dscj_inv=vbld_inv(j+nres)
1557 chi1=chi(itypi,itypj)
1558 chi2=chi(itypj,itypi)
1565 alf12=0.5D0*(alf1+alf2)
1566 C For diagnostics only!!!
1579 dxj=dc_norm(1,nres+j)
1580 dyj=dc_norm(2,nres+j)
1581 dzj=dc_norm(3,nres+j)
1582 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1583 cd if (icall.eq.0) then
1589 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1591 C Calculate whole angle-dependent part of epsilon and contributions
1592 C to its derivatives
1593 fac=(rrij*sigsq)**expon2
1594 e1=fac*fac*aa(itypi,itypj)
1595 e2=fac*bb(itypi,itypj)
1596 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1597 eps2der=evdwij*eps3rt
1598 eps3der=evdwij*eps2rt
1599 evdwij=evdwij*eps2rt*eps3rt
1601 if (bb(itypi,itypj).gt.0) then
1602 evdw_p=evdw_p+evdwij
1604 evdw_m=evdw_m+evdwij
1610 sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1611 epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1612 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1613 cd & restyp(itypi),i,restyp(itypj),j,
1614 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1615 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1616 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1619 C Calculate gradient components.
1620 e1=e1*eps1*eps2rt**2*eps3rt**2
1621 fac=-expon*(e1+evdwij)
1624 C Calculate radial part of the gradient
1628 C Calculate the angular part of the gradient and sum add the contributions
1629 C to the appropriate components of the Cartesian gradient.
1631 if (bb(itypi,itypj).gt.0) then
1645 C-----------------------------------------------------------------------------
1646 subroutine egb(evdw,evdw_p,evdw_m)
1648 C This subroutine calculates the interaction energy of nonbonded side chains
1649 C assuming the Gay-Berne potential of interaction.
1651 implicit real*8 (a-h,o-z)
1652 include 'DIMENSIONS'
1653 include 'COMMON.GEO'
1654 include 'COMMON.VAR'
1655 include 'COMMON.LOCAL'
1656 include 'COMMON.CHAIN'
1657 include 'COMMON.DERIV'
1658 include 'COMMON.NAMES'
1659 include 'COMMON.INTERACT'
1660 include 'COMMON.IOUNITS'
1661 include 'COMMON.CALC'
1662 include 'COMMON.CONTROL'
1663 include 'COMMON.SBRIDGE'
1666 ccccc energy_dec=.false.
1667 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1672 c if (icall.eq.0) lprn=.false.
1674 do i=iatsc_s,iatsc_e
1680 dxi=dc_norm(1,nres+i)
1681 dyi=dc_norm(2,nres+i)
1682 dzi=dc_norm(3,nres+i)
1683 c dsci_inv=dsc_inv(itypi)
1684 dsci_inv=vbld_inv(i+nres)
1685 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1686 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1688 C Calculate SC interaction energy.
1690 do iint=1,nint_gr(i)
1691 do j=istart(i,iint),iend(i,iint)
1692 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1693 call dyn_ssbond_ene(i,j,evdwij)
1695 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1696 & 'evdw',i,j,evdwij,' ss'
1700 c dscj_inv=dsc_inv(itypj)
1701 dscj_inv=vbld_inv(j+nres)
1702 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1703 c & 1.0d0/vbld(j+nres)
1704 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1705 sig0ij=sigma(itypi,itypj)
1706 chi1=chi(itypi,itypj)
1707 chi2=chi(itypj,itypi)
1714 alf12=0.5D0*(alf1+alf2)
1715 C For diagnostics only!!!
1728 dxj=dc_norm(1,nres+j)
1729 dyj=dc_norm(2,nres+j)
1730 dzj=dc_norm(3,nres+j)
1731 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1732 c write (iout,*) "j",j," dc_norm",
1733 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1734 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1736 C Calculate angle-dependent terms of energy and contributions to their
1740 sig=sig0ij*dsqrt(sigsq)
1741 rij_shift=1.0D0/rij-sig+sig0ij
1742 c for diagnostics; uncomment
1743 c rij_shift=1.2*sig0ij
1744 C I hate to put IF's in the loops, but here don't have another choice!!!!
1745 if (rij_shift.le.0.0D0) then
1747 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1748 cd & restyp(itypi),i,restyp(itypj),j,
1749 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1753 c---------------------------------------------------------------
1754 rij_shift=1.0D0/rij_shift
1755 fac=rij_shift**expon
1756 e1=fac*fac*aa(itypi,itypj)
1757 e2=fac*bb(itypi,itypj)
1758 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1759 eps2der=evdwij*eps3rt
1760 eps3der=evdwij*eps2rt
1761 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1762 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1763 evdwij=evdwij*eps2rt*eps3rt
1765 if (bb(itypi,itypj).gt.0) then
1766 evdw_p=evdw_p+evdwij
1768 evdw_m=evdw_m+evdwij
1774 sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1775 epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1776 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1777 & restyp(itypi),i,restyp(itypj),j,
1778 & epsi,sigm,chi1,chi2,chip1,chip2,
1779 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1780 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1784 if (energy_dec) then
1785 write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
1788 C Calculate gradient components.
1789 e1=e1*eps1*eps2rt**2*eps3rt**2
1790 fac=-expon*(e1+evdwij)*rij_shift
1794 C Calculate the radial part of the gradient
1798 C Calculate angular part of the gradient.
1800 if (bb(itypi,itypj).gt.0) then
1812 c write (iout,*) "Number of loop steps in EGB:",ind
1813 cccc energy_dec=.false.
1816 C-----------------------------------------------------------------------------
1817 subroutine egbv(evdw,evdw_p,evdw_m)
1819 C This subroutine calculates the interaction energy of nonbonded side chains
1820 C assuming the Gay-Berne-Vorobjev potential of interaction.
1822 implicit real*8 (a-h,o-z)
1823 include 'DIMENSIONS'
1824 include 'COMMON.GEO'
1825 include 'COMMON.VAR'
1826 include 'COMMON.LOCAL'
1827 include 'COMMON.CHAIN'
1828 include 'COMMON.DERIV'
1829 include 'COMMON.NAMES'
1830 include 'COMMON.INTERACT'
1831 include 'COMMON.IOUNITS'
1832 include 'COMMON.CALC'
1833 common /srutu/ icall
1836 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1839 c if (icall.eq.0) lprn=.true.
1841 do i=iatsc_s,iatsc_e
1847 dxi=dc_norm(1,nres+i)
1848 dyi=dc_norm(2,nres+i)
1849 dzi=dc_norm(3,nres+i)
1850 c dsci_inv=dsc_inv(itypi)
1851 dsci_inv=vbld_inv(i+nres)
1853 C Calculate SC interaction energy.
1855 do iint=1,nint_gr(i)
1856 do j=istart(i,iint),iend(i,iint)
1859 c dscj_inv=dsc_inv(itypj)
1860 dscj_inv=vbld_inv(j+nres)
1861 sig0ij=sigma(itypi,itypj)
1862 r0ij=r0(itypi,itypj)
1863 chi1=chi(itypi,itypj)
1864 chi2=chi(itypj,itypi)
1871 alf12=0.5D0*(alf1+alf2)
1872 C For diagnostics only!!!
1885 dxj=dc_norm(1,nres+j)
1886 dyj=dc_norm(2,nres+j)
1887 dzj=dc_norm(3,nres+j)
1888 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1890 C Calculate angle-dependent terms of energy and contributions to their
1894 sig=sig0ij*dsqrt(sigsq)
1895 rij_shift=1.0D0/rij-sig+r0ij
1896 C I hate to put IF's in the loops, but here don't have another choice!!!!
1897 if (rij_shift.le.0.0D0) then
1902 c---------------------------------------------------------------
1903 rij_shift=1.0D0/rij_shift
1904 fac=rij_shift**expon
1905 e1=fac*fac*aa(itypi,itypj)
1906 e2=fac*bb(itypi,itypj)
1907 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1908 eps2der=evdwij*eps3rt
1909 eps3der=evdwij*eps2rt
1910 fac_augm=rrij**expon
1911 e_augm=augm(itypi,itypj)*fac_augm
1912 evdwij=evdwij*eps2rt*eps3rt
1914 if (bb(itypi,itypj).gt.0) then
1915 evdw_p=evdw_p+evdwij+e_augm
1917 evdw_m=evdw_m+evdwij+e_augm
1920 evdw=evdw+evdwij+e_augm
1923 sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1924 epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1925 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1926 & restyp(itypi),i,restyp(itypj),j,
1927 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1928 & chi1,chi2,chip1,chip2,
1929 & eps1,eps2rt**2,eps3rt**2,
1930 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1933 C Calculate gradient components.
1934 e1=e1*eps1*eps2rt**2*eps3rt**2
1935 fac=-expon*(e1+evdwij)*rij_shift
1937 fac=rij*fac-2*expon*rrij*e_augm
1938 C Calculate the radial part of the gradient
1942 C Calculate angular part of the gradient.
1944 if (bb(itypi,itypj).gt.0) then
1956 C-----------------------------------------------------------------------------
1957 subroutine sc_angular
1958 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1959 C om12. Called by ebp, egb, and egbv.
1961 include 'COMMON.CALC'
1962 include 'COMMON.IOUNITS'
1966 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1967 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1968 om12=dxi*dxj+dyi*dyj+dzi*dzj
1970 C Calculate eps1(om12) and its derivative in om12
1971 faceps1=1.0D0-om12*chiom12
1972 faceps1_inv=1.0D0/faceps1
1973 eps1=dsqrt(faceps1_inv)
1974 C Following variable is eps1*deps1/dom12
1975 eps1_om12=faceps1_inv*chiom12
1980 c write (iout,*) "om12",om12," eps1",eps1
1981 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1986 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1987 sigsq=1.0D0-facsig*faceps1_inv
1988 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1989 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1990 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1996 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1997 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1999 C Calculate eps2 and its derivatives in om1, om2, and om12.
2002 chipom12=chip12*om12
2003 facp=1.0D0-om12*chipom12
2005 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2006 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2007 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2008 C Following variable is the square root of eps2
2009 eps2rt=1.0D0-facp1*facp_inv
2010 C Following three variables are the derivatives of the square root of eps
2011 C in om1, om2, and om12.
2012 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2013 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2014 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2015 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2016 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2017 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2018 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2019 c & " eps2rt_om12",eps2rt_om12
2020 C Calculate whole angle-dependent part of epsilon and contributions
2021 C to its derivatives
2025 C----------------------------------------------------------------------------
2026 subroutine sc_grad_T
2027 implicit real*8 (a-h,o-z)
2028 include 'DIMENSIONS'
2029 include 'COMMON.CHAIN'
2030 include 'COMMON.DERIV'
2031 include 'COMMON.CALC'
2032 include 'COMMON.IOUNITS'
2033 double precision dcosom1(3),dcosom2(3)
2034 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2035 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2036 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2037 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2041 c eom12=evdwij*eps1_om12
2043 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2044 c & " sigder",sigder
2045 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2046 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2048 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2049 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2052 gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2054 c write (iout,*) "gg",(gg(k),k=1,3)
2056 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
2057 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2058 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2059 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
2060 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2061 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2062 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2063 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2064 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2065 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2068 C Calculate the components of the gradient in DC and X
2072 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2076 gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
2077 gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
2082 C----------------------------------------------------------------------------
2084 implicit real*8 (a-h,o-z)
2085 include 'DIMENSIONS'
2086 include 'COMMON.CHAIN'
2087 include 'COMMON.DERIV'
2088 include 'COMMON.CALC'
2089 include 'COMMON.IOUNITS'
2090 double precision dcosom1(3),dcosom2(3)
2091 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2092 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2093 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2094 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2098 c eom12=evdwij*eps1_om12
2100 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2101 c & " sigder",sigder
2102 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2103 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2105 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2106 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2109 gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2111 c write (iout,*) "gg",(gg(k),k=1,3)
2113 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2114 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2115 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2116 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2117 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2118 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2119 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2120 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2121 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2122 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2125 C Calculate the components of the gradient in DC and X
2129 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2133 gvdwc(l,i)=gvdwc(l,i)-gg(l)
2134 gvdwc(l,j)=gvdwc(l,j)+gg(l)
2138 C-----------------------------------------------------------------------
2139 subroutine e_softsphere(evdw)
2141 C This subroutine calculates the interaction energy of nonbonded side chains
2142 C assuming the LJ potential of interaction.
2144 implicit real*8 (a-h,o-z)
2145 include 'DIMENSIONS'
2146 parameter (accur=1.0d-10)
2147 include 'COMMON.GEO'
2148 include 'COMMON.VAR'
2149 include 'COMMON.LOCAL'
2150 include 'COMMON.CHAIN'
2151 include 'COMMON.DERIV'
2152 include 'COMMON.INTERACT'
2153 include 'COMMON.TORSION'
2154 include 'COMMON.SBRIDGE'
2155 include 'COMMON.NAMES'
2156 include 'COMMON.IOUNITS'
2157 include 'COMMON.CONTACTS'
2159 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2161 do i=iatsc_s,iatsc_e
2168 C Calculate SC interaction energy.
2170 do iint=1,nint_gr(i)
2171 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2172 cd & 'iend=',iend(i,iint)
2173 do j=istart(i,iint),iend(i,iint)
2178 rij=xj*xj+yj*yj+zj*zj
2179 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2180 r0ij=r0(itypi,itypj)
2182 c print *,i,j,r0ij,dsqrt(rij)
2183 if (rij.lt.r0ijsq) then
2184 evdwij=0.25d0*(rij-r0ijsq)**2
2192 C Calculate the components of the gradient in DC and X
2198 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2199 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2200 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2201 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2205 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2213 C--------------------------------------------------------------------------
2214 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2217 C Soft-sphere potential of p-p interaction
2219 implicit real*8 (a-h,o-z)
2220 include 'DIMENSIONS'
2221 include 'COMMON.CONTROL'
2222 include 'COMMON.IOUNITS'
2223 include 'COMMON.GEO'
2224 include 'COMMON.VAR'
2225 include 'COMMON.LOCAL'
2226 include 'COMMON.CHAIN'
2227 include 'COMMON.DERIV'
2228 include 'COMMON.INTERACT'
2229 include 'COMMON.CONTACTS'
2230 include 'COMMON.TORSION'
2231 include 'COMMON.VECTORS'
2232 include 'COMMON.FFIELD'
2234 cd write(iout,*) 'In EELEC_soft_sphere'
2241 do i=iatel_s,iatel_e
2245 xmedi=c(1,i)+0.5d0*dxi
2246 ymedi=c(2,i)+0.5d0*dyi
2247 zmedi=c(3,i)+0.5d0*dzi
2249 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2250 do j=ielstart(i),ielend(i)
2254 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2255 r0ij=rpp(iteli,itelj)
2260 xj=c(1,j)+0.5D0*dxj-xmedi
2261 yj=c(2,j)+0.5D0*dyj-ymedi
2262 zj=c(3,j)+0.5D0*dzj-zmedi
2263 rij=xj*xj+yj*yj+zj*zj
2264 if (rij.lt.r0ijsq) then
2265 evdw1ij=0.25d0*(rij-r0ijsq)**2
2273 C Calculate contributions to the Cartesian gradient.
2279 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2280 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2283 * Loop over residues i+1 thru j-1.
2287 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2292 cgrad do i=nnt,nct-1
2294 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2296 cgrad do j=i+1,nct-1
2298 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2304 c------------------------------------------------------------------------------
2305 subroutine vec_and_deriv
2306 implicit real*8 (a-h,o-z)
2307 include 'DIMENSIONS'
2311 include 'COMMON.IOUNITS'
2312 include 'COMMON.GEO'
2313 include 'COMMON.VAR'
2314 include 'COMMON.LOCAL'
2315 include 'COMMON.CHAIN'
2316 include 'COMMON.VECTORS'
2317 include 'COMMON.SETUP'
2318 include 'COMMON.TIME1'
2319 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2320 C Compute the local reference systems. For reference system (i), the
2321 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2322 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2324 do i=ivec_start,ivec_end
2328 if (i.eq.nres-1) then
2329 C Case of the last full residue
2330 C Compute the Z-axis
2331 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2332 costh=dcos(pi-theta(nres))
2333 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2337 C Compute the derivatives of uz
2339 uzder(2,1,1)=-dc_norm(3,i-1)
2340 uzder(3,1,1)= dc_norm(2,i-1)
2341 uzder(1,2,1)= dc_norm(3,i-1)
2343 uzder(3,2,1)=-dc_norm(1,i-1)
2344 uzder(1,3,1)=-dc_norm(2,i-1)
2345 uzder(2,3,1)= dc_norm(1,i-1)
2348 uzder(2,1,2)= dc_norm(3,i)
2349 uzder(3,1,2)=-dc_norm(2,i)
2350 uzder(1,2,2)=-dc_norm(3,i)
2352 uzder(3,2,2)= dc_norm(1,i)
2353 uzder(1,3,2)= dc_norm(2,i)
2354 uzder(2,3,2)=-dc_norm(1,i)
2356 C Compute the Y-axis
2359 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2361 C Compute the derivatives of uy
2364 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2365 & -dc_norm(k,i)*dc_norm(j,i-1)
2366 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2368 uyder(j,j,1)=uyder(j,j,1)-costh
2369 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2374 uygrad(l,k,j,i)=uyder(l,k,j)
2375 uzgrad(l,k,j,i)=uzder(l,k,j)
2379 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2380 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2381 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2382 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2385 C Compute the Z-axis
2386 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2387 costh=dcos(pi-theta(i+2))
2388 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2392 C Compute the derivatives of uz
2394 uzder(2,1,1)=-dc_norm(3,i+1)
2395 uzder(3,1,1)= dc_norm(2,i+1)
2396 uzder(1,2,1)= dc_norm(3,i+1)
2398 uzder(3,2,1)=-dc_norm(1,i+1)
2399 uzder(1,3,1)=-dc_norm(2,i+1)
2400 uzder(2,3,1)= dc_norm(1,i+1)
2403 uzder(2,1,2)= dc_norm(3,i)
2404 uzder(3,1,2)=-dc_norm(2,i)
2405 uzder(1,2,2)=-dc_norm(3,i)
2407 uzder(3,2,2)= dc_norm(1,i)
2408 uzder(1,3,2)= dc_norm(2,i)
2409 uzder(2,3,2)=-dc_norm(1,i)
2411 C Compute the Y-axis
2414 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2416 C Compute the derivatives of uy
2419 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2420 & -dc_norm(k,i)*dc_norm(j,i+1)
2421 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2423 uyder(j,j,1)=uyder(j,j,1)-costh
2424 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2429 uygrad(l,k,j,i)=uyder(l,k,j)
2430 uzgrad(l,k,j,i)=uzder(l,k,j)
2434 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2435 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2436 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2437 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2441 vbld_inv_temp(1)=vbld_inv(i+1)
2442 if (i.lt.nres-1) then
2443 vbld_inv_temp(2)=vbld_inv(i+2)
2445 vbld_inv_temp(2)=vbld_inv(i)
2450 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2451 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2456 #if defined(PARVEC) && defined(MPI)
2457 if (nfgtasks1.gt.1) then
2459 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2460 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2461 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2462 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2463 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2465 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2466 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2468 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2469 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2470 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2471 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2472 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2473 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2474 time_gather=time_gather+MPI_Wtime()-time00
2476 c if (fg_rank.eq.0) then
2477 c write (iout,*) "Arrays UY and UZ"
2479 c write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2486 C-----------------------------------------------------------------------------
2487 subroutine check_vecgrad
2488 implicit real*8 (a-h,o-z)
2489 include 'DIMENSIONS'
2490 include 'COMMON.IOUNITS'
2491 include 'COMMON.GEO'
2492 include 'COMMON.VAR'
2493 include 'COMMON.LOCAL'
2494 include 'COMMON.CHAIN'
2495 include 'COMMON.VECTORS'
2496 dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2497 dimension uyt(3,maxres),uzt(3,maxres)
2498 dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2499 double precision delta /1.0d-7/
2502 crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2503 crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2504 crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2505 cd write(iout,'(2i5,2(3f10.5,5x))') i,1,
2506 cd & (dc_norm(if90,i),if90=1,3)
2507 cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2508 cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2509 cd write(iout,'(a)')
2515 uygradt(l,k,j,i)=uygrad(l,k,j,i)
2516 uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2529 cd write (iout,*) 'i=',i
2531 erij(k)=dc_norm(k,i)
2535 dc_norm(k,i)=erij(k)
2537 dc_norm(j,i)=dc_norm(j,i)+delta
2538 c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2540 c dc_norm(k,i)=dc_norm(k,i)/fac
2542 c write (iout,*) (dc_norm(k,i),k=1,3)
2543 c write (iout,*) (erij(k),k=1,3)
2546 uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2547 uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2548 uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2549 uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2551 c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2552 c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2553 c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2556 dc_norm(k,i)=erij(k)
2559 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2560 cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2561 cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2562 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2563 cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2564 cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2565 cd write (iout,'(a)')
2570 C--------------------------------------------------------------------------
2571 subroutine set_matrices
2572 implicit real*8 (a-h,o-z)
2573 include 'DIMENSIONS'
2576 include "COMMON.SETUP"
2578 integer status(MPI_STATUS_SIZE)
2580 include 'COMMON.IOUNITS'
2581 include 'COMMON.GEO'
2582 include 'COMMON.VAR'
2583 include 'COMMON.LOCAL'
2584 include 'COMMON.CHAIN'
2585 include 'COMMON.DERIV'
2586 include 'COMMON.INTERACT'
2587 include 'COMMON.CONTACTS'
2588 include 'COMMON.TORSION'
2589 include 'COMMON.VECTORS'
2590 include 'COMMON.FFIELD'
2591 double precision auxvec(2),auxmat(2,2)
2593 C Compute the virtual-bond-torsional-angle dependent quantities needed
2594 C to calculate the el-loc multibody terms of various order.
2597 do i=ivec_start+2,ivec_end+2
2601 if (i .lt. nres+1) then
2638 if (i .gt. 3 .and. i .lt. nres+1) then
2639 obrot_der(1,i-2)=-sin1
2640 obrot_der(2,i-2)= cos1
2641 Ugder(1,1,i-2)= sin1
2642 Ugder(1,2,i-2)=-cos1
2643 Ugder(2,1,i-2)=-cos1
2644 Ugder(2,2,i-2)=-sin1
2647 obrot2_der(1,i-2)=-dwasin2
2648 obrot2_der(2,i-2)= dwacos2
2649 Ug2der(1,1,i-2)= dwasin2
2650 Ug2der(1,2,i-2)=-dwacos2
2651 Ug2der(2,1,i-2)=-dwacos2
2652 Ug2der(2,2,i-2)=-dwasin2
2654 obrot_der(1,i-2)=0.0d0
2655 obrot_der(2,i-2)=0.0d0
2656 Ugder(1,1,i-2)=0.0d0
2657 Ugder(1,2,i-2)=0.0d0
2658 Ugder(2,1,i-2)=0.0d0
2659 Ugder(2,2,i-2)=0.0d0
2660 obrot2_der(1,i-2)=0.0d0
2661 obrot2_der(2,i-2)=0.0d0
2662 Ug2der(1,1,i-2)=0.0d0
2663 Ug2der(1,2,i-2)=0.0d0
2664 Ug2der(2,1,i-2)=0.0d0
2665 Ug2der(2,2,i-2)=0.0d0
2667 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2668 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2669 iti = itortyp(itype(i-2))
2673 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2674 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2675 iti1 = itortyp(itype(i-1))
2679 cd write (iout,*) '*******i',i,' iti1',iti
2680 cd write (iout,*) 'b1',b1(:,iti)
2681 cd write (iout,*) 'b2',b2(:,iti)
2682 cd write (iout,*) 'Ug',Ug(:,:,i-2)
2683 c if (i .gt. iatel_s+2) then
2684 if (i .gt. nnt+2) then
2685 call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2686 call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2687 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2689 call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2690 call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2691 call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2692 call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2693 call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2704 DtUg2(l,k,i-2)=0.0d0
2708 call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2709 call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2711 muder(k,i-2)=Ub2der(k,i-2)
2713 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2714 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2715 iti1 = itortyp(itype(i-1))
2720 mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2722 cd write (iout,*) 'mu ',mu(:,i-2)
2723 cd write (iout,*) 'mu1',mu1(:,i-2)
2724 cd write (iout,*) 'mu2',mu2(:,i-2)
2725 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2727 call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2728 call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2729 call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2730 call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2731 call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2732 C Vectors and matrices dependent on a single virtual-bond dihedral.
2733 call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2734 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2735 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2736 call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2737 call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2738 call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2739 call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2740 call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2741 call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2744 C Matrices dependent on two consecutive virtual-bond dihedrals.
2745 C The order of matrices is from left to right.
2746 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2748 c do i=max0(ivec_start,2),ivec_end
2750 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2751 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2752 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2753 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2754 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2755 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2756 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2757 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2760 #if defined(MPI) && defined(PARMAT)
2762 c if (fg_rank.eq.0) then
2763 write (iout,*) "Arrays UG and UGDER before GATHER"
2765 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2766 & ((ug(l,k,i),l=1,2),k=1,2),
2767 & ((ugder(l,k,i),l=1,2),k=1,2)
2769 write (iout,*) "Arrays UG2 and UG2DER"
2771 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2772 & ((ug2(l,k,i),l=1,2),k=1,2),
2773 & ((ug2der(l,k,i),l=1,2),k=1,2)
2775 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2777 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2778 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2779 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2781 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2783 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2784 & costab(i),sintab(i),costab2(i),sintab2(i)
2786 write (iout,*) "Array MUDER"
2788 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2792 if (nfgtasks.gt.1) then
2794 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2795 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2796 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2798 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2799 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2801 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2802 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2804 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2805 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2807 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2808 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2810 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2811 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2813 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2814 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2816 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2817 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2818 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2819 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2820 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2821 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2822 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2823 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2824 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2825 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2826 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2827 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2828 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2830 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2831 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2833 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2834 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2836 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2837 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2839 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2840 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2842 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2843 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2845 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2846 & ivec_count(fg_rank1),
2847 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2849 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2850 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2852 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2853 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2855 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2856 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2858 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2859 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2861 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2862 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2864 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2865 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2867 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2868 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2870 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2871 & ivec_count(fg_rank1),
2872 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2874 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2875 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2877 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2878 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2880 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2881 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2883 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2884 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2886 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2887 & ivec_count(fg_rank1),
2888 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2890 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2891 & ivec_count(fg_rank1),
2892 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2894 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2895 & ivec_count(fg_rank1),
2896 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2897 & MPI_MAT2,FG_COMM1,IERR)
2898 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2899 & ivec_count(fg_rank1),
2900 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2901 & MPI_MAT2,FG_COMM1,IERR)
2904 c Passes matrix info through the ring
2907 if (irecv.lt.0) irecv=nfgtasks1-1
2910 if (inext.ge.nfgtasks1) inext=0
2912 c write (iout,*) "isend",isend," irecv",irecv
2914 lensend=lentyp(isend)
2915 lenrecv=lentyp(irecv)
2916 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
2917 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2918 c & MPI_ROTAT1(lensend),inext,2200+isend,
2919 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2920 c & iprev,2200+irecv,FG_COMM,status,IERR)
2921 c write (iout,*) "Gather ROTAT1"
2923 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2924 c & MPI_ROTAT2(lensend),inext,3300+isend,
2925 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2926 c & iprev,3300+irecv,FG_COMM,status,IERR)
2927 c write (iout,*) "Gather ROTAT2"
2929 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2930 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
2931 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2932 & iprev,4400+irecv,FG_COMM,status,IERR)
2933 c write (iout,*) "Gather ROTAT_OLD"
2935 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2936 & MPI_PRECOMP11(lensend),inext,5500+isend,
2937 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2938 & iprev,5500+irecv,FG_COMM,status,IERR)
2939 c write (iout,*) "Gather PRECOMP11"
2941 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2942 & MPI_PRECOMP12(lensend),inext,6600+isend,
2943 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2944 & iprev,6600+irecv,FG_COMM,status,IERR)
2945 c write (iout,*) "Gather PRECOMP12"
2947 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2949 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2950 & MPI_ROTAT2(lensend),inext,7700+isend,
2951 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2952 & iprev,7700+irecv,FG_COMM,status,IERR)
2953 c write (iout,*) "Gather PRECOMP21"
2955 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2956 & MPI_PRECOMP22(lensend),inext,8800+isend,
2957 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2958 & iprev,8800+irecv,FG_COMM,status,IERR)
2959 c write (iout,*) "Gather PRECOMP22"
2961 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2962 & MPI_PRECOMP23(lensend),inext,9900+isend,
2963 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2964 & MPI_PRECOMP23(lenrecv),
2965 & iprev,9900+irecv,FG_COMM,status,IERR)
2966 c write (iout,*) "Gather PRECOMP23"
2971 if (irecv.lt.0) irecv=nfgtasks1-1
2974 time_gather=time_gather+MPI_Wtime()-time00
2977 c if (fg_rank.eq.0) then
2978 write (iout,*) "Arrays UG and UGDER"
2980 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2981 & ((ug(l,k,i),l=1,2),k=1,2),
2982 & ((ugder(l,k,i),l=1,2),k=1,2)
2984 write (iout,*) "Arrays UG2 and UG2DER"
2986 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2987 & ((ug2(l,k,i),l=1,2),k=1,2),
2988 & ((ug2der(l,k,i),l=1,2),k=1,2)
2990 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2992 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2993 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2994 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2996 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2998 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2999 & costab(i),sintab(i),costab2(i),sintab2(i)
3001 write (iout,*) "Array MUDER"
3003 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3009 cd iti = itortyp(itype(i))
3012 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3013 cd & (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3018 C--------------------------------------------------------------------------
3019 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3021 C This subroutine calculates the average interaction energy and its gradient
3022 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3023 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3024 C The potential depends both on the distance of peptide-group centers and on
3025 C the orientation of the CA-CA virtual bonds.
3027 implicit real*8 (a-h,o-z)
3031 include 'DIMENSIONS'
3032 include 'COMMON.CONTROL'
3033 include 'COMMON.SETUP'
3034 include 'COMMON.IOUNITS'
3035 include 'COMMON.GEO'
3036 include 'COMMON.VAR'
3037 include 'COMMON.LOCAL'
3038 include 'COMMON.CHAIN'
3039 include 'COMMON.DERIV'
3040 include 'COMMON.INTERACT'
3041 include 'COMMON.CONTACTS'
3042 include 'COMMON.TORSION'
3043 include 'COMMON.VECTORS'
3044 include 'COMMON.FFIELD'
3045 include 'COMMON.TIME1'
3046 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3047 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3048 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3049 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3050 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3051 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3053 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3055 double precision scal_el /1.0d0/
3057 double precision scal_el /0.5d0/
3060 C 13-go grudnia roku pamietnego...
3061 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3062 & 0.0d0,1.0d0,0.0d0,
3063 & 0.0d0,0.0d0,1.0d0/
3064 cd write(iout,*) 'In EELEC'
3066 cd write(iout,*) 'Type',i
3067 cd write(iout,*) 'B1',B1(:,i)
3068 cd write(iout,*) 'B2',B2(:,i)
3069 cd write(iout,*) 'CC',CC(:,:,i)
3070 cd write(iout,*) 'DD',DD(:,:,i)
3071 cd write(iout,*) 'EE',EE(:,:,i)
3073 cd call check_vecgrad
3075 if (icheckgrad.eq.1) then
3077 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3079 dc_norm(k,i)=dc(k,i)*fac
3081 c write (iout,*) 'i',i,' fac',fac
3084 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3085 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3086 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3087 c call vec_and_deriv
3093 time_mat=time_mat+MPI_Wtime()-time01
3097 cd write (iout,*) 'i=',i
3099 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3102 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3103 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3116 cd print '(a)','Enter EELEC'
3117 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3119 gel_loc_loc(i)=0.0d0
3124 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3126 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3128 do i=iturn3_start,iturn3_end
3132 dx_normi=dc_norm(1,i)
3133 dy_normi=dc_norm(2,i)
3134 dz_normi=dc_norm(3,i)
3135 xmedi=c(1,i)+0.5d0*dxi
3136 ymedi=c(2,i)+0.5d0*dyi
3137 zmedi=c(3,i)+0.5d0*dzi
3139 call eelecij(i,i+2,ees,evdw1,eel_loc)
3140 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3141 num_cont_hb(i)=num_conti
3143 do i=iturn4_start,iturn4_end
3147 dx_normi=dc_norm(1,i)
3148 dy_normi=dc_norm(2,i)
3149 dz_normi=dc_norm(3,i)
3150 xmedi=c(1,i)+0.5d0*dxi
3151 ymedi=c(2,i)+0.5d0*dyi
3152 zmedi=c(3,i)+0.5d0*dzi
3153 num_conti=num_cont_hb(i)
3154 call eelecij(i,i+3,ees,evdw1,eel_loc)
3155 if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3156 num_cont_hb(i)=num_conti
3159 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3161 do i=iatel_s,iatel_e
3165 dx_normi=dc_norm(1,i)
3166 dy_normi=dc_norm(2,i)
3167 dz_normi=dc_norm(3,i)
3168 xmedi=c(1,i)+0.5d0*dxi
3169 ymedi=c(2,i)+0.5d0*dyi
3170 zmedi=c(3,i)+0.5d0*dzi
3171 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3172 num_conti=num_cont_hb(i)
3173 do j=ielstart(i),ielend(i)
3174 call eelecij(i,j,ees,evdw1,eel_loc)
3176 num_cont_hb(i)=num_conti
3178 c write (iout,*) "Number of loop steps in EELEC:",ind
3180 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3181 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3183 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3184 ccc eel_loc=eel_loc+eello_turn3
3185 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3188 C-------------------------------------------------------------------------------
3189 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3190 implicit real*8 (a-h,o-z)
3191 include 'DIMENSIONS'
3195 include 'COMMON.CONTROL'
3196 include 'COMMON.IOUNITS'
3197 include 'COMMON.GEO'
3198 include 'COMMON.VAR'
3199 include 'COMMON.LOCAL'
3200 include 'COMMON.CHAIN'
3201 include 'COMMON.DERIV'
3202 include 'COMMON.INTERACT'
3203 include 'COMMON.CONTACTS'
3204 include 'COMMON.TORSION'
3205 include 'COMMON.VECTORS'
3206 include 'COMMON.FFIELD'
3207 include 'COMMON.TIME1'
3208 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3209 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3210 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3211 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3212 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3213 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3215 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3217 double precision scal_el /1.0d0/
3219 double precision scal_el /0.5d0/
3222 C 13-go grudnia roku pamietnego...
3223 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3224 & 0.0d0,1.0d0,0.0d0,
3225 & 0.0d0,0.0d0,1.0d0/
3226 c time00=MPI_Wtime()
3227 cd write (iout,*) "eelecij",i,j
3231 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3232 aaa=app(iteli,itelj)
3233 bbb=bpp(iteli,itelj)
3234 ael6i=ael6(iteli,itelj)
3235 ael3i=ael3(iteli,itelj)
3239 dx_normj=dc_norm(1,j)
3240 dy_normj=dc_norm(2,j)
3241 dz_normj=dc_norm(3,j)
3242 xj=c(1,j)+0.5D0*dxj-xmedi
3243 yj=c(2,j)+0.5D0*dyj-ymedi
3244 zj=c(3,j)+0.5D0*dzj-zmedi
3245 rij=xj*xj+yj*yj+zj*zj
3251 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3252 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3253 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3254 fac=cosa-3.0D0*cosb*cosg
3256 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3257 if (j.eq.i+2) ev1=scal_el*ev1
3262 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3265 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3266 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3269 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3270 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3271 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
3272 cd & xmedi,ymedi,zmedi,xj,yj,zj
3274 if (energy_dec) then
3275 write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3276 write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3280 C Calculate contributions to the Cartesian gradient.
3283 facvdw=-6*rrmij*(ev1+evdwij)
3284 facel=-3*rrmij*(el1+eesij)
3290 * Radial derivatives. First process both termini of the fragment (i,j)
3296 c ghalf=0.5D0*ggg(k)
3297 c gelc(k,i)=gelc(k,i)+ghalf
3298 c gelc(k,j)=gelc(k,j)+ghalf
3300 c 9/28/08 AL Gradient compotents will be summed only at the end
3302 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3303 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3306 * Loop over residues i+1 thru j-1.
3310 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
3317 c ghalf=0.5D0*ggg(k)
3318 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3319 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3321 c 9/28/08 AL Gradient compotents will be summed only at the end
3323 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3324 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3327 * Loop over residues i+1 thru j-1.
3331 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3338 fac=-3*rrmij*(facvdw+facvdw+facel)
3343 * Radial derivatives. First process both termini of the fragment (i,j)
3349 c ghalf=0.5D0*ggg(k)
3350 c gelc(k,i)=gelc(k,i)+ghalf
3351 c gelc(k,j)=gelc(k,j)+ghalf
3353 c 9/28/08 AL Gradient compotents will be summed only at the end
3355 gelc_long(k,j)=gelc(k,j)+ggg(k)
3356 gelc_long(k,i)=gelc(k,i)-ggg(k)
3359 * Loop over residues i+1 thru j-1.
3363 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
3366 c 9/28/08 AL Gradient compotents will be summed only at the end
3371 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3372 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3378 ecosa=2.0D0*fac3*fac1+fac4
3381 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3382 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3384 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3385 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3387 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3388 cd & (dcosg(k),k=1,3)
3390 ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3393 c ghalf=0.5D0*ggg(k)
3394 c gelc(k,i)=gelc(k,i)+ghalf
3395 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3396 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3397 c gelc(k,j)=gelc(k,j)+ghalf
3398 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3399 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3403 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
3408 & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3409 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3411 & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3412 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3413 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3414 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3416 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3417 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3418 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3420 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3421 C energy of a peptide unit is assumed in the form of a second-order
3422 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3423 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3424 C are computed for EVERY pair of non-contiguous peptide groups.
3426 if (j.lt.nres-1) then
3437 muij(kkk)=mu(k,i)*mu(l,j)
3440 cd write (iout,*) 'EELEC: i',i,' j',j
3441 cd write (iout,*) 'j',j,' j1',j1,' j2',j2
3442 cd write(iout,*) 'muij',muij
3443 ury=scalar(uy(1,i),erij)
3444 urz=scalar(uz(1,i),erij)
3445 vry=scalar(uy(1,j),erij)
3446 vrz=scalar(uz(1,j),erij)
3447 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3448 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3449 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3450 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3451 fac=dsqrt(-ael6i)*r3ij
3456 cd write (iout,'(4i5,4f10.5)')
3457 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3458 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3459 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3460 cd & uy(:,j),uz(:,j)
3461 cd write (iout,'(4f10.5)')
3462 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3463 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3464 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
3465 cd write (iout,'(9f10.5/)')
3466 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3467 C Derivatives of the elements of A in virtual-bond vectors
3468 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3470 uryg(k,1)=scalar(erder(1,k),uy(1,i))
3471 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3472 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3473 urzg(k,1)=scalar(erder(1,k),uz(1,i))
3474 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3475 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3476 vryg(k,1)=scalar(erder(1,k),uy(1,j))
3477 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3478 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3479 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3480 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3481 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3483 C Compute radial contributions to the gradient
3501 C Add the contributions coming from er
3504 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3505 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3506 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3507 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3510 C Derivatives in DC(i)
3511 cgrad ghalf1=0.5d0*agg(k,1)
3512 cgrad ghalf2=0.5d0*agg(k,2)
3513 cgrad ghalf3=0.5d0*agg(k,3)
3514 cgrad ghalf4=0.5d0*agg(k,4)
3515 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3516 & -3.0d0*uryg(k,2)*vry)!+ghalf1
3517 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3518 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
3519 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3520 & -3.0d0*urzg(k,2)*vry)!+ghalf3
3521 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3522 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
3523 C Derivatives in DC(i+1)
3524 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3525 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3526 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3527 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3528 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3529 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3530 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3531 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3532 C Derivatives in DC(j)
3533 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3534 & -3.0d0*vryg(k,2)*ury)!+ghalf1
3535 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3536 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
3537 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3538 & -3.0d0*vryg(k,2)*urz)!+ghalf3
3539 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3540 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
3541 C Derivatives in DC(j+1) or DC(nres-1)
3542 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3543 & -3.0d0*vryg(k,3)*ury)
3544 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3545 & -3.0d0*vrzg(k,3)*ury)
3546 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3547 & -3.0d0*vryg(k,3)*urz)
3548 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3549 & -3.0d0*vrzg(k,3)*urz)
3550 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
3552 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
3565 aggi(k,l)=-aggi(k,l)
3566 aggi1(k,l)=-aggi1(k,l)
3567 aggj(k,l)=-aggj(k,l)
3568 aggj1(k,l)=-aggj1(k,l)
3571 if (j.lt.nres-1) then
3577 aggi(k,l)=-aggi(k,l)
3578 aggi1(k,l)=-aggi1(k,l)
3579 aggj(k,l)=-aggj(k,l)
3580 aggj1(k,l)=-aggj1(k,l)
3591 aggi(k,l)=-aggi(k,l)
3592 aggi1(k,l)=-aggi1(k,l)
3593 aggj(k,l)=-aggj(k,l)
3594 aggj1(k,l)=-aggj1(k,l)
3599 IF (wel_loc.gt.0.0d0) THEN
3600 C Contribution to the local-electrostatic energy coming from the i-j pair
3601 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3603 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3605 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3606 & 'eelloc',i,j,eel_loc_ij
3608 eel_loc=eel_loc+eel_loc_ij
3609 C Partial derivatives in virtual-bond dihedral angles gamma
3611 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3612 & a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3613 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3614 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3615 & a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3616 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3617 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3619 ggg(l)=agg(l,1)*muij(1)+
3620 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3621 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3622 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3623 cgrad ghalf=0.5d0*ggg(l)
3624 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
3625 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
3629 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3632 C Remaining derivatives of eello
3634 gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3635 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3636 gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3637 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3638 gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3639 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3640 gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3641 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3644 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3645 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
3646 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3647 & .and. num_conti.le.maxconts) then
3648 c write (iout,*) i,j," entered corr"
3650 C Calculate the contact function. The ith column of the array JCONT will
3651 C contain the numbers of atoms that make contacts with the atom I (of numbers
3652 C greater than I). The arrays FACONT and GACONT will contain the values of
3653 C the contact function and its derivative.
3654 c r0ij=1.02D0*rpp(iteli,itelj)
3655 c r0ij=1.11D0*rpp(iteli,itelj)
3656 r0ij=2.20D0*rpp(iteli,itelj)
3657 c r0ij=1.55D0*rpp(iteli,itelj)
3658 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3659 if (fcont.gt.0.0D0) then
3660 num_conti=num_conti+1
3661 if (num_conti.gt.maxconts) then
3662 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3663 & ' will skip next contacts for this conf.'
3665 jcont_hb(num_conti,i)=j
3666 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
3667 cd & " jcont_hb",jcont_hb(num_conti,i)
3668 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3669 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3670 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3672 d_cont(num_conti,i)=rij
3673 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3674 C --- Electrostatic-interaction matrix ---
3675 a_chuj(1,1,num_conti,i)=a22
3676 a_chuj(1,2,num_conti,i)=a23
3677 a_chuj(2,1,num_conti,i)=a32
3678 a_chuj(2,2,num_conti,i)=a33
3679 C --- Gradient of rij
3681 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3688 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3689 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3690 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3691 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3692 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3697 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3698 C Calculate contact energies
3700 wij=cosa-3.0D0*cosb*cosg
3703 c fac3=dsqrt(-ael6i)/r0ij**3
3704 fac3=dsqrt(-ael6i)*r3ij
3705 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3706 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3707 if (ees0tmp.gt.0) then
3708 ees0pij=dsqrt(ees0tmp)
3712 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3713 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3714 if (ees0tmp.gt.0) then
3715 ees0mij=dsqrt(ees0tmp)
3720 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3721 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3722 C Diagnostics. Comment out or remove after debugging!
3723 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3724 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3725 c ees0m(num_conti,i)=0.0D0
3727 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3728 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3729 C Angular derivatives of the contact function
3730 ees0pij1=fac3/ees0pij
3731 ees0mij1=fac3/ees0mij
3732 fac3p=-3.0D0*fac3*rrmij
3733 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3734 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3736 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
3737 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3738 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3739 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
3740 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3741 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3742 ecosap=ecosa1+ecosa2
3743 ecosbp=ecosb1+ecosb2
3744 ecosgp=ecosg1+ecosg2
3745 ecosam=ecosa1-ecosa2
3746 ecosbm=ecosb1-ecosb2
3747 ecosgm=ecosg1-ecosg2
3756 facont_hb(num_conti,i)=fcont
3757 fprimcont=fprimcont/rij
3758 cd facont_hb(num_conti,i)=1.0D0
3759 C Following line is for diagnostics.
3762 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3763 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3766 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3767 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3769 gggp(1)=gggp(1)+ees0pijp*xj
3770 gggp(2)=gggp(2)+ees0pijp*yj
3771 gggp(3)=gggp(3)+ees0pijp*zj
3772 gggm(1)=gggm(1)+ees0mijp*xj
3773 gggm(2)=gggm(2)+ees0mijp*yj
3774 gggm(3)=gggm(3)+ees0mijp*zj
3775 C Derivatives due to the contact function
3776 gacont_hbr(1,num_conti,i)=fprimcont*xj
3777 gacont_hbr(2,num_conti,i)=fprimcont*yj
3778 gacont_hbr(3,num_conti,i)=fprimcont*zj
3781 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3782 c following the change of gradient-summation algorithm.
3784 cgrad ghalfp=0.5D0*gggp(k)
3785 cgrad ghalfm=0.5D0*gggm(k)
3786 gacontp_hb1(k,num_conti,i)=!ghalfp
3787 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3788 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3789 gacontp_hb2(k,num_conti,i)=!ghalfp
3790 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3791 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3792 gacontp_hb3(k,num_conti,i)=gggp(k)
3793 gacontm_hb1(k,num_conti,i)=!ghalfm
3794 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3795 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3796 gacontm_hb2(k,num_conti,i)=!ghalfm
3797 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3798 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3799 gacontm_hb3(k,num_conti,i)=gggm(k)
3801 C Diagnostics. Comment out or remove after debugging!
3803 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
3804 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
3805 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
3806 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
3807 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
3808 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
3811 endif ! num_conti.le.maxconts
3814 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3817 ghalf=0.5d0*agg(l,k)
3818 aggi(l,k)=aggi(l,k)+ghalf
3819 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3820 aggj(l,k)=aggj(l,k)+ghalf
3823 if (j.eq.nres-1 .and. i.lt.j-2) then
3826 aggj1(l,k)=aggj1(l,k)+agg(l,k)
3831 c t_eelecij=t_eelecij+MPI_Wtime()-time00
3834 C-----------------------------------------------------------------------------
3835 subroutine eturn3(i,eello_turn3)
3836 C Third- and fourth-order contributions from turns
3837 implicit real*8 (a-h,o-z)
3838 include 'DIMENSIONS'
3839 include 'COMMON.IOUNITS'
3840 include 'COMMON.GEO'
3841 include 'COMMON.VAR'
3842 include 'COMMON.LOCAL'
3843 include 'COMMON.CHAIN'
3844 include 'COMMON.DERIV'
3845 include 'COMMON.INTERACT'
3846 include 'COMMON.CONTACTS'
3847 include 'COMMON.TORSION'
3848 include 'COMMON.VECTORS'
3849 include 'COMMON.FFIELD'
3850 include 'COMMON.CONTROL'
3852 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3853 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3854 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3855 double precision agg(3,4),aggi(3,4),aggi1(3,4),
3856 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3857 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3858 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3861 c write (iout,*) "eturn3",i,j,j1,j2
3866 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3868 C Third-order contributions
3875 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3876 cd call checkint_turn3(i,a_temp,eello_turn3_num)
3877 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3878 call transpose2(auxmat(1,1),auxmat1(1,1))
3879 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3880 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3881 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3882 & 'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3883 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
3884 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
3885 cd & ' eello_turn3_num',4*eello_turn3_num
3886 C Derivatives in gamma(i)
3887 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3888 call transpose2(auxmat2(1,1),auxmat3(1,1))
3889 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3890 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3891 C Derivatives in gamma(i+1)
3892 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3893 call transpose2(auxmat2(1,1),auxmat3(1,1))
3894 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3895 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3896 & +0.5d0*(pizda(1,1)+pizda(2,2))
3897 C Cartesian derivatives
3900 c ghalf1=0.5d0*agg(l,1)
3901 c ghalf2=0.5d0*agg(l,2)
3902 c ghalf3=0.5d0*agg(l,3)
3903 c ghalf4=0.5d0*agg(l,4)
3904 a_temp(1,1)=aggi(l,1)!+ghalf1
3905 a_temp(1,2)=aggi(l,2)!+ghalf2
3906 a_temp(2,1)=aggi(l,3)!+ghalf3
3907 a_temp(2,2)=aggi(l,4)!+ghalf4
3908 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3909 gcorr3_turn(l,i)=gcorr3_turn(l,i)
3910 & +0.5d0*(pizda(1,1)+pizda(2,2))
3911 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3912 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3913 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3914 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3915 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3916 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3917 & +0.5d0*(pizda(1,1)+pizda(2,2))
3918 a_temp(1,1)=aggj(l,1)!+ghalf1
3919 a_temp(1,2)=aggj(l,2)!+ghalf2
3920 a_temp(2,1)=aggj(l,3)!+ghalf3
3921 a_temp(2,2)=aggj(l,4)!+ghalf4
3922 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3923 gcorr3_turn(l,j)=gcorr3_turn(l,j)
3924 & +0.5d0*(pizda(1,1)+pizda(2,2))
3925 a_temp(1,1)=aggj1(l,1)
3926 a_temp(1,2)=aggj1(l,2)
3927 a_temp(2,1)=aggj1(l,3)
3928 a_temp(2,2)=aggj1(l,4)
3929 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3930 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3931 & +0.5d0*(pizda(1,1)+pizda(2,2))
3935 C-------------------------------------------------------------------------------
3936 subroutine eturn4(i,eello_turn4)
3937 C Third- and fourth-order contributions from turns
3938 implicit real*8 (a-h,o-z)
3939 include 'DIMENSIONS'
3940 include 'COMMON.IOUNITS'
3941 include 'COMMON.GEO'
3942 include 'COMMON.VAR'
3943 include 'COMMON.LOCAL'
3944 include 'COMMON.CHAIN'
3945 include 'COMMON.DERIV'
3946 include 'COMMON.INTERACT'
3947 include 'COMMON.CONTACTS'
3948 include 'COMMON.TORSION'
3949 include 'COMMON.VECTORS'
3950 include 'COMMON.FFIELD'
3951 include 'COMMON.CONTROL'
3953 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3954 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3955 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3956 double precision agg(3,4),aggi(3,4),aggi1(3,4),
3957 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3958 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3959 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3962 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3964 C Fourth-order contributions
3972 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3973 cd call checkint_turn4(i,a_temp,eello_turn4_num)
3974 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3979 iti1=itortyp(itype(i+1))
3980 iti2=itortyp(itype(i+2))
3981 iti3=itortyp(itype(i+3))
3982 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3983 call transpose2(EUg(1,1,i+1),e1t(1,1))
3984 call transpose2(Eug(1,1,i+2),e2t(1,1))
3985 call transpose2(Eug(1,1,i+3),e3t(1,1))
3986 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3987 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3988 s1=scalar2(b1(1,iti2),auxvec(1))
3989 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3990 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3991 s2=scalar2(b1(1,iti1),auxvec(1))
3992 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3993 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3994 s3=0.5d0*(pizda(1,1)+pizda(2,2))
3995 eello_turn4=eello_turn4-(s1+s2+s3)
3996 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3997 & 'eturn4',i,j,-(s1+s2+s3)
3998 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3999 cd & ' eello_turn4_num',8*eello_turn4_num
4000 C Derivatives in gamma(i)
4001 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4002 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4003 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4004 s1=scalar2(b1(1,iti2),auxvec(1))
4005 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4006 s3=0.5d0*(pizda(1,1)+pizda(2,2))
4007 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4008 C Derivatives in gamma(i+1)
4009 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4010 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4011 s2=scalar2(b1(1,iti1),auxvec(1))
4012 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4013 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4014 s3=0.5d0*(pizda(1,1)+pizda(2,2))
4015 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4016 C Derivatives in gamma(i+2)
4017 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4018 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4019 s1=scalar2(b1(1,iti2),auxvec(1))
4020 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4021 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4022 s2=scalar2(b1(1,iti1),auxvec(1))
4023 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4024 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4025 s3=0.5d0*(pizda(1,1)+pizda(2,2))
4026 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4027 C Cartesian derivatives
4028 C Derivatives of this turn contributions in DC(i+2)
4029 if (j.lt.nres-1) then
4031 a_temp(1,1)=agg(l,1)
4032 a_temp(1,2)=agg(l,2)
4033 a_temp(2,1)=agg(l,3)
4034 a_temp(2,2)=agg(l,4)
4035 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4036 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4037 s1=scalar2(b1(1,iti2),auxvec(1))
4038 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4039 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4040 s2=scalar2(b1(1,iti1),auxvec(1))
4041 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4042 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4043 s3=0.5d0*(pizda(1,1)+pizda(2,2))
4045 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4048 C Remaining derivatives of this turn contribution
4050 a_temp(1,1)=aggi(l,1)
4051 a_temp(1,2)=aggi(l,2)
4052 a_temp(2,1)=aggi(l,3)
4053 a_temp(2,2)=aggi(l,4)
4054 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4055 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4056 s1=scalar2(b1(1,iti2),auxvec(1))
4057 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4058 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4059 s2=scalar2(b1(1,iti1),auxvec(1))
4060 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4061 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4062 s3=0.5d0*(pizda(1,1)+pizda(2,2))
4063 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4064 a_temp(1,1)=aggi1(l,1)
4065 a_temp(1,2)=aggi1(l,2)
4066 a_temp(2,1)=aggi1(l,3)
4067 a_temp(2,2)=aggi1(l,4)
4068 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4069 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4070 s1=scalar2(b1(1,iti2),auxvec(1))
4071 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4072 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4073 s2=scalar2(b1(1,iti1),auxvec(1))
4074 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4075 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4076 s3=0.5d0*(pizda(1,1)+pizda(2,2))
4077 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4078 a_temp(1,1)=aggj(l,1)
4079 a_temp(1,2)=aggj(l,2)
4080 a_temp(2,1)=aggj(l,3)
4081 a_temp(2,2)=aggj(l,4)
4082 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4083 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4084 s1=scalar2(b1(1,iti2),auxvec(1))
4085 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4086 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4087 s2=scalar2(b1(1,iti1),auxvec(1))
4088 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4089 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4090 s3=0.5d0*(pizda(1,1)+pizda(2,2))
4091 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4092 a_temp(1,1)=aggj1(l,1)
4093 a_temp(1,2)=aggj1(l,2)
4094 a_temp(2,1)=aggj1(l,3)
4095 a_temp(2,2)=aggj1(l,4)
4096 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4097 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4098 s1=scalar2(b1(1,iti2),auxvec(1))
4099 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4100 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4101 s2=scalar2(b1(1,iti1),auxvec(1))
4102 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4103 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4104 s3=0.5d0*(pizda(1,1)+pizda(2,2))
4105 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4106 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4110 C-----------------------------------------------------------------------------
4111 subroutine vecpr(u,v,w)
4112 implicit real*8(a-h,o-z)
4113 dimension u(3),v(3),w(3)
4114 w(1)=u(2)*v(3)-u(3)*v(2)
4115 w(2)=-u(1)*v(3)+u(3)*v(1)
4116 w(3)=u(1)*v(2)-u(2)*v(1)
4119 C-----------------------------------------------------------------------------
4120 subroutine unormderiv(u,ugrad,unorm,ungrad)
4121 C This subroutine computes the derivatives of a normalized vector u, given
4122 C the derivatives computed without normalization conditions, ugrad. Returns
4125 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4126 double precision vec(3)
4127 double precision scalar
4129 c write (2,*) 'ugrad',ugrad
4132 vec(i)=scalar(ugrad(1,i),u(1))
4134 c write (2,*) 'vec',vec
4137 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4140 c write (2,*) 'ungrad',ungrad
4143 C-----------------------------------------------------------------------------
4144 subroutine escp_soft_sphere(evdw2,evdw2_14)
4146 C This subroutine calculates the excluded-volume interaction energy between
4147 C peptide-group centers and side chains and its gradient in virtual-bond and
4148 C side-chain vectors.
4150 implicit real*8 (a-h,o-z)
4151 include 'DIMENSIONS'
4152 include 'COMMON.GEO'
4153 include 'COMMON.VAR'
4154 include 'COMMON.LOCAL'
4155 include 'COMMON.CHAIN'
4156 include 'COMMON.DERIV'
4157 include 'COMMON.INTERACT'
4158 include 'COMMON.FFIELD'
4159 include 'COMMON.IOUNITS'
4160 include 'COMMON.CONTROL'
4165 cd print '(a)','Enter ESCP'
4166 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4167 do i=iatscp_s,iatscp_e
4169 xi=0.5D0*(c(1,i)+c(1,i+1))
4170 yi=0.5D0*(c(2,i)+c(2,i+1))
4171 zi=0.5D0*(c(3,i)+c(3,i+1))
4173 do iint=1,nscp_gr(i)
4175 do j=iscpstart(i,iint),iscpend(i,iint)
4177 C Uncomment following three lines for SC-p interactions
4181 C Uncomment following three lines for Ca-p interactions
4185 rij=xj*xj+yj*yj+zj*zj
4188 if (rij.lt.r0ijsq) then
4189 evdwij=0.25d0*(rij-r0ijsq)**2
4197 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4202 cgrad if (j.lt.i) then
4203 cd write (iout,*) 'j<i'
4204 C Uncomment following three lines for SC-p interactions
4206 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4209 cd write (iout,*) 'j>i'
4211 cgrad ggg(k)=-ggg(k)
4212 C Uncomment following line for SC-p interactions
4213 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4217 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4219 cgrad kstart=min0(i+1,j)
4220 cgrad kend=max0(i-1,j-1)
4221 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4222 cd write (iout,*) ggg(1),ggg(2),ggg(3)
4223 cgrad do k=kstart,kend
4225 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4229 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4230 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4238 C-----------------------------------------------------------------------------
4239 subroutine escp(evdw2,evdw2_14)
4241 C This subroutine calculates the excluded-volume interaction energy between
4242 C peptide-group centers and side chains and its gradient in virtual-bond and
4243 C side-chain vectors.
4245 implicit real*8 (a-h,o-z)
4246 include 'DIMENSIONS'
4247 include 'COMMON.GEO'
4248 include 'COMMON.VAR'
4249 include 'COMMON.LOCAL'
4250 include 'COMMON.CHAIN'
4251 include 'COMMON.DERIV'
4252 include 'COMMON.INTERACT'
4253 include 'COMMON.FFIELD'
4254 include 'COMMON.IOUNITS'
4255 include 'COMMON.CONTROL'
4259 cd print '(a)','Enter ESCP'
4260 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4261 do i=iatscp_s,iatscp_e
4263 xi=0.5D0*(c(1,i)+c(1,i+1))
4264 yi=0.5D0*(c(2,i)+c(2,i+1))
4265 zi=0.5D0*(c(3,i)+c(3,i+1))
4267 do iint=1,nscp_gr(i)
4269 do j=iscpstart(i,iint),iscpend(i,iint)
4271 C Uncomment following three lines for SC-p interactions
4275 C Uncomment following three lines for Ca-p interactions
4279 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4281 e1=fac*fac*aad(itypj,iteli)
4282 e2=fac*bad(itypj,iteli)
4283 if (iabs(j-i) .le. 2) then
4286 evdw2_14=evdw2_14+e1+e2
4290 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4291 & 'evdw2',i,j,evdwij
4293 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4295 fac=-(evdwij+e1)*rrij
4299 cgrad if (j.lt.i) then
4300 cd write (iout,*) 'j<i'
4301 C Uncomment following three lines for SC-p interactions
4303 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4306 cd write (iout,*) 'j>i'
4308 cgrad ggg(k)=-ggg(k)
4309 C Uncomment following line for SC-p interactions
4310 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4311 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4315 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4317 cgrad kstart=min0(i+1,j)
4318 cgrad kend=max0(i-1,j-1)
4319 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4320 cd write (iout,*) ggg(1),ggg(2),ggg(3)
4321 cgrad do k=kstart,kend
4323 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4327 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4328 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4336 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4337 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4338 gradx_scp(j,i)=expon*gradx_scp(j,i)
4341 C******************************************************************************
4345 C To save time the factor EXPON has been extracted from ALL components
4346 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4349 C******************************************************************************
4352 C--------------------------------------------------------------------------
4353 subroutine edis(ehpb)
4355 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4357 implicit real*8 (a-h,o-z)
4358 include 'DIMENSIONS'
4359 include 'COMMON.SBRIDGE'
4360 include 'COMMON.CHAIN'
4361 include 'COMMON.DERIV'
4362 include 'COMMON.VAR'
4363 include 'COMMON.INTERACT'
4364 include 'COMMON.IOUNITS'
4365 include 'COMMON.CONTROL'
4371 C write (iout,*) ,"link_end",link_end,constr_dist
4372 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4373 c write(iout,*)'link_start=',link_start,' link_end=',link_end,
4374 c & " constr_dist",constr_dist
4375 if (link_end.eq.0) return
4376 do i=link_start,link_end
4377 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4378 C CA-CA distance used in regularization of structure.
4381 C iii and jjj point to the residues for which the distance is assigned.
4382 if (ii.gt.nres) then
4389 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4390 c & dhpb(i),dhpb1(i),forcon(i)
4391 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4392 C distance and angle dependent SS bond potential.
4393 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4394 C & iabs(itype(jjj)).eq.1) then
4395 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4396 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4397 if (.not.dyn_ss .and. i.le.nss) then
4398 C 15/02/13 CC dynamic SSbond - additional check
4399 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4400 & iabs(itype(jjj)).eq.1) then
4401 call ssbond_ene(iii,jjj,eij)
4404 cd write (iout,*) "eij",eij
4405 cd & ' waga=',waga,' fac=',fac
4406 ! else if (ii.gt.nres .and. jj.gt.nres) then
4408 C Calculate the distance between the two points and its difference from the
4411 if (irestr_type(i).eq.11) then
4412 ehpb=ehpb+fordepth(i)!**4.0d0
4413 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4414 fac=fordepth(i)!**4.0d0
4415 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4416 if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4417 & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4418 & ehpb,irestr_type(i)
4419 else if (irestr_type(i).eq.10) then
4420 c AL 6//19/2018 cross-link restraints
4421 xdis = 0.5d0*(dd/forcon(i))**2
4422 expdis = dexp(-xdis)
4423 c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4424 aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4425 c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4426 c & " wboltzd",wboltzd
4427 ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4428 c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4429 fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4430 & *expdis/(aux*forcon(i)**2)
4431 if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4432 & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4433 & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4434 else if (irestr_type(i).eq.2) then
4435 c Quartic restraints
4436 ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4437 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4438 & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4439 & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4440 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4442 c Quadratic restraints
4444 C Get the force constant corresponding to this distance.
4446 C Calculate the contribution to energy.
4447 ehpb=ehpb+0.5d0*waga*rdis*rdis
4448 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4449 & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4450 & 0.5d0*waga*rdis*rdis,irestr_type(i)
4452 C Evaluate gradient.
4456 c Calculate Cartesian gradient
4458 ggg(j)=fac*(c(j,jj)-c(j,ii))
4460 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4461 C If this is a SC-SC distance, we need to calculate the contributions to the
4462 C Cartesian gradient in the SC vectors (ghpbx).
4465 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4466 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4469 cgrad do j=iii,jjj-1
4471 cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4475 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4476 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4482 C--------------------------------------------------------------------------
4483 subroutine ssbond_ene(i,j,eij)
4485 C Calculate the distance and angle dependent SS-bond potential energy
4486 C using a free-energy function derived based on RHF/6-31G** ab initio
4487 C calculations of diethyl disulfide.
4489 C A. Liwo and U. Kozlowska, 11/24/03
4491 implicit real*8 (a-h,o-z)
4492 include 'DIMENSIONS'
4493 include 'COMMON.SBRIDGE'
4494 include 'COMMON.CHAIN'
4495 include 'COMMON.DERIV'
4496 include 'COMMON.LOCAL'
4497 include 'COMMON.INTERACT'
4498 include 'COMMON.VAR'
4499 include 'COMMON.IOUNITS'
4500 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4505 dxi=dc_norm(1,nres+i)
4506 dyi=dc_norm(2,nres+i)
4507 dzi=dc_norm(3,nres+i)
4508 c dsci_inv=dsc_inv(itypi)
4509 dsci_inv=vbld_inv(nres+i)
4511 c dscj_inv=dsc_inv(itypj)
4512 dscj_inv=vbld_inv(nres+j)
4516 dxj=dc_norm(1,nres+j)
4517 dyj=dc_norm(2,nres+j)
4518 dzj=dc_norm(3,nres+j)
4519 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4524 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4525 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4526 om12=dxi*dxj+dyi*dyj+dzi*dzj
4528 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4529 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4535 deltat12=om2-om1+2.0d0
4537 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4538 & +akct*deltad*deltat12+ebr
4539 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4540 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4541 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4542 c & " deltat12",deltat12," eij",eij
4543 ed=2*akcm*deltad+akct*deltat12
4545 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4546 eom1=-2*akth*deltat1-pom1-om2*pom2
4547 eom2= 2*akth*deltat2+pom1-om1*pom2
4550 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4551 ghpbx(k,i)=ghpbx(k,i)-ggk
4552 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4553 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4554 ghpbx(k,j)=ghpbx(k,j)+ggk
4555 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4556 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4557 ghpbc(k,i)=ghpbc(k,i)-ggk
4558 ghpbc(k,j)=ghpbc(k,j)+ggk
4561 C Calculate the components of the gradient in DC and X
4565 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
4570 C--------------------------------------------------------------------------
4571 subroutine ebond(estr)
4573 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4575 implicit real*8 (a-h,o-z)
4576 include 'DIMENSIONS'
4577 include 'COMMON.LOCAL'
4578 include 'COMMON.GEO'
4579 include 'COMMON.INTERACT'
4580 include 'COMMON.DERIV'
4581 include 'COMMON.VAR'
4582 include 'COMMON.CHAIN'
4583 include 'COMMON.IOUNITS'
4584 include 'COMMON.NAMES'
4585 include 'COMMON.FFIELD'
4586 include 'COMMON.CONTROL'
4587 include 'COMMON.SETUP'
4588 double precision u(3),ud(3)
4590 do i=ibondp_start,ibondp_end
4591 diff = vbld(i)-vbldp0
4592 c write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4593 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
4594 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4597 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4599 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4603 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4605 do i=ibond_start,ibond_end
4610 diff=vbld(i+nres)-vbldsc0(1,iti)
4611 c write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4612 c & AKSC(1,iti),AKSC(1,iti)*diff*diff
4613 if (energy_dec) then
4615 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4616 & AKSC(1,iti),AKSC(1,iti)*diff*diff
4619 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4621 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4625 diff=vbld(i+nres)-vbldsc0(j,iti)
4626 ud(j)=aksc(j,iti)*diff
4627 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4641 uprod2=uprod2*u(k)*u(k)
4645 usumsqder=usumsqder+ud(j)*uprod2
4647 estr=estr+uprod/usum
4649 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4657 C--------------------------------------------------------------------------
4658 subroutine ebend(etheta)
4660 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4661 C angles gamma and its derivatives in consecutive thetas and gammas.
4663 implicit real*8 (a-h,o-z)
4664 include 'DIMENSIONS'
4665 include 'COMMON.LOCAL'
4666 include 'COMMON.GEO'
4667 include 'COMMON.INTERACT'
4668 include 'COMMON.DERIV'
4669 include 'COMMON.VAR'
4670 include 'COMMON.CHAIN'
4671 include 'COMMON.IOUNITS'
4672 include 'COMMON.NAMES'
4673 include 'COMMON.FFIELD'
4674 include 'COMMON.CONTROL'
4675 common /calcthet/ term1,term2,termm,diffak,ratak,
4676 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4677 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4678 double precision y(2),z(2)
4680 c time11=dexp(-2*time)
4683 c write (*,'(a,i2)') 'EBEND ICG=',icg
4684 do i=ithet_start,ithet_end
4685 C Zero the energy function and its derivative at 0 or pi.
4686 call splinthet(theta(i),0.5d0*delta,ss,ssd)
4691 if (phii.ne.phii) phii=150.0
4704 if (phii1.ne.phii1) phii1=150.0
4716 C Calculate the "mean" value of theta from the part of the distribution
4717 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4718 C In following comments this theta will be referred to as t_c.
4719 thet_pred_mean=0.0d0
4723 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4725 dthett=thet_pred_mean*ssd
4726 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4727 C Derivatives of the "mean" values in gamma1 and gamma2.
4728 dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4729 dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4730 if (theta(i).gt.pi-delta) then
4731 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4733 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4734 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4735 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4737 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4739 else if (theta(i).lt.delta) then
4740 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4741 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4742 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4744 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4745 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4748 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4751 etheta=etheta+ethetai
4752 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4754 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4755 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4756 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4758 C Ufff.... We've done all this!!!
4761 C---------------------------------------------------------------------------
4762 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4764 implicit real*8 (a-h,o-z)
4765 include 'DIMENSIONS'
4766 include 'COMMON.LOCAL'
4767 include 'COMMON.IOUNITS'
4768 common /calcthet/ term1,term2,termm,diffak,ratak,
4769 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4770 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4771 C Calculate the contributions to both Gaussian lobes.
4772 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4773 C The "polynomial part" of the "standard deviation" of this part of
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 Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4805 C NaNs in taking the logarithm. We extract the largest exponent which is added
4806 C to the energy (this being the log of the distribution) at the end of energy
4807 C term evaluation for this virtual-bond angle.
4808 if (term1.gt.term2) then
4810 term2=dexp(term2-termm)
4814 term1=dexp(term1-termm)
4817 C The ratio between the gamma-independent and gamma-dependent lobes of
4818 C the distribution is a Gaussian function of thet_pred_mean too.
4819 diffak=gthet(2,it)-thet_pred_mean
4820 ratak=diffak/gthet(3,it)**2
4821 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4822 C Let's differentiate it in thet_pred_mean NOW.
4824 C Now put together the distribution terms to make complete distribution.
4825 termexp=term1+ak*term2
4826 termpre=sigc+ak*sig0i
4827 C Contribution of the bending energy from this theta is just the -log of
4828 C the sum of the contributions from the two lobes and the pre-exponential
4829 C factor. Simple enough, isn't it?
4830 ethetai=(-dlog(termexp)-termm+dlog(termpre))
4831 C NOW the derivatives!!!
4832 C 6/6/97 Take into account the deformation.
4833 E_theta=(delthec*sigcsq*term1
4834 & +ak*delthe0*sig0inv*term2)/termexp
4835 E_tc=((sigtc+aktc*sig0i)/termpre
4836 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4837 & aktc*term2)/termexp)
4840 c-----------------------------------------------------------------------------
4841 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4842 implicit real*8 (a-h,o-z)
4843 include 'DIMENSIONS'
4844 include 'COMMON.LOCAL'
4845 include 'COMMON.IOUNITS'
4846 common /calcthet/ term1,term2,termm,diffak,ratak,
4847 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4848 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4849 delthec=thetai-thet_pred_mean
4850 delthe0=thetai-theta0i
4851 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4852 t3 = thetai-thet_pred_mean
4856 t14 = t12+t6*sigsqtc
4858 t21 = thetai-theta0i
4864 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4865 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4866 & *(-t12*t9-ak*sig0inv*t27)
4870 C--------------------------------------------------------------------------
4871 subroutine ebend(etheta)
4873 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4874 C angles gamma and its derivatives in consecutive thetas and gammas.
4875 C ab initio-derived potentials from
4876 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4878 implicit real*8 (a-h,o-z)
4879 include 'DIMENSIONS'
4880 include 'COMMON.LOCAL'
4881 include 'COMMON.GEO'
4882 include 'COMMON.INTERACT'
4883 include 'COMMON.DERIV'
4884 include 'COMMON.VAR'
4885 include 'COMMON.CHAIN'
4886 include 'COMMON.IOUNITS'
4887 include 'COMMON.NAMES'
4888 include 'COMMON.FFIELD'
4889 include 'COMMON.CONTROL'
4890 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4891 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4892 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4893 & sinph1ph2(maxdouble,maxdouble)
4894 logical lprn /.false./, lprn1 /.false./
4896 c write (iout,*) "EBEND ithet_start",ithet_start,
4897 c & " ithet_end",ithet_end
4898 do i=ithet_start,ithet_end
4899 if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4900 &(itype(i).eq.ntyp1)) cycle
4904 theti2=0.5d0*theta(i)
4905 ityp2=ithetyp(itype(i-1))
4907 coskt(k)=dcos(k*theti2)
4908 sinkt(k)=dsin(k*theti2)
4911 if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4914 if (phii.ne.phii) phii=150.0
4918 ityp1=ithetyp(itype(i-2))
4920 cosph1(k)=dcos(k*phii)
4921 sinph1(k)=dsin(k*phii)
4925 ityp1=ithetyp(itype(i-2))
4931 if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4934 if (phii1.ne.phii1) phii1=150.0
4939 ityp3=ithetyp(itype(i))
4941 cosph2(k)=dcos(k*phii1)
4942 sinph2(k)=dsin(k*phii1)
4946 ityp3=ithetyp(itype(i))
4952 ethetai=aa0thet(ityp1,ityp2,ityp3)
4955 ccl=cosph1(l)*cosph2(k-l)
4956 ssl=sinph1(l)*sinph2(k-l)
4957 scl=sinph1(l)*cosph2(k-l)
4958 csl=cosph1(l)*sinph2(k-l)
4959 cosph1ph2(l,k)=ccl-ssl
4960 cosph1ph2(k,l)=ccl+ssl
4961 sinph1ph2(l,k)=scl+csl
4962 sinph1ph2(k,l)=scl-csl
4966 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4967 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4968 write (iout,*) "coskt and sinkt"
4970 write (iout,*) k,coskt(k),sinkt(k)
4974 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4975 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4978 & write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4979 & " ethetai",ethetai
4982 write (iout,*) "cosph and sinph"
4984 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4986 write (iout,*) "cosph1ph2 and sinph2ph2"
4989 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4990 & sinph1ph2(l,k),sinph1ph2(k,l)
4993 write(iout,*) "ethetai",ethetai
4997 aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4998 & +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4999 & +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
5000 & +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
5001 ethetai=ethetai+sinkt(m)*aux
5002 dethetai=dethetai+0.5d0*m*aux*coskt(m)
5003 dephii=dephii+k*sinkt(m)*(
5004 & ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
5005 & bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
5006 dephii1=dephii1+k*sinkt(m)*(
5007 & eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
5008 & ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
5010 & write (iout,*) "m",m," k",k," bbthet",
5011 & bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
5012 & ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
5013 & ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5014 & eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5018 & write(iout,*) "ethetai",ethetai
5022 aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5023 & ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5024 & ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5025 & ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5026 ethetai=ethetai+sinkt(m)*aux
5027 dethetai=dethetai+0.5d0*m*coskt(m)*aux
5028 dephii=dephii+l*sinkt(m)*(
5029 & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5030 & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5031 & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5032 & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5033 dephii1=dephii1+(k-l)*sinkt(m)*(
5034 & -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5035 & ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5036 & ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5037 & ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5039 write (iout,*) "m",m," k",k," l",l," ffthet",
5040 & ffthet(l,k,m,ityp1,ityp2,ityp3),
5041 & ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5042 & ggthet(l,k,m,ityp1,ityp2,ityp3),
5043 & ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5044 write (iout,*) cosph1ph2(l,k)*sinkt(m),
5045 & cosph1ph2(k,l)*sinkt(m),
5046 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5053 if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
5054 & 'ebe', i,theta(i)*rad2deg,phii*rad2deg,
5055 & phii1*rad2deg,ethetai
5057 etheta=etheta+ethetai
5058 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5060 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5061 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5062 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5068 c-----------------------------------------------------------------------------
5069 subroutine esc(escloc)
5070 C Calculate the local energy of a side chain and its derivatives in the
5071 C corresponding virtual-bond valence angles THETA and the spherical angles
5073 implicit real*8 (a-h,o-z)
5074 include 'DIMENSIONS'
5075 include 'COMMON.GEO'
5076 include 'COMMON.LOCAL'
5077 include 'COMMON.VAR'
5078 include 'COMMON.INTERACT'
5079 include 'COMMON.DERIV'
5080 include 'COMMON.CHAIN'
5081 include 'COMMON.IOUNITS'
5082 include 'COMMON.NAMES'
5083 include 'COMMON.FFIELD'
5084 include 'COMMON.CONTROL'
5085 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5086 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
5087 common /sccalc/ time11,time12,time112,theti,it,nlobit
5090 c write (iout,'(a)') 'ESC'
5091 do i=loc_start,loc_end
5093 if (it.eq.10) goto 1
5095 c print *,'i=',i,' it=',it,' nlobit=',nlobit
5096 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5097 theti=theta(i+1)-pipol
5102 if (x(2).gt.pi-delta) then
5106 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5108 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5109 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5111 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5112 & ddersc0(1),dersc(1))
5113 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5114 & ddersc0(3),dersc(3))
5116 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5118 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5119 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5120 & dersc0(2),esclocbi,dersc02)
5121 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5123 call splinthet(x(2),0.5d0*delta,ss,ssd)
5128 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5130 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5131 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5133 escloci=ss*escloci+(1.0d0-ss)*esclocbi
5135 c write (iout,*) escloci
5136 else if (x(2).lt.delta) then
5140 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5142 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5143 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5145 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5146 & ddersc0(1),dersc(1))
5147 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5148 & ddersc0(3),dersc(3))
5150 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5152 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5153 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5154 & dersc0(2),esclocbi,dersc02)
5155 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5160 call splinthet(x(2),0.5d0*delta,ss,ssd)
5162 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5164 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5165 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5167 escloci=ss*escloci+(1.0d0-ss)*esclocbi
5168 c write (iout,*) escloci
5170 call enesc(x,escloci,dersc,ddummy,.false.)
5173 escloc=escloc+escloci
5174 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5175 & 'escloc',i,escloci
5176 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5178 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5180 gloc(ialph(i,1),icg)=wscloc*dersc(2)
5181 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5186 C---------------------------------------------------------------------------
5187 subroutine enesc(x,escloci,dersc,ddersc,mixed)
5188 implicit real*8 (a-h,o-z)
5189 include 'DIMENSIONS'
5190 include 'COMMON.GEO'
5191 include 'COMMON.LOCAL'
5192 include 'COMMON.IOUNITS'
5193 common /sccalc/ time11,time12,time112,theti,it,nlobit
5194 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5195 double precision contr(maxlob,-1:1)
5197 c write (iout,*) 'it=',it,' nlobit=',nlobit
5201 if (mixed) ddersc(j)=0.0d0
5205 C Because of periodicity of the dependence of the SC energy in omega we have
5206 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5207 C To avoid underflows, first compute & store the exponents.
5215 z(k)=x(k)-censc(k,j,it)
5220 Axk=Axk+gaussc(l,k,j,it)*z(l)
5226 expfac=expfac+Ax(k,j,iii)*z(k)
5234 C As in the case of ebend, we want to avoid underflows in exponentiation and
5235 C subsequent NaNs and INFs in energy calculation.
5236 C Find the largest exponent
5240 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5244 cd print *,'it=',it,' emin=',emin
5246 C Compute the contribution to SC energy and derivatives
5251 adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5252 if(adexp.ne.adexp) adexp=1.0
5255 expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5257 cd print *,'j=',j,' expfac=',expfac
5258 escloc_i=escloc_i+expfac
5260 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5264 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5265 & +gaussc(k,2,j,it))*expfac
5272 dersc(1)=dersc(1)/cos(theti)**2
5273 ddersc(1)=ddersc(1)/cos(theti)**2
5276 escloci=-(dlog(escloc_i)-emin)
5278 dersc(j)=dersc(j)/escloc_i
5282 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5287 C------------------------------------------------------------------------------
5288 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5289 implicit real*8 (a-h,o-z)
5290 include 'DIMENSIONS'
5291 include 'COMMON.GEO'
5292 include 'COMMON.LOCAL'
5293 include 'COMMON.IOUNITS'
5294 common /sccalc/ time11,time12,time112,theti,it,nlobit
5295 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5296 double precision contr(maxlob)
5307 z(k)=x(k)-censc(k,j,it)
5313 Axk=Axk+gaussc(l,k,j,it)*z(l)
5319 expfac=expfac+Ax(k,j)*z(k)
5324 C As in the case of ebend, we want to avoid underflows in exponentiation and
5325 C subsequent NaNs and INFs in energy calculation.
5326 C Find the largest exponent
5329 if (emin.gt.contr(j)) emin=contr(j)
5333 C Compute the contribution to SC energy and derivatives
5337 expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5338 escloc_i=escloc_i+expfac
5340 dersc(k)=dersc(k)+Ax(k,j)*expfac
5342 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5343 & +gaussc(1,2,j,it))*expfac
5347 dersc(1)=dersc(1)/cos(theti)**2
5348 dersc12=dersc12/cos(theti)**2
5349 escloci=-(dlog(escloc_i)-emin)
5351 dersc(j)=dersc(j)/escloc_i
5353 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5357 c----------------------------------------------------------------------------------
5358 subroutine esc(escloc)
5359 C Calculate the local energy of a side chain and its derivatives in the
5360 C corresponding virtual-bond valence angles THETA and the spherical angles
5361 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5362 C added by Urszula Kozlowska. 07/11/2007
5364 implicit real*8 (a-h,o-z)
5365 include 'DIMENSIONS'
5366 include 'COMMON.GEO'
5367 include 'COMMON.LOCAL'
5368 include 'COMMON.VAR'
5369 include 'COMMON.SCROT'
5370 include 'COMMON.INTERACT'
5371 include 'COMMON.DERIV'
5372 include 'COMMON.CHAIN'
5373 include 'COMMON.IOUNITS'
5374 include 'COMMON.NAMES'
5375 include 'COMMON.FFIELD'
5376 include 'COMMON.CONTROL'
5377 include 'COMMON.VECTORS'
5378 double precision x_prime(3),y_prime(3),z_prime(3)
5379 & , sumene,dsc_i,dp2_i,x(65),
5380 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5381 & de_dxx,de_dyy,de_dzz,de_dt
5382 double precision s1_t,s1_6_t,s2_t,s2_6_t
5384 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5385 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5386 & dt_dCi(3),dt_dCi1(3)
5387 common /sccalc/ time11,time12,time112,theti,it,nlobit
5390 c write(iout,*) "ESC: loc_start",loc_start," loc_end",loc_end
5391 do i=loc_start,loc_end
5392 costtab(i+1) =dcos(theta(i+1))
5393 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5394 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5395 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5396 cosfac2=0.5d0/(1.0d0+costtab(i+1))
5397 cosfac=dsqrt(cosfac2)
5398 sinfac2=0.5d0/(1.0d0-costtab(i+1))
5399 sinfac=dsqrt(sinfac2)
5401 if (it.eq.10) goto 1
5403 C Compute the axes of tghe local cartesian coordinates system; store in
5404 c x_prime, y_prime and z_prime
5411 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5412 C & dc_norm(3,i+nres)
5414 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5415 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5418 z_prime(j) = -uz(j,i-1)
5421 c write (2,*) "x_prime",(x_prime(j),j=1,3)
5422 c write (2,*) "y_prime",(y_prime(j),j=1,3)
5423 c write (2,*) "z_prime",(z_prime(j),j=1,3)
5424 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5425 c & " xy",scalar(x_prime(1),y_prime(1)),
5426 c & " xz",scalar(x_prime(1),z_prime(1)),
5427 c & " yy",scalar(y_prime(1),y_prime(1)),
5428 c & " yz",scalar(y_prime(1),z_prime(1)),
5429 c & " zz",scalar(z_prime(1),z_prime(1))
5431 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5432 C to local coordinate system. Store in xx, yy, zz.
5438 xx = xx + x_prime(j)*dc_norm(j,i+nres)
5439 yy = yy + y_prime(j)*dc_norm(j,i+nres)
5440 zz = zz + z_prime(j)*dc_norm(j,i+nres)
5447 C Compute the energy of the ith side cbain
5449 c write (2,*) "xx",xx," yy",yy," zz",zz
5452 x(j) = sc_parmin(j,it)
5455 Cc diagnostics - remove later
5457 yy1 = dsin(alph(2))*dcos(omeg(2))
5458 zz1 = -dsin(alph(2))*dsin(omeg(2))
5459 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5460 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5462 C," --- ", xx_w,yy_w,zz_w
5465 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
5466 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
5468 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5469 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5471 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5472 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5473 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5474 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5475 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5477 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5478 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5479 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5480 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5481 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5483 dsc_i = 0.743d0+x(61)
5485 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5486 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5487 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5488 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5489 s1=(1+x(63))/(0.1d0 + dscp1)
5490 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5491 s2=(1+x(65))/(0.1d0 + dscp2)
5492 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5493 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5494 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5495 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5497 c & dscp1,dscp2,sumene
5498 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5499 escloc = escloc + sumene
5500 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5504 C This section to check the numerical derivatives of the energy of ith side
5505 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5506 C #define DEBUG in the code to turn it on.
5508 write (2,*) "sumene =",sumene
5512 write (2,*) xx,yy,zz
5513 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5514 de_dxx_num=(sumenep-sumene)/aincr
5516 write (2,*) "xx+ sumene from enesc=",sumenep
5519 write (2,*) xx,yy,zz
5520 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5521 de_dyy_num=(sumenep-sumene)/aincr
5523 write (2,*) "yy+ sumene from enesc=",sumenep
5526 write (2,*) xx,yy,zz
5527 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5528 de_dzz_num=(sumenep-sumene)/aincr
5530 write (2,*) "zz+ sumene from enesc=",sumenep
5531 costsave=cost2tab(i+1)
5532 sintsave=sint2tab(i+1)
5533 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5534 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5535 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5536 de_dt_num=(sumenep-sumene)/aincr
5537 write (2,*) " t+ sumene from enesc=",sumenep
5538 cost2tab(i+1)=costsave
5539 sint2tab(i+1)=sintsave
5540 C End of diagnostics section.
5543 C Compute the gradient of esc
5545 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5546 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5547 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5548 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5549 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5550 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5551 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5552 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5553 pom1=(sumene3*sint2tab(i+1)+sumene1)
5554 & *(pom_s1/dscp1+pom_s16*dscp1**4)
5555 pom2=(sumene4*cost2tab(i+1)+sumene2)
5556 & *(pom_s2/dscp2+pom_s26*dscp2**4)
5557 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5558 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5559 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5561 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5562 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5563 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5565 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5566 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5567 & +(pom1+pom2)*pom_dx
5569 write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5572 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5573 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5574 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5576 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5577 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5578 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5579 & +x(59)*zz**2 +x(60)*xx*zz
5580 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5581 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5582 & +(pom1-pom2)*pom_dy
5584 write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5587 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5588 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5589 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5590 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
5591 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
5592 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5593 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5594 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
5596 write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5599 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5600 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5601 & +pom1*pom_dt1+pom2*pom_dt2
5603 write(2,*), "de_dt = ", de_dt,de_dt_num
5607 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5608 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5609 cosfac2xx=cosfac2*xx
5610 sinfac2yy=sinfac2*yy
5612 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5614 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5616 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5617 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5618 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5619 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5620 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5621 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5622 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5623 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5624 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5625 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5629 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5630 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5633 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5634 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5635 dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5637 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5638 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5642 dXX_Ctab(k,i)=dXX_Ci(k)
5643 dXX_C1tab(k,i)=dXX_Ci1(k)
5644 dYY_Ctab(k,i)=dYY_Ci(k)
5645 dYY_C1tab(k,i)=dYY_Ci1(k)
5646 dZZ_Ctab(k,i)=dZZ_Ci(k)
5647 dZZ_C1tab(k,i)=dZZ_Ci1(k)
5648 dXX_XYZtab(k,i)=dXX_XYZ(k)
5649 dYY_XYZtab(k,i)=dYY_XYZ(k)
5650 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5654 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5655 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5656 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5657 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
5658 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5660 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5661 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5662 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5663 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5664 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5665 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5666 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
5667 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5669 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5670 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5672 C to check gradient call subroutine check_grad
5678 c------------------------------------------------------------------------------
5679 double precision function enesc(x,xx,yy,zz,cost2,sint2)
5681 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5682 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5683 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
5684 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
5686 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5687 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5689 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5690 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5691 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5692 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5693 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5695 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5696 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5697 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5698 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5699 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5701 dsc_i = 0.743d0+x(61)
5703 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5704 & *(xx*cost2+yy*sint2))
5705 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5706 & *(xx*cost2-yy*sint2))
5707 s1=(1+x(63))/(0.1d0 + dscp1)
5708 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5709 s2=(1+x(65))/(0.1d0 + dscp2)
5710 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5711 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5712 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5717 c------------------------------------------------------------------------------
5718 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5720 C This procedure calculates two-body contact function g(rij) and its derivative:
5723 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
5726 C where x=(rij-r0ij)/delta
5728 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5731 double precision rij,r0ij,eps0ij,fcont,fprimcont
5732 double precision x,x2,x4,delta
5736 if (x.lt.-1.0D0) then
5739 else if (x.le.1.0D0) then
5742 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5743 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5750 c------------------------------------------------------------------------------
5751 subroutine splinthet(theti,delta,ss,ssder)
5752 implicit real*8 (a-h,o-z)
5753 include 'DIMENSIONS'
5754 include 'COMMON.VAR'
5755 include 'COMMON.GEO'
5758 if (theti.gt.pipol) then
5759 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5761 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5766 c------------------------------------------------------------------------------
5767 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5769 double precision x,x0,delta,f0,f1,fprim0,f,fprim
5770 double precision ksi,ksi2,ksi3,a1,a2,a3
5771 a1=fprim0*delta/(f1-f0)
5777 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5778 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5781 c------------------------------------------------------------------------------
5782 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5784 double precision x,x0,delta,f0x,f1x,fprim0x,fx
5785 double precision ksi,ksi2,ksi3,a1,a2,a3
5790 a2=3*(f1x-f0x)-2*fprim0x*delta
5791 a3=fprim0x*delta-2*(f1x-f0x)
5792 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5795 C-----------------------------------------------------------------------------
5797 C-----------------------------------------------------------------------------
5798 subroutine etor(etors,edihcnstr)
5799 implicit real*8 (a-h,o-z)
5800 include 'DIMENSIONS'
5801 include 'COMMON.VAR'
5802 include 'COMMON.GEO'
5803 include 'COMMON.LOCAL'
5804 include 'COMMON.TORSION'
5805 include 'COMMON.INTERACT'
5806 include 'COMMON.DERIV'
5807 include 'COMMON.CHAIN'
5808 include 'COMMON.NAMES'
5809 include 'COMMON.IOUNITS'
5810 include 'COMMON.FFIELD'
5811 include 'COMMON.TORCNSTR'
5812 include 'COMMON.CONTROL'
5814 C Set lprn=.true. for debugging
5818 do i=iphi_start,iphi_end
5820 itori=itortyp(itype(i-2))
5821 itori1=itortyp(itype(i-1))
5824 C Proline-Proline pair is a special case...
5825 if (itori.eq.3 .and. itori1.eq.3) then
5826 if (phii.gt.-dwapi3) then
5828 fac=1.0D0/(1.0D0-cosphi)
5829 etorsi=v1(1,3,3)*fac
5830 etorsi=etorsi+etorsi
5831 etors=etors+etorsi-v1(1,3,3)
5832 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5833 gloci=gloci-3*fac*etorsi*dsin(3*phii)
5836 v1ij=v1(j+1,itori,itori1)
5837 v2ij=v2(j+1,itori,itori1)
5840 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5841 if (energy_dec) etors_ii=etors_ii+
5842 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5843 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5847 v1ij=v1(j,itori,itori1)
5848 v2ij=v2(j,itori,itori1)
5851 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5852 if (energy_dec) etors_ii=etors_ii+
5853 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5854 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5857 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5860 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5861 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5862 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5863 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5864 write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5866 ! 6/20/98 - dihedral angle constraints
5869 itori=idih_constr(i)
5872 if (difi.gt.drange(i)) then
5874 edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5875 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5876 else if (difi.lt.-drange(i)) then
5878 edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5879 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5881 ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5882 ! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5884 ! write (iout,*) 'edihcnstr',edihcnstr
5887 c------------------------------------------------------------------------------
5888 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5889 subroutine e_modeller(ehomology_constr)
5890 ehomology_constr=0.0d0
5891 write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5894 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5896 c------------------------------------------------------------------------------
5897 subroutine etor_d(etors_d)
5901 c----------------------------------------------------------------------------
5903 subroutine etor(etors,edihcnstr)
5904 implicit real*8 (a-h,o-z)
5905 include 'DIMENSIONS'
5906 include 'COMMON.VAR'
5907 include 'COMMON.GEO'
5908 include 'COMMON.LOCAL'
5909 include 'COMMON.TORSION'
5910 include 'COMMON.INTERACT'
5911 include 'COMMON.DERIV'
5912 include 'COMMON.CHAIN'
5913 include 'COMMON.NAMES'
5914 include 'COMMON.IOUNITS'
5915 include 'COMMON.FFIELD'
5916 include 'COMMON.TORCNSTR'
5917 include 'COMMON.CONTROL'
5919 C Set lprn=.true. for debugging
5923 do i=iphi_start,iphi_end
5925 itori=itortyp(itype(i-2))
5926 itori1=itortyp(itype(i-1))
5929 C Regular cosine and sine terms
5930 do j=1,nterm(itori,itori1)
5931 v1ij=v1(j,itori,itori1)
5932 v2ij=v2(j,itori,itori1)
5935 etors=etors+v1ij*cosphi+v2ij*sinphi
5936 if (energy_dec) etors_ii=etors_ii+
5937 & v1ij*cosphi+v2ij*sinphi
5938 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5942 C E = SUM ----------------------------------- - v1
5943 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5945 cosphi=dcos(0.5d0*phii)
5946 sinphi=dsin(0.5d0*phii)
5947 do j=1,nlor(itori,itori1)
5948 vl1ij=vlor1(j,itori,itori1)
5949 vl2ij=vlor2(j,itori,itori1)
5950 vl3ij=vlor3(j,itori,itori1)
5951 pom=vl2ij*cosphi+vl3ij*sinphi
5952 pom1=1.0d0/(pom*pom+1.0d0)
5953 etors=etors+vl1ij*pom1
5954 if (energy_dec) etors_ii=etors_ii+
5957 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5959 C Subtract the constant term
5960 etors=etors-v0(itori,itori1)
5961 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5962 & 'etor',i,etors_ii-v0(itori,itori1)
5964 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5965 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5966 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5967 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5968 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5970 ! 6/20/98 - dihedral angle constraints
5972 c do i=1,ndih_constr
5973 do i=idihconstr_start,idihconstr_end
5974 itori=idih_constr(i)
5976 difi=pinorm(phii-phi0(i))
5977 if (difi.gt.drange(i)) then
5979 edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5980 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5981 else if (difi.lt.-drange(i)) then
5983 edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5984 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5988 c write (iout,*) "gloci", gloc(i-3,icg)
5989 cd write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5990 cd & rad2deg*phi0(i), rad2deg*drange(i),
5991 cd & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5993 cd write (iout,*) 'edihcnstr',edihcnstr
5996 c----------------------------------------------------------------------------
5997 c MODELLER restraint function
5998 subroutine e_modeller(ehomology_constr)
5999 implicit real*8 (a-h,o-z)
6000 include 'DIMENSIONS'
6002 integer nnn, i, j, k, ki, irec, l
6003 integer katy, odleglosci, test7
6004 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
6006 real*8 distance(max_template),distancek(max_template),
6007 & min_odl,godl(max_template),dih_diff(max_template)
6010 c FP - 30/10/2014 Temporary specifications for homology restraints
6012 double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6014 double precision, dimension (maxres) :: guscdiff,usc_diff
6015 double precision, dimension (max_template) ::
6016 & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6020 include 'COMMON.SBRIDGE'
6021 include 'COMMON.CHAIN'
6022 include 'COMMON.GEO'
6023 include 'COMMON.DERIV'
6024 include 'COMMON.LOCAL'
6025 include 'COMMON.INTERACT'
6026 include 'COMMON.VAR'
6027 include 'COMMON.IOUNITS'
6029 include 'COMMON.CONTROL'
6031 c From subroutine Econstr_back
6033 include 'COMMON.NAMES'
6034 include 'COMMON.TIME1'
6039 distancek(i)=9999999.9
6045 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6047 C AL 5/2/14 - Introduce list of restraints
6048 c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6050 write(iout,*) "------- dist restrs start -------"
6052 do ii = link_start_homo,link_end_homo
6056 c write (iout,*) "dij(",i,j,") =",dij
6058 do k=1,constr_homology
6059 c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
6060 if(.not.l_homo(k,ii)) then
6064 distance(k)=odl(k,ii)-dij
6065 c write (iout,*) "distance(",k,") =",distance(k)
6067 c For Gaussian-type Urestr
6069 distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6070 c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6071 c write (iout,*) "distancek(",k,") =",distancek(k)
6072 c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6074 c For Lorentzian-type Urestr
6076 if (waga_dist.lt.0.0d0) then
6077 sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6078 distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6079 & (distance(k)**2+sigma_odlir(k,ii)**2))
6082 c write (iout,*) "distance: ii",ii," nexl",nexl
6085 c min_odl=minval(distancek)
6086 do kk=1,constr_homology
6087 if(l_homo(kk,ii)) then
6088 min_odl=distancek(kk)
6092 do kk=1,constr_homology
6093 if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
6094 & min_odl=distancek(kk)
6096 c write (iout,* )"min_odl",min_odl
6098 write (iout,*) "ij dij",i,j,dij
6099 write (iout,*) "distance",(distance(k),k=1,constr_homology)
6100 write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6101 write (iout,* )"min_odl",min_odl
6106 if (waga_dist.ge.0.0d0) then
6112 do k=1,constr_homology
6113 c Nie wiem po co to liczycie jeszcze raz!
6114 c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6115 c & (2*(sigma_odl(i,j,k))**2))
6116 if(.not.l_homo(k,ii)) cycle
6117 if (waga_dist.ge.0.0d0) then
6119 c For Gaussian-type Urestr
6121 godl(k)=dexp(-distancek(k)+min_odl)
6122 odleg2=odleg2+godl(k)
6124 c For Lorentzian-type Urestr
6127 odleg2=odleg2+distancek(k)
6130 ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6131 ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6132 ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6133 ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6136 c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6137 c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6139 write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6140 write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6142 if (waga_dist.ge.0.0d0) then
6144 c For Gaussian-type Urestr
6146 odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6148 c For Lorentzian-type Urestr
6151 odleg=odleg+odleg2/constr_homology
6154 c write (iout,*) "odleg",odleg ! sum of -ln-s
6157 c For Gaussian-type Urestr
6159 if (waga_dist.ge.0.0d0) sum_godl=odleg2
6161 do k=1,constr_homology
6162 c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6163 c & *waga_dist)+min_odl
6164 c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6166 if(.not.l_homo(k,ii)) cycle
6167 if (waga_dist.ge.0.0d0) then
6168 c For Gaussian-type Urestr
6170 sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6172 c For Lorentzian-type Urestr
6175 sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
6176 & sigma_odlir(k,ii)**2)**2)
6178 sum_sgodl=sum_sgodl+sgodl
6180 c sgodl2=sgodl2+sgodl
6181 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6182 c write(iout,*) "constr_homology=",constr_homology
6183 c write(iout,*) i, j, k, "TEST K"
6185 if (waga_dist.ge.0.0d0) then
6187 c For Gaussian-type Urestr
6189 grad_odl3=waga_homology(iset)*waga_dist
6190 & *sum_sgodl/(sum_godl*dij)
6192 c For Lorentzian-type Urestr
6195 c Original grad expr modified by analogy w Gaussian-type Urestr grad
6196 c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
6197 grad_odl3=-waga_homology(iset)*waga_dist*
6198 & sum_sgodl/(constr_homology*dij)
6201 c grad_odl3=sum_sgodl/(sum_godl*dij)
6204 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6205 c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6206 c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6208 ccc write(iout,*) godl, sgodl, grad_odl3
6210 c grad_odl=grad_odl+grad_odl3
6213 ggodl=grad_odl3*(c(jik,i)-c(jik,j))
6214 ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6215 ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6216 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
6217 ghpbc(jik,i)=ghpbc(jik,i)+ggodl
6218 ghpbc(jik,j)=ghpbc(jik,j)-ggodl
6219 ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6220 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
6221 c if (i.eq.25.and.j.eq.27) then
6222 c write(iout,*) "jik",jik,"i",i,"j",j
6223 c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
6224 c write(iout,*) "grad_odl3",grad_odl3
6225 c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
6226 c write(iout,*) "ggodl",ggodl
6227 c write(iout,*) "ghpbc(",jik,i,")",
6228 c & ghpbc(jik,i),"ghpbc(",jik,j,")",
6232 ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
6233 ccc & dLOG(odleg2),"-odleg=", -odleg
6235 enddo ! ii-loop for dist
6237 write(iout,*) "------- dist restrs end -------"
6238 c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
6239 c & waga_d.eq.1.0d0) call sum_gradient
6241 c Pseudo-energy and gradient from dihedral-angle restraints from
6242 c homology templates
6243 c write (iout,*) "End of distance loop"
6246 c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6248 write(iout,*) "------- dih restrs start -------"
6249 do i=idihconstr_start_homo,idihconstr_end_homo
6250 write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
6253 do i=idihconstr_start_homo,idihconstr_end_homo
6254 c betai=beta(i,i+1,i+2,i+3)
6256 c write (iout,*) "betai =",betai
6258 do k=1,constr_homology
6259 dih_diff(k)=pinorm(dih(k,i)-betai)
6260 c write (iout,*) "dih_diff(",k,") =",dih_diff(k)
6261 c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6262 c & -(6.28318-dih_diff(i,k))
6263 c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6264 c & 6.28318+dih_diff(i,k)
6266 kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
6268 kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
6270 c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
6273 c write(iout,*) "i",i," k",k," sigma",sigma_dih(k,i),
6274 c & " kat2=", kat2, "gdih=",gdih(k)
6276 c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
6277 c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
6279 write (iout,*) "i",i," betai",betai," kat2",kat2
6280 write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6282 if (kat2.le.1.0d-14) cycle
6283 kat=kat-dLOG(kat2/constr_homology)
6284 c write (iout,*) "kat",kat ! sum of -ln-s
6286 ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6287 ccc & dLOG(kat2), "-kat=", -kat
6289 c ----------------------------------------------------------------------
6291 c ----------------------------------------------------------------------
6295 do k=1,constr_homology
6297 sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
6299 sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd
6301 c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
6302 sum_sgdih=sum_sgdih+sgdih
6304 c grad_dih3=sum_sgdih/sum_gdih
6305 grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
6307 c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6308 ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6309 ccc & gloc(nphi+i-3,icg)
6310 gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
6312 c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
6314 ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6315 ccc & gloc(nphi+i-3,icg)
6317 enddo ! i-loop for dih
6319 write(iout,*) "------- dih restrs end -------"
6322 c Pseudo-energy and gradient for theta angle restraints from
6323 c homology templates
6324 c FP 01/15 - inserted from econstr_local_test.F, loop structure
6328 c For constr_homology reference structures (FP)
6330 c Uconst_back_tot=0.0d0
6333 c Econstr_back legacy
6335 c do i=ithet_start,ithet_end
6338 c do i=loc_start,loc_end
6341 duscdiffx(j,i)=0.0d0
6346 c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
6347 c write (iout,*) "waga_theta",waga_theta
6348 if (waga_theta.gt.0.0d0) then
6350 write (iout,*) "usampl",usampl
6351 write(iout,*) "------- theta restrs start -------"
6352 c do i=ithet_start,ithet_end
6353 c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
6356 c write (iout,*) "maxres",maxres,"nres",nres
6358 do i=ithet_start,ithet_end
6361 c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
6363 c Deviation of theta angles wrt constr_homology ref structures
6365 utheta_i=0.0d0 ! argument of Gaussian for single k
6366 gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6367 c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
6368 c over residues in a fragment
6369 c write (iout,*) "theta(",i,")=",theta(i)
6370 do k=1,constr_homology
6372 c dtheta_i=theta(j)-thetaref(j,iref)
6373 c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
6374 theta_diff(k)=thetatpl(k,i)-theta(i)
6376 utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
6377 c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
6378 gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
6379 gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk)
6380 c write (iout,*) "i",i," k",k," sigma_theta",sigma_theta(k,i),
6381 c & " gtheta",gtheta(k)
6382 c Gradient for single Gaussian restraint in subr Econstr_back
6383 c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
6386 c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
6387 c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
6390 c Gradient for multiple Gaussian restraint
6391 sum_gtheta=gutheta_i
6393 do k=1,constr_homology
6394 c New generalized expr for multiple Gaussian from Econstr_back
6395 sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
6397 c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
6398 sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
6400 c Final value of gradient using same var as in Econstr_back
6401 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
6402 & +sum_sgtheta/sum_gtheta*waga_theta
6403 & *waga_homology(iset)
6404 c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
6405 c & *waga_homology(iset)
6406 c dutheta(i)=sum_sgtheta/sum_gtheta
6408 c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
6409 Eval=Eval-dLOG(gutheta_i/constr_homology)
6410 c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
6411 c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
6412 c Uconst_back=Uconst_back+utheta(i)
6413 enddo ! (i-loop for theta)
6415 write(iout,*) "------- theta restrs end -------"
6419 c Deviation of local SC geometry
6421 c Separation of two i-loops (instructed by AL - 11/3/2014)
6423 c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
6424 c write (iout,*) "waga_d",waga_d
6427 write(iout,*) "------- SC restrs start -------"
6428 write (iout,*) "Initial duscdiff,duscdiffx"
6429 do i=loc_start,loc_end
6430 write (iout,*) i,(duscdiff(jik,i),jik=1,3),
6431 & (duscdiffx(jik,i),jik=1,3)
6434 do i=loc_start,loc_end
6435 usc_diff_i=0.0d0 ! argument of Gaussian for single k
6436 guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6437 c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
6438 c write(iout,*) "xxtab, yytab, zztab"
6439 c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
6440 do k=1,constr_homology
6442 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6443 c Original sign inverted for calc of gradients (s. Econstr_back)
6444 dyy=-yytpl(k,i)+yytab(i) ! ibid y
6445 dzz=-zztpl(k,i)+zztab(i) ! ibid z
6446 c write(iout,*) "dxx, dyy, dzz"
6447 c write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6449 usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
6450 c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
6451 c uscdiffk(k)=usc_diff(i)
6452 guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
6453 c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
6454 c & " guscdiff2",guscdiff2(k)
6455 guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk)
6456 c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
6457 c & xxref(j),yyref(j),zzref(j)
6462 c Generalized expression for multiple Gaussian acc to that for a single
6463 c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
6465 c Original implementation
6466 c sum_guscdiff=guscdiff(i)
6468 c sum_sguscdiff=0.0d0
6469 c do k=1,constr_homology
6470 c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
6471 c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
6472 c sum_sguscdiff=sum_sguscdiff+sguscdiff
6475 c Implementation of new expressions for gradient (Jan. 2015)
6477 c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
6478 do k=1,constr_homology
6480 c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
6481 c before. Now the drivatives should be correct
6483 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6484 c Original sign inverted for calc of gradients (s. Econstr_back)
6485 dyy=-yytpl(k,i)+yytab(i) ! ibid y
6486 dzz=-zztpl(k,i)+zztab(i) ! ibid z
6488 c New implementation
6490 sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
6491 & sigma_d(k,i) ! for the grad wrt r'
6492 c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
6495 c New implementation
6496 sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
6498 duscdiff(jik,i-1)=duscdiff(jik,i-1)+
6499 & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
6500 & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
6501 duscdiff(jik,i)=duscdiff(jik,i)+
6502 & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
6503 & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
6504 duscdiffx(jik,i)=duscdiffx(jik,i)+
6505 & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
6506 & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
6509 write(iout,*) "jik",jik,"i",i
6510 write(iout,*) "dxx, dyy, dzz"
6511 write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6512 write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
6513 c write(iout,*) "sum_sguscdiff",sum_sguscdiff
6514 cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
6515 c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
6516 c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
6517 c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
6518 c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
6519 c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
6520 c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
6521 c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
6522 c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
6523 c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
6524 c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
6525 c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
6531 c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
6532 c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
6534 c write (iout,*) i," uscdiff",uscdiff(i)
6536 c Put together deviations from local geometry
6538 c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
6539 c & wfrag_back(3,i,iset)*uscdiff(i)
6540 Erot=Erot-dLOG(guscdiff(i)/constr_homology)
6541 c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
6542 c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
6543 c Uconst_back=Uconst_back+usc_diff(i)
6545 c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
6547 c New implment: multiplied by sum_sguscdiff
6550 enddo ! (i-loop for dscdiff)
6555 write(iout,*) "------- SC restrs end -------"
6556 write (iout,*) "------ After SC loop in e_modeller ------"
6557 do i=loc_start,loc_end
6558 write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
6559 write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
6561 if (waga_theta.eq.1.0d0) then
6562 write (iout,*) "in e_modeller after SC restr end: dutheta"
6563 do i=ithet_start,ithet_end
6564 write (iout,*) i,dutheta(i)
6567 if (waga_d.eq.1.0d0) then
6568 write (iout,*) "e_modeller after SC loop: duscdiff/x"
6570 write (iout,*) i,(duscdiff(j,i),j=1,3)
6571 write (iout,*) i,(duscdiffx(j,i),j=1,3)
6576 c Total energy from homology restraints
6578 write (iout,*) "odleg",odleg," kat",kat
6581 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
6583 c ehomology_constr=odleg+kat
6585 c For Lorentzian-type Urestr
6588 if (waga_dist.ge.0.0d0) then
6590 c For Gaussian-type Urestr
6592 ehomology_constr=(waga_dist*odleg+waga_angle*kat+
6593 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6594 c write (iout,*) "ehomology_constr=",ehomology_constr
6597 c For Lorentzian-type Urestr
6599 ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
6600 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6601 c write (iout,*) "ehomology_constr=",ehomology_constr
6604 write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
6605 & "Eval",waga_theta,eval,
6606 & "Erot",waga_d,Erot
6607 write (iout,*) "ehomology_constr",ehomology_constr
6613 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6614 747 format(a12,i4,i4,i4,f8.3,f8.3)
6615 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6616 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6617 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6618 & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6621 c------------------------------------------------------------------------------
6622 subroutine etor_d(etors_d)
6623 C 6/23/01 Compute double torsional energy
6624 implicit real*8 (a-h,o-z)
6625 include 'DIMENSIONS'
6626 include 'COMMON.VAR'
6627 include 'COMMON.GEO'
6628 include 'COMMON.LOCAL'
6629 include 'COMMON.TORSION'
6630 include 'COMMON.INTERACT'
6631 include 'COMMON.DERIV'
6632 include 'COMMON.CHAIN'
6633 include 'COMMON.NAMES'
6634 include 'COMMON.IOUNITS'
6635 include 'COMMON.FFIELD'
6636 include 'COMMON.TORCNSTR'
6637 include 'COMMON.CONTROL'
6639 C Set lprn=.true. for debugging
6643 do i=iphid_start,iphid_end
6645 itori=itortyp(itype(i-2))
6646 itori1=itortyp(itype(i-1))
6647 itori2=itortyp(itype(i))
6652 do j=1,ntermd_1(itori,itori1,itori2)
6653 v1cij=v1c(1,j,itori,itori1,itori2)
6654 v1sij=v1s(1,j,itori,itori1,itori2)
6655 v2cij=v1c(2,j,itori,itori1,itori2)
6656 v2sij=v1s(2,j,itori,itori1,itori2)
6657 cosphi1=dcos(j*phii)
6658 sinphi1=dsin(j*phii)
6659 cosphi2=dcos(j*phii1)
6660 sinphi2=dsin(j*phii1)
6661 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6662 & v2cij*cosphi2+v2sij*sinphi2
6663 if (energy_dec) etors_d_ii=etors_d_ii+
6664 & v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6665 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6666 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6668 do k=2,ntermd_2(itori,itori1,itori2)
6670 v1cdij = v2c(k,l,itori,itori1,itori2)
6671 v2cdij = v2c(l,k,itori,itori1,itori2)
6672 v1sdij = v2s(k,l,itori,itori1,itori2)
6673 v2sdij = v2s(l,k,itori,itori1,itori2)
6674 cosphi1p2=dcos(l*phii+(k-l)*phii1)
6675 cosphi1m2=dcos(l*phii-(k-l)*phii1)
6676 sinphi1p2=dsin(l*phii+(k-l)*phii1)
6677 sinphi1m2=dsin(l*phii-(k-l)*phii1)
6678 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6679 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
6680 if (energy_dec) etors_d_ii=etors_d_ii+
6681 & v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6682 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
6683 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6684 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6685 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6686 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6689 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6690 & 'etor_d',i,etors_d_ii
6691 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6692 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6693 c write (iout,*) "gloci", gloc(i-3,icg)
6698 c------------------------------------------------------------------------------
6699 subroutine eback_sc_corr(esccor)
6700 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6701 c conformational states; temporarily implemented as differences
6702 c between UNRES torsional potentials (dependent on three types of
6703 c residues) and the torsional potentials dependent on all 20 types
6704 c of residues computed from AM1 energy surfaces of terminally-blocked
6705 c amino-acid residues.
6706 implicit real*8 (a-h,o-z)
6707 include 'DIMENSIONS'
6708 include 'COMMON.VAR'
6709 include 'COMMON.GEO'
6710 include 'COMMON.LOCAL'
6711 include 'COMMON.TORSION'
6712 include 'COMMON.SCCOR'
6713 include 'COMMON.INTERACT'
6714 include 'COMMON.DERIV'
6715 include 'COMMON.CHAIN'
6716 include 'COMMON.NAMES'
6717 include 'COMMON.IOUNITS'
6718 include 'COMMON.FFIELD'
6719 include 'COMMON.CONTROL'
6721 C Set lprn=.true. for debugging
6724 c write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6726 do i=itau_start,itau_end
6727 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6728 isccori=isccortyp(itype(i-2))
6729 isccori1=isccortyp(itype(i-1))
6731 cccc Added 9 May 2012
6732 cc Tauangle is torsional engle depending on the value of first digit
6733 c(see comment below)
6734 cc Omicron is flat angle depending on the value of first digit
6735 c(see comment below)
6738 do intertyp=1,3 !intertyp
6740 cc Added 09 May 2012 (Adasko)
6741 cc Intertyp means interaction type of backbone mainchain correlation:
6742 c 1 = SC...Ca...Ca...Ca
6743 c 2 = Ca...Ca...Ca...SC
6744 c 3 = SC...Ca...Ca...SCi
6746 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6747 & (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6748 & (itype(i-1).eq.21)))
6749 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6750 & .or.(itype(i-2).eq.21)))
6751 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6752 & (itype(i-1).eq.21)))) cycle
6753 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6754 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6756 do j=1,nterm_sccor(isccori,isccori1)
6757 v1ij=v1sccor(j,intertyp,isccori,isccori1)
6758 v2ij=v2sccor(j,intertyp,isccori,isccori1)
6759 cosphi=dcos(j*tauangle(intertyp,i))
6760 sinphi=dsin(j*tauangle(intertyp,i))
6761 if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6762 esccor=esccor+v1ij*cosphi+v2ij*sinphi
6763 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6765 if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
6766 & 'esccor',i,intertyp,esccor_ii
6767 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6768 c write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6769 c &gloc_sc(intertyp,i-3,icg)
6771 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6772 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6773 & (v1sccor(j,intertyp,itori,itori1),j=1,6)
6774 & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6775 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6779 c write (iout,*) "W@T@F", gloc_sc(1,i,icg),gloc(i,icg)
6783 c----------------------------------------------------------------------------
6784 subroutine multibody(ecorr)
6785 C This subroutine calculates multi-body contributions to energy following
6786 C the idea of Skolnick et al. If side chains I and J make a contact and
6787 C at the same time side chains I+1 and J+1 make a contact, an extra
6788 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6789 implicit real*8 (a-h,o-z)
6790 include 'DIMENSIONS'
6791 include 'COMMON.IOUNITS'
6792 include 'COMMON.DERIV'
6793 include 'COMMON.INTERACT'
6794 include 'COMMON.CONTACTS'
6795 double precision gx(3),gx1(3)
6798 C Set lprn=.true. for debugging
6802 write (iout,'(a)') 'Contact function values:'
6804 write (iout,'(i2,20(1x,i2,f10.5))')
6805 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6820 num_conti=num_cont(i)
6821 num_conti1=num_cont(i1)
6826 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6827 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6828 cd & ' ishift=',ishift
6829 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6830 C The system gains extra energy.
6831 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6832 endif ! j1==j+-ishift
6841 c------------------------------------------------------------------------------
6842 double precision function esccorr(i,j,k,l,jj,kk)
6843 implicit real*8 (a-h,o-z)
6844 include 'DIMENSIONS'
6845 include 'COMMON.IOUNITS'
6846 include 'COMMON.DERIV'
6847 include 'COMMON.INTERACT'
6848 include 'COMMON.CONTACTS'
6849 double precision gx(3),gx1(3)
6854 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6855 C Calculate the multi-body contribution to energy.
6856 C Calculate multi-body contributions to the gradient.
6857 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6858 cd & k,l,(gacont(m,kk,k),m=1,3)
6860 gx(m) =ekl*gacont(m,jj,i)
6861 gx1(m)=eij*gacont(m,kk,k)
6862 gradxorr(m,i)=gradxorr(m,i)-gx(m)
6863 gradxorr(m,j)=gradxorr(m,j)+gx(m)
6864 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6865 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6869 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6874 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6880 c------------------------------------------------------------------------------
6881 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6882 C This subroutine calculates multi-body contributions to hydrogen-bonding
6883 implicit real*8 (a-h,o-z)
6884 include 'DIMENSIONS'
6885 include 'COMMON.IOUNITS'
6888 parameter (max_cont=maxconts)
6889 parameter (max_dim=26)
6890 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6891 double precision zapas(max_dim,maxconts,max_fg_procs),
6892 & zapas_recv(max_dim,maxconts,max_fg_procs)
6893 common /przechowalnia/ zapas
6894 integer status(MPI_STATUS_SIZE),req(maxconts*2),
6895 & status_array(MPI_STATUS_SIZE,maxconts*2)
6897 include 'COMMON.SETUP'
6898 include 'COMMON.FFIELD'
6899 include 'COMMON.DERIV'
6900 include 'COMMON.INTERACT'
6901 include 'COMMON.CONTACTS'
6902 include 'COMMON.CONTROL'
6903 include 'COMMON.LOCAL'
6904 double precision gx(3),gx1(3),time00
6907 C Set lprn=.true. for debugging
6912 if (nfgtasks.le.1) goto 30
6914 write (iout,'(a)') 'Contact function values before RECEIVE:'
6916 write (iout,'(2i3,50(1x,i2,f5.2))')
6917 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6918 & j=1,num_cont_hb(i))
6922 do i=1,ntask_cont_from
6925 do i=1,ntask_cont_to
6928 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6930 C Make the list of contacts to send to send to other procesors
6931 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6933 do i=iturn3_start,iturn3_end
6934 c write (iout,*) "make contact list turn3",i," num_cont",
6936 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6938 do i=iturn4_start,iturn4_end
6939 c write (iout,*) "make contact list turn4",i," num_cont",
6941 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6945 c write (iout,*) "make contact list longrange",i,ii," num_cont",
6947 do j=1,num_cont_hb(i)
6950 iproc=iint_sent_local(k,jjc,ii)
6951 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6952 if (iproc.gt.0) then
6953 ncont_sent(iproc)=ncont_sent(iproc)+1
6954 nn=ncont_sent(iproc)
6956 zapas(2,nn,iproc)=jjc
6957 zapas(3,nn,iproc)=facont_hb(j,i)
6958 zapas(4,nn,iproc)=ees0p(j,i)
6959 zapas(5,nn,iproc)=ees0m(j,i)
6960 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6961 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6962 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6963 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6964 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6965 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6966 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6967 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6968 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6969 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6970 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6971 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6972 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6973 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6974 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6975 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6976 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6977 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6978 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6979 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6980 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6987 & "Numbers of contacts to be sent to other processors",
6988 & (ncont_sent(i),i=1,ntask_cont_to)
6989 write (iout,*) "Contacts sent"
6990 do ii=1,ntask_cont_to
6992 iproc=itask_cont_to(ii)
6993 write (iout,*) nn," contacts to processor",iproc,
6994 & " of CONT_TO_COMM group"
6996 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7004 CorrelID1=nfgtasks+fg_rank+1
7006 C Receive the numbers of needed contacts from other processors
7007 do ii=1,ntask_cont_from
7008 iproc=itask_cont_from(ii)
7010 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7011 & FG_COMM,req(ireq),IERR)
7013 c write (iout,*) "IRECV ended"
7015 C Send the number of contacts needed by other processors
7016 do ii=1,ntask_cont_to
7017 iproc=itask_cont_to(ii)
7019 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7020 & FG_COMM,req(ireq),IERR)
7022 c write (iout,*) "ISEND ended"
7023 c write (iout,*) "number of requests (nn)",ireq
7026 & call MPI_Waitall(ireq,req,status_array,ierr)
7028 c & "Numbers of contacts to be received from other processors",
7029 c & (ncont_recv(i),i=1,ntask_cont_from)
7033 do ii=1,ntask_cont_from
7034 iproc=itask_cont_from(ii)
7036 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
7037 c & " of CONT_TO_COMM group"
7041 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7042 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7043 c write (iout,*) "ireq,req",ireq,req(ireq)
7046 C Send the contacts to processors that need them
7047 do ii=1,ntask_cont_to
7048 iproc=itask_cont_to(ii)
7050 c write (iout,*) nn," contacts to processor",iproc,
7051 c & " of CONT_TO_COMM group"
7054 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7055 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7056 c write (iout,*) "ireq,req",ireq,req(ireq)
7058 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7062 c write (iout,*) "number of requests (contacts)",ireq
7063 c write (iout,*) "req",(req(i),i=1,4)
7066 & call MPI_Waitall(ireq,req,status_array,ierr)
7067 do iii=1,ntask_cont_from
7068 iproc=itask_cont_from(iii)
7071 write (iout,*) "Received",nn," contacts from processor",iproc,
7072 & " of CONT_FROM_COMM group"
7075 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7080 ii=zapas_recv(1,i,iii)
7081 c Flag the received contacts to prevent double-counting
7082 jj=-zapas_recv(2,i,iii)
7083 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7085 nnn=num_cont_hb(ii)+1
7088 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7089 ees0p(nnn,ii)=zapas_recv(4,i,iii)
7090 ees0m(nnn,ii)=zapas_recv(5,i,iii)
7091 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7092 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7093 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7094 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7095 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7096 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7097 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7098 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7099 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7100 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7101 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7102 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7103 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7104 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7105 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7106 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7107 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7108 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7109 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7110 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7111 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7116 write (iout,'(a)') 'Contact function values after receive:'
7118 write (iout,'(2i3,50(1x,i3,f5.2))')
7119 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7120 & j=1,num_cont_hb(i))
7127 write (iout,'(a)') 'Contact function values:'
7129 write (iout,'(2i3,50(1x,i3,f5.2))')
7130 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7131 & j=1,num_cont_hb(i))
7135 C Remove the loop below after debugging !!!
7142 C Calculate the local-electrostatic correlation terms
7143 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7145 num_conti=num_cont_hb(i)
7146 num_conti1=num_cont_hb(i+1)
7153 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7154 c & ' jj=',jj,' kk=',kk
7155 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7156 & .or. j.lt.0 .and. j1.gt.0) .and.
7157 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7158 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7159 C The system gains extra energy.
7160 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7161 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7162 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7164 else if (j1.eq.j) then
7165 C Contacts I-J and I-(J+1) occur simultaneously.
7166 C The system loses extra energy.
7167 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7172 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7173 c & ' jj=',jj,' kk=',kk
7175 C Contacts I-J and (I+1)-J occur simultaneously.
7176 C The system loses extra energy.
7177 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7184 c------------------------------------------------------------------------------
7185 subroutine add_hb_contact(ii,jj,itask)
7186 implicit real*8 (a-h,o-z)
7187 include "DIMENSIONS"
7188 include "COMMON.IOUNITS"
7191 parameter (max_cont=maxconts)
7192 parameter (max_dim=26)
7193 include "COMMON.CONTACTS"
7194 double precision zapas(max_dim,maxconts,max_fg_procs),
7195 & zapas_recv(max_dim,maxconts,max_fg_procs)
7196 common /przechowalnia/ zapas
7197 integer i,j,ii,jj,iproc,itask(4),nn
7198 c write (iout,*) "itask",itask
7201 if (iproc.gt.0) then
7202 do j=1,num_cont_hb(ii)
7204 c write (iout,*) "i",ii," j",jj," jjc",jjc
7206 ncont_sent(iproc)=ncont_sent(iproc)+1
7207 nn=ncont_sent(iproc)
7208 zapas(1,nn,iproc)=ii
7209 zapas(2,nn,iproc)=jjc
7210 zapas(3,nn,iproc)=facont_hb(j,ii)
7211 zapas(4,nn,iproc)=ees0p(j,ii)
7212 zapas(5,nn,iproc)=ees0m(j,ii)
7213 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7214 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7215 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7216 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7217 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7218 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7219 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7220 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7221 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7222 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7223 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7224 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7225 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7226 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7227 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7228 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7229 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7230 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7231 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7232 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7233 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7241 c------------------------------------------------------------------------------
7242 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7244 C This subroutine calculates multi-body contributions to hydrogen-bonding
7245 implicit real*8 (a-h,o-z)
7246 include 'DIMENSIONS'
7247 include 'COMMON.IOUNITS'
7250 parameter (max_cont=maxconts)
7251 parameter (max_dim=70)
7252 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7253 double precision zapas(max_dim,maxconts,max_fg_procs),
7254 & zapas_recv(max_dim,maxconts,max_fg_procs)
7255 common /przechowalnia/ zapas
7256 integer status(MPI_STATUS_SIZE),req(maxconts*2),
7257 & status_array(MPI_STATUS_SIZE,maxconts*2)
7259 include 'COMMON.SETUP'
7260 include 'COMMON.FFIELD'
7261 include 'COMMON.DERIV'
7262 include 'COMMON.LOCAL'
7263 include 'COMMON.INTERACT'
7264 include 'COMMON.CONTACTS'
7265 include 'COMMON.CHAIN'
7266 include 'COMMON.CONTROL'
7267 double precision gx(3),gx1(3)
7268 integer num_cont_hb_old(maxres)
7270 double precision eello4,eello5,eelo6,eello_turn6
7271 external eello4,eello5,eello6,eello_turn6
7272 C Set lprn=.true. for debugging
7277 num_cont_hb_old(i)=num_cont_hb(i)
7281 if (nfgtasks.le.1) goto 30
7283 write (iout,'(a)') 'Contact function values before RECEIVE:'
7285 write (iout,'(2i3,50(1x,i2,f5.2))')
7286 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7287 & j=1,num_cont_hb(i))
7291 do i=1,ntask_cont_from
7294 do i=1,ntask_cont_to
7297 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7299 C Make the list of contacts to send to send to other procesors
7300 do i=iturn3_start,iturn3_end
7301 c write (iout,*) "make contact list turn3",i," num_cont",
7303 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7305 do i=iturn4_start,iturn4_end
7306 c write (iout,*) "make contact list turn4",i," num_cont",
7308 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7312 c write (iout,*) "make contact list longrange",i,ii," num_cont",
7314 do j=1,num_cont_hb(i)
7317 iproc=iint_sent_local(k,jjc,ii)
7318 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7319 if (iproc.ne.0) then
7320 ncont_sent(iproc)=ncont_sent(iproc)+1
7321 nn=ncont_sent(iproc)
7323 zapas(2,nn,iproc)=jjc
7324 zapas(3,nn,iproc)=d_cont(j,i)
7328 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7333 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7341 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7352 & "Numbers of contacts to be sent to other processors",
7353 & (ncont_sent(i),i=1,ntask_cont_to)
7354 write (iout,*) "Contacts sent"
7355 do ii=1,ntask_cont_to
7357 iproc=itask_cont_to(ii)
7358 write (iout,*) nn," contacts to processor",iproc,
7359 & " of CONT_TO_COMM group"
7361 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7369 CorrelID1=nfgtasks+fg_rank+1
7371 C Receive the numbers of needed contacts from other processors
7372 do ii=1,ntask_cont_from
7373 iproc=itask_cont_from(ii)
7375 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7376 & FG_COMM,req(ireq),IERR)
7378 c write (iout,*) "IRECV ended"
7380 C Send the number of contacts needed by other processors
7381 do ii=1,ntask_cont_to
7382 iproc=itask_cont_to(ii)
7384 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7385 & FG_COMM,req(ireq),IERR)
7387 c write (iout,*) "ISEND ended"
7388 c write (iout,*) "number of requests (nn)",ireq
7391 & call MPI_Waitall(ireq,req,status_array,ierr)
7393 c & "Numbers of contacts to be received from other processors",
7394 c & (ncont_recv(i),i=1,ntask_cont_from)
7398 do ii=1,ntask_cont_from
7399 iproc=itask_cont_from(ii)
7401 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
7402 c & " of CONT_TO_COMM group"
7406 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7407 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7408 c write (iout,*) "ireq,req",ireq,req(ireq)
7411 C Send the contacts to processors that need them
7412 do ii=1,ntask_cont_to
7413 iproc=itask_cont_to(ii)
7415 c write (iout,*) nn," contacts to processor",iproc,
7416 c & " of CONT_TO_COMM group"
7419 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7420 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7421 c write (iout,*) "ireq,req",ireq,req(ireq)
7423 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7427 c write (iout,*) "number of requests (contacts)",ireq
7428 c write (iout,*) "req",(req(i),i=1,4)
7431 & call MPI_Waitall(ireq,req,status_array,ierr)
7432 do iii=1,ntask_cont_from
7433 iproc=itask_cont_from(iii)
7436 write (iout,*) "Received",nn," contacts from processor",iproc,
7437 & " of CONT_FROM_COMM group"
7440 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7445 ii=zapas_recv(1,i,iii)
7446 c Flag the received contacts to prevent double-counting
7447 jj=-zapas_recv(2,i,iii)
7448 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7450 nnn=num_cont_hb(ii)+1
7453 d_cont(nnn,ii)=zapas_recv(3,i,iii)
7457 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7462 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7470 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7479 write (iout,'(a)') 'Contact function values after receive:'
7481 write (iout,'(2i3,50(1x,i3,5f6.3))')
7482 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7483 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7490 write (iout,'(a)') 'Contact function values:'
7492 write (iout,'(2i3,50(1x,i2,5f6.3))')
7493 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7494 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7500 C Remove the loop below after debugging !!!
7507 C Calculate the dipole-dipole interaction energies
7508 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7509 do i=iatel_s,iatel_e+1
7510 num_conti=num_cont_hb(i)
7519 C Calculate the local-electrostatic correlation terms
7520 c write (iout,*) "gradcorr5 in eello5 before loop"
7522 c write (iout,'(i5,3f10.5)')
7523 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
7525 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7526 c write (iout,*) "corr loop i",i
7528 num_conti=num_cont_hb(i)
7529 num_conti1=num_cont_hb(i+1)
7536 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7537 c & ' jj=',jj,' kk=',kk
7538 c if (j1.eq.j+1 .or. j1.eq.j-1) then
7539 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7540 & .or. j.lt.0 .and. j1.gt.0) .and.
7541 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7542 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7543 C The system gains extra energy.
7545 sqd1=dsqrt(d_cont(jj,i))
7546 sqd2=dsqrt(d_cont(kk,i1))
7547 sred_geom = sqd1*sqd2
7548 IF (sred_geom.lt.cutoff_corr) THEN
7549 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7551 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7552 cd & ' jj=',jj,' kk=',kk
7553 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7554 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7556 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7557 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7560 cd write (iout,*) 'sred_geom=',sred_geom,
7561 cd & ' ekont=',ekont,' fprim=',fprimcont,
7562 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7563 cd write (iout,*) "g_contij",g_contij
7564 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7565 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7566 call calc_eello(i,jp,i+1,jp1,jj,kk)
7567 if (wcorr4.gt.0.0d0)
7568 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7569 if (energy_dec.and.wcorr4.gt.0.0d0)
7570 1 write (iout,'(a6,4i5,0pf7.3)')
7571 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7572 c write (iout,*) "gradcorr5 before eello5"
7574 c write (iout,'(i5,3f10.5)')
7575 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
7577 if (wcorr5.gt.0.0d0)
7578 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7579 c write (iout,*) "gradcorr5 after eello5"
7581 c write (iout,'(i5,3f10.5)')
7582 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
7584 if (energy_dec.and.wcorr5.gt.0.0d0)
7585 1 write (iout,'(a6,4i5,0pf7.3)')
7586 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7587 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7588 cd write(2,*)'ijkl',i,jp,i+1,jp1
7589 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7590 & .or. wturn6.eq.0.0d0))then
7591 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7592 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7593 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7594 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7595 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7596 cd & 'ecorr6=',ecorr6
7597 cd write (iout,'(4e15.5)') sred_geom,
7598 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7599 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7600 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
7601 else if (wturn6.gt.0.0d0
7602 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7603 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7604 eturn6=eturn6+eello_turn6(i,jj,kk)
7605 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7606 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7607 cd write (2,*) 'multibody_eello:eturn6',eturn6
7616 num_cont_hb(i)=num_cont_hb_old(i)
7618 c write (iout,*) "gradcorr5 in eello5"
7620 c write (iout,'(i5,3f10.5)')
7621 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
7625 c------------------------------------------------------------------------------
7626 subroutine add_hb_contact_eello(ii,jj,itask)
7627 implicit real*8 (a-h,o-z)
7628 include "DIMENSIONS"
7629 include "COMMON.IOUNITS"
7632 parameter (max_cont=maxconts)
7633 parameter (max_dim=70)
7634 include "COMMON.CONTACTS"
7635 double precision zapas(max_dim,maxconts,max_fg_procs),
7636 & zapas_recv(max_dim,maxconts,max_fg_procs)
7637 common /przechowalnia/ zapas
7638 integer i,j,ii,jj,iproc,itask(4),nn
7639 c write (iout,*) "itask",itask
7642 if (iproc.gt.0) then
7643 do j=1,num_cont_hb(ii)
7645 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7647 ncont_sent(iproc)=ncont_sent(iproc)+1
7648 nn=ncont_sent(iproc)
7649 zapas(1,nn,iproc)=ii
7650 zapas(2,nn,iproc)=jjc
7651 zapas(3,nn,iproc)=d_cont(j,ii)
7655 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7660 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7668 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7680 c------------------------------------------------------------------------------
7681 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7682 implicit real*8 (a-h,o-z)
7683 include 'DIMENSIONS'
7684 include 'COMMON.IOUNITS'
7685 include 'COMMON.DERIV'
7686 include 'COMMON.INTERACT'
7687 include 'COMMON.CONTACTS'
7688 double precision gx(3),gx1(3)
7698 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7699 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7700 C Following 4 lines for diagnostics.
7705 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7706 c & 'Contacts ',i,j,
7707 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7708 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7710 C Calculate the multi-body contribution to energy.
7711 c ecorr=ecorr+ekont*ees
7712 C Calculate multi-body contributions to the gradient.
7713 coeffpees0pij=coeffp*ees0pij
7714 coeffmees0mij=coeffm*ees0mij
7715 coeffpees0pkl=coeffp*ees0pkl
7716 coeffmees0mkl=coeffm*ees0mkl
7718 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7719 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7720 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7721 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
7722 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7723 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7724 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
7725 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7726 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7727 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7728 & coeffmees0mij*gacontm_hb1(ll,kk,k))
7729 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7730 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7731 & coeffmees0mij*gacontm_hb2(ll,kk,k))
7732 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7733 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7734 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
7735 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7736 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7737 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7738 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7739 & coeffmees0mij*gacontm_hb3(ll,kk,k))
7740 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7741 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7742 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7747 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
7748 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
7749 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7750 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7755 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
7756 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
7757 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7758 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7761 c write (iout,*) "ehbcorr",ekont*ees
7766 C---------------------------------------------------------------------------
7767 subroutine dipole(i,j,jj)
7768 implicit real*8 (a-h,o-z)
7769 include 'DIMENSIONS'
7770 include 'COMMON.IOUNITS'
7771 include 'COMMON.CHAIN'
7772 include 'COMMON.FFIELD'
7773 include 'COMMON.DERIV'
7774 include 'COMMON.INTERACT'
7775 include 'COMMON.CONTACTS'
7776 include 'COMMON.TORSION'
7777 include 'COMMON.VAR'
7778 include 'COMMON.GEO'
7779 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7781 iti1 = itortyp(itype(i+1))
7782 if (j.lt.nres-1) then
7783 itj1 = itortyp(itype(j+1))
7788 dipi(iii,1)=Ub2(iii,i)
7789 dipderi(iii)=Ub2der(iii,i)
7790 dipi(iii,2)=b1(iii,iti1)
7791 dipj(iii,1)=Ub2(iii,j)
7792 dipderj(iii)=Ub2der(iii,j)
7793 dipj(iii,2)=b1(iii,itj1)
7797 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7800 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7807 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7811 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7816 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7817 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7819 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7821 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7823 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7828 C---------------------------------------------------------------------------
7829 subroutine calc_eello(i,j,k,l,jj,kk)
7831 C This subroutine computes matrices and vectors needed to calculate
7832 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7834 implicit real*8 (a-h,o-z)
7835 include 'DIMENSIONS'
7836 include 'COMMON.IOUNITS'
7837 include 'COMMON.CHAIN'
7838 include 'COMMON.DERIV'
7839 include 'COMMON.INTERACT'
7840 include 'COMMON.CONTACTS'
7841 include 'COMMON.TORSION'
7842 include 'COMMON.VAR'
7843 include 'COMMON.GEO'
7844 include 'COMMON.FFIELD'
7845 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7846 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7849 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7850 cd & ' jj=',jj,' kk=',kk
7851 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7852 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7853 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7856 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7857 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7860 call transpose2(aa1(1,1),aa1t(1,1))
7861 call transpose2(aa2(1,1),aa2t(1,1))
7864 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7865 & aa1tder(1,1,lll,kkk))
7866 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7867 & aa2tder(1,1,lll,kkk))
7871 C parallel orientation of the two CA-CA-CA frames.
7873 iti=itortyp(itype(i))
7877 itk1=itortyp(itype(k+1))
7878 itj=itortyp(itype(j))
7879 if (l.lt.nres-1) then
7880 itl1=itortyp(itype(l+1))
7884 C A1 kernel(j+1) A2T
7886 cd write (iout,'(3f10.5,5x,3f10.5)')
7887 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7889 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7890 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7891 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7892 C Following matrices are needed only for 6-th order cumulants
7893 IF (wcorr6.gt.0.0d0) THEN
7894 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7895 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7896 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7897 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7898 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7899 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7900 & ADtEAderx(1,1,1,1,1,1))
7902 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7903 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7904 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7905 & ADtEA1derx(1,1,1,1,1,1))
7907 C End 6-th order cumulants
7910 cd write (2,*) 'In calc_eello6'
7912 cd write (2,*) 'iii=',iii
7914 cd write (2,*) 'kkk=',kkk
7916 cd write (2,'(3(2f10.5),5x)')
7917 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7922 call transpose2(EUgder(1,1,k),auxmat(1,1))
7923 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7924 call transpose2(EUg(1,1,k),auxmat(1,1))
7925 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7926 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7930 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7931 & EAEAderx(1,1,lll,kkk,iii,1))
7935 C A1T kernel(i+1) A2
7936 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7937 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7938 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7939 C Following matrices are needed only for 6-th order cumulants
7940 IF (wcorr6.gt.0.0d0) THEN
7941 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7942 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7943 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7944 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7945 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7946 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7947 & ADtEAderx(1,1,1,1,1,2))
7948 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7949 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7950 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7951 & ADtEA1derx(1,1,1,1,1,2))
7953 C End 6-th order cumulants
7954 call transpose2(EUgder(1,1,l),auxmat(1,1))
7955 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7956 call transpose2(EUg(1,1,l),auxmat(1,1))
7957 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7958 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7962 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7963 & EAEAderx(1,1,lll,kkk,iii,2))
7968 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7969 C They are needed only when the fifth- or the sixth-order cumulants are
7971 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7972 call transpose2(AEA(1,1,1),auxmat(1,1))
7973 call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7974 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7975 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7976 call transpose2(AEAderg(1,1,1),auxmat(1,1))
7977 call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7978 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7979 call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7980 call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7981 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7982 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7983 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7984 call transpose2(AEA(1,1,2),auxmat(1,1))
7985 call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7986 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7987 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7988 call transpose2(AEAderg(1,1,2),auxmat(1,1))
7989 call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7990 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7991 call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7992 call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7993 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7994 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7995 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7996 C Calculate the Cartesian derivatives of the vectors.
8000 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8001 call matvec2(auxmat(1,1),b1(1,iti),
8002 & AEAb1derx(1,lll,kkk,iii,1,1))
8003 call matvec2(auxmat(1,1),Ub2(1,i),
8004 & AEAb2derx(1,lll,kkk,iii,1,1))
8005 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8006 & AEAb1derx(1,lll,kkk,iii,2,1))
8007 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8008 & AEAb2derx(1,lll,kkk,iii,2,1))
8009 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8010 call matvec2(auxmat(1,1),b1(1,itj),
8011 & AEAb1derx(1,lll,kkk,iii,1,2))
8012 call matvec2(auxmat(1,1),Ub2(1,j),
8013 & AEAb2derx(1,lll,kkk,iii,1,2))
8014 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8015 & AEAb1derx(1,lll,kkk,iii,2,2))
8016 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8017 & AEAb2derx(1,lll,kkk,iii,2,2))
8024 C Antiparallel orientation of the two CA-CA-CA frames.
8026 iti=itortyp(itype(i))
8030 itk1=itortyp(itype(k+1))
8031 itl=itortyp(itype(l))
8032 itj=itortyp(itype(j))
8033 if (j.lt.nres-1) then
8034 itj1=itortyp(itype(j+1))
8038 C A2 kernel(j-1)T A1T
8039 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8040 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8041 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8042 C Following matrices are needed only for 6-th order cumulants
8043 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8044 & j.eq.i+4 .and. l.eq.i+3)) THEN
8045 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8046 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8047 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8048 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8049 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8050 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8051 & ADtEAderx(1,1,1,1,1,1))
8052 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8053 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8054 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8055 & ADtEA1derx(1,1,1,1,1,1))
8057 C End 6-th order cumulants
8058 call transpose2(EUgder(1,1,k),auxmat(1,1))
8059 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8060 call transpose2(EUg(1,1,k),auxmat(1,1))
8061 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8062 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8066 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8067 & EAEAderx(1,1,lll,kkk,iii,1))
8071 C A2T kernel(i+1)T A1
8072 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8073 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8074 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8075 C Following matrices are needed only for 6-th order cumulants
8076 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8077 & j.eq.i+4 .and. l.eq.i+3)) THEN
8078 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8079 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8080 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8081 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8082 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8083 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8084 & ADtEAderx(1,1,1,1,1,2))
8085 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8086 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8087 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8088 & ADtEA1derx(1,1,1,1,1,2))
8090 C End 6-th order cumulants
8091 call transpose2(EUgder(1,1,j),auxmat(1,1))
8092 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8093 call transpose2(EUg(1,1,j),auxmat(1,1))
8094 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8095 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8099 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8100 & EAEAderx(1,1,lll,kkk,iii,2))
8105 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8106 C They are needed only when the fifth- or the sixth-order cumulants are
8108 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8109 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8110 call transpose2(AEA(1,1,1),auxmat(1,1))
8111 call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8112 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8113 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8114 call transpose2(AEAderg(1,1,1),auxmat(1,1))
8115 call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8116 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8117 call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8118 call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8119 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8120 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8121 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8122 call transpose2(AEA(1,1,2),auxmat(1,1))
8123 call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8124 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8125 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8126 call transpose2(AEAderg(1,1,2),auxmat(1,1))
8127 call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8128 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8129 call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8130 call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8131 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8132 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8133 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8134 C Calculate the Cartesian derivatives of the vectors.
8138 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8139 call matvec2(auxmat(1,1),b1(1,iti),
8140 & AEAb1derx(1,lll,kkk,iii,1,1))
8141 call matvec2(auxmat(1,1),Ub2(1,i),
8142 & AEAb2derx(1,lll,kkk,iii,1,1))
8143 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8144 & AEAb1derx(1,lll,kkk,iii,2,1))
8145 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8146 & AEAb2derx(1,lll,kkk,iii,2,1))
8147 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8148 call matvec2(auxmat(1,1),b1(1,itl),
8149 & AEAb1derx(1,lll,kkk,iii,1,2))
8150 call matvec2(auxmat(1,1),Ub2(1,l),
8151 & AEAb2derx(1,lll,kkk,iii,1,2))
8152 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
8153 & AEAb1derx(1,lll,kkk,iii,2,2))
8154 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8155 & AEAb2derx(1,lll,kkk,iii,2,2))
8164 C---------------------------------------------------------------------------
8165 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8166 & KK,KKderg,AKA,AKAderg,AKAderx)
8170 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8171 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8172 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8177 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8179 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8182 cd if (lprn) write (2,*) 'In kernel'
8184 cd if (lprn) write (2,*) 'kkk=',kkk
8186 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8187 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8189 cd write (2,*) 'lll=',lll
8190 cd write (2,*) 'iii=1'
8192 cd write (2,'(3(2f10.5),5x)')
8193 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8196 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8197 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8199 cd write (2,*) 'lll=',lll
8200 cd write (2,*) 'iii=2'
8202 cd write (2,'(3(2f10.5),5x)')
8203 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8210 C---------------------------------------------------------------------------
8211 double precision function eello4(i,j,k,l,jj,kk)
8212 implicit real*8 (a-h,o-z)
8213 include 'DIMENSIONS'
8214 include 'COMMON.IOUNITS'
8215 include 'COMMON.CHAIN'
8216 include 'COMMON.DERIV'
8217 include 'COMMON.INTERACT'
8218 include 'COMMON.CONTACTS'
8219 include 'COMMON.TORSION'
8220 include 'COMMON.VAR'
8221 include 'COMMON.GEO'
8222 double precision pizda(2,2),ggg1(3),ggg2(3)
8223 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8227 cd print *,'eello4:',i,j,k,l,jj,kk
8228 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
8229 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
8230 cold eij=facont_hb(jj,i)
8231 cold ekl=facont_hb(kk,k)
8233 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8234 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8235 gcorr_loc(k-1)=gcorr_loc(k-1)
8236 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8238 gcorr_loc(l-1)=gcorr_loc(l-1)
8239 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8241 gcorr_loc(j-1)=gcorr_loc(j-1)
8242 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8247 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8248 & -EAEAderx(2,2,lll,kkk,iii,1)
8249 cd derx(lll,kkk,iii)=0.0d0
8253 cd gcorr_loc(l-1)=0.0d0
8254 cd gcorr_loc(j-1)=0.0d0
8255 cd gcorr_loc(k-1)=0.0d0
8257 cd write (iout,*)'Contacts have occurred for peptide groups',
8258 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
8259 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8260 if (j.lt.nres-1) then
8267 if (l.lt.nres-1) then
8275 cgrad ggg1(ll)=eel4*g_contij(ll,1)
8276 cgrad ggg2(ll)=eel4*g_contij(ll,2)
8277 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8278 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8279 cgrad ghalf=0.5d0*ggg1(ll)
8280 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8281 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8282 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8283 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8284 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8285 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8286 cgrad ghalf=0.5d0*ggg2(ll)
8287 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8288 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8289 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8290 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8291 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8292 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8296 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8301 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8306 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8311 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8315 cd write (2,*) iii,gcorr_loc(iii)
8318 cd write (2,*) 'ekont',ekont
8319 cd write (iout,*) 'eello4',ekont*eel4
8322 C---------------------------------------------------------------------------
8323 double precision function eello5(i,j,k,l,jj,kk)
8324 implicit real*8 (a-h,o-z)
8325 include 'DIMENSIONS'
8326 include 'COMMON.IOUNITS'
8327 include 'COMMON.CHAIN'
8328 include 'COMMON.DERIV'
8329 include 'COMMON.INTERACT'
8330 include 'COMMON.CONTACTS'
8331 include 'COMMON.TORSION'
8332 include 'COMMON.VAR'
8333 include 'COMMON.GEO'
8334 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8335 double precision ggg1(3),ggg2(3)
8336 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8341 C /l\ / \ \ / \ / \ / C
8342 C / \ / \ \ / \ / \ / C
8343 C j| o |l1 | o | o| o | | o |o C
8344 C \ |/k\| |/ \| / |/ \| |/ \| C
8345 C \i/ \ / \ / / \ / \ C
8347 C (I) (II) (III) (IV) C
8349 C eello5_1 eello5_2 eello5_3 eello5_4 C
8351 C Antiparallel chains C
8354 C /j\ / \ \ / \ / \ / C
8355 C / \ / \ \ / \ / \ / C
8356 C j1| o |l | o | o| o | | o |o C
8357 C \ |/k\| |/ \| / |/ \| |/ \| C
8358 C \i/ \ / \ / / \ / \ C
8360 C (I) (II) (III) (IV) C
8362 C eello5_1 eello5_2 eello5_3 eello5_4 C
8364 C o denotes a local interaction, vertical lines an electrostatic interaction. C
8366 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8367 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8372 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
8374 itk=itortyp(itype(k))
8375 itl=itortyp(itype(l))
8376 itj=itortyp(itype(j))
8381 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8382 cd & eel5_3_num,eel5_4_num)
8386 derx(lll,kkk,iii)=0.0d0
8390 cd eij=facont_hb(jj,i)
8391 cd ekl=facont_hb(kk,k)
8393 cd write (iout,*)'Contacts have occurred for peptide groups',
8394 cd & i,j,' fcont:',eij,' eij',' and ',k,l
8396 C Contribution from the graph I.
8397 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8398 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8399 call transpose2(EUg(1,1,k),auxmat(1,1))
8400 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8401 vv(1)=pizda(1,1)-pizda(2,2)
8402 vv(2)=pizda(1,2)+pizda(2,1)
8403 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8404 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8405 C Explicit gradient in virtual-dihedral angles.
8406 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8407 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8408 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8409 call transpose2(EUgder(1,1,k),auxmat1(1,1))
8410 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8411 vv(1)=pizda(1,1)-pizda(2,2)
8412 vv(2)=pizda(1,2)+pizda(2,1)
8413 g_corr5_loc(k-1)=g_corr5_loc(k-1)
8414 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8415 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8416 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8417 vv(1)=pizda(1,1)-pizda(2,2)
8418 vv(2)=pizda(1,2)+pizda(2,1)
8420 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8421 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8422 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8424 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8425 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8426 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8428 C Cartesian gradient
8432 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8434 vv(1)=pizda(1,1)-pizda(2,2)
8435 vv(2)=pizda(1,2)+pizda(2,1)
8436 derx(lll,kkk,iii)=derx(lll,kkk,iii)
8437 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8438 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8444 C Contribution from graph II
8445 call transpose2(EE(1,1,itk),auxmat(1,1))
8446 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8447 vv(1)=pizda(1,1)+pizda(2,2)
8448 vv(2)=pizda(2,1)-pizda(1,2)
8449 eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8450 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8451 C Explicit gradient in virtual-dihedral angles.
8452 g_corr5_loc(k-1)=g_corr5_loc(k-1)
8453 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8454 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8455 vv(1)=pizda(1,1)+pizda(2,2)
8456 vv(2)=pizda(2,1)-pizda(1,2)
8458 g_corr5_loc(l-1)=g_corr5_loc(l-1)
8459 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8460 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8462 g_corr5_loc(j-1)=g_corr5_loc(j-1)
8463 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8464 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8466 C Cartesian gradient
8470 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8472 vv(1)=pizda(1,1)+pizda(2,2)
8473 vv(2)=pizda(2,1)-pizda(1,2)
8474 derx(lll,kkk,iii)=derx(lll,kkk,iii)
8475 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8476 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8484 C Parallel orientation
8485 C Contribution from graph III
8486 call transpose2(EUg(1,1,l),auxmat(1,1))
8487 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8488 vv(1)=pizda(1,1)-pizda(2,2)
8489 vv(2)=pizda(1,2)+pizda(2,1)
8490 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8491 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8492 C Explicit gradient in virtual-dihedral angles.
8493 g_corr5_loc(j-1)=g_corr5_loc(j-1)
8494 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8495 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8496 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8497 vv(1)=pizda(1,1)-pizda(2,2)
8498 vv(2)=pizda(1,2)+pizda(2,1)
8499 g_corr5_loc(k-1)=g_corr5_loc(k-1)
8500 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8501 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8502 call transpose2(EUgder(1,1,l),auxmat1(1,1))
8503 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8504 vv(1)=pizda(1,1)-pizda(2,2)
8505 vv(2)=pizda(1,2)+pizda(2,1)
8506 g_corr5_loc(l-1)=g_corr5_loc(l-1)
8507 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8508 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8509 C Cartesian gradient
8513 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8515 vv(1)=pizda(1,1)-pizda(2,2)
8516 vv(2)=pizda(1,2)+pizda(2,1)
8517 derx(lll,kkk,iii)=derx(lll,kkk,iii)
8518 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8519 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8524 C Contribution from graph IV
8526 call transpose2(EE(1,1,itl),auxmat(1,1))
8527 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8528 vv(1)=pizda(1,1)+pizda(2,2)
8529 vv(2)=pizda(2,1)-pizda(1,2)
8530 eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8531 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
8532 C Explicit gradient in virtual-dihedral angles.
8533 g_corr5_loc(l-1)=g_corr5_loc(l-1)
8534 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8535 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8536 vv(1)=pizda(1,1)+pizda(2,2)
8537 vv(2)=pizda(2,1)-pizda(1,2)
8538 g_corr5_loc(k-1)=g_corr5_loc(k-1)
8539 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8540 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8541 C Cartesian gradient
8545 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8547 vv(1)=pizda(1,1)+pizda(2,2)
8548 vv(2)=pizda(2,1)-pizda(1,2)
8549 derx(lll,kkk,iii)=derx(lll,kkk,iii)
8550 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8551 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
8556 C Antiparallel orientation
8557 C Contribution from graph III
8559 call transpose2(EUg(1,1,j),auxmat(1,1))
8560 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8561 vv(1)=pizda(1,1)-pizda(2,2)
8562 vv(2)=pizda(1,2)+pizda(2,1)
8563 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8564 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8565 C Explicit gradient in virtual-dihedral angles.
8566 g_corr5_loc(l-1)=g_corr5_loc(l-1)
8567 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8568 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8569 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8570 vv(1)=pizda(1,1)-pizda(2,2)
8571 vv(2)=pizda(1,2)+pizda(2,1)
8572 g_corr5_loc(k-1)=g_corr5_loc(k-1)
8573 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8574 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8575 call transpose2(EUgder(1,1,j),auxmat1(1,1))
8576 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8577 vv(1)=pizda(1,1)-pizda(2,2)
8578 vv(2)=pizda(1,2)+pizda(2,1)
8579 g_corr5_loc(j-1)=g_corr5_loc(j-1)
8580 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8581 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8582 C Cartesian gradient
8586 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8588 vv(1)=pizda(1,1)-pizda(2,2)
8589 vv(2)=pizda(1,2)+pizda(2,1)
8590 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8591 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8592 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8597 C Contribution from graph IV
8599 call transpose2(EE(1,1,itj),auxmat(1,1))
8600 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8601 vv(1)=pizda(1,1)+pizda(2,2)
8602 vv(2)=pizda(2,1)-pizda(1,2)
8603 eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8604 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
8605 C Explicit gradient in virtual-dihedral angles.
8606 g_corr5_loc(j-1)=g_corr5_loc(j-1)
8607 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8608 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8609 vv(1)=pizda(1,1)+pizda(2,2)
8610 vv(2)=pizda(2,1)-pizda(1,2)
8611 g_corr5_loc(k-1)=g_corr5_loc(k-1)
8612 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8613 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8614 C Cartesian gradient
8618 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8620 vv(1)=pizda(1,1)+pizda(2,2)
8621 vv(2)=pizda(2,1)-pizda(1,2)
8622 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8623 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8624 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
8630 eel5=eello5_1+eello5_2+eello5_3+eello5_4
8631 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8632 cd write (2,*) 'ijkl',i,j,k,l
8633 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8634 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
8636 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8637 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8638 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8639 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8640 if (j.lt.nres-1) then
8647 if (l.lt.nres-1) then
8657 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8658 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8659 C summed up outside the subrouine as for the other subroutines
8660 C handling long-range interactions. The old code is commented out
8661 C with "cgrad" to keep track of changes.
8663 cgrad ggg1(ll)=eel5*g_contij(ll,1)
8664 cgrad ggg2(ll)=eel5*g_contij(ll,2)
8665 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8666 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8667 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8668 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8669 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8670 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8671 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8672 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8674 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8675 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8676 cgrad ghalf=0.5d0*ggg1(ll)
8678 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8679 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8680 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8681 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8682 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8683 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8684 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8685 cgrad ghalf=0.5d0*ggg2(ll)
8687 gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8688 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8689 gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8690 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8691 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8692 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8697 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8698 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8703 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8704 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8710 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8715 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8719 cd write (2,*) iii,g_corr5_loc(iii)
8722 cd write (2,*) 'ekont',ekont
8723 cd write (iout,*) 'eello5',ekont*eel5
8726 c--------------------------------------------------------------------------
8727 double precision function eello6(i,j,k,l,jj,kk)
8728 implicit real*8 (a-h,o-z)
8729 include 'DIMENSIONS'
8730 include 'COMMON.IOUNITS'
8731 include 'COMMON.CHAIN'
8732 include 'COMMON.DERIV'
8733 include 'COMMON.INTERACT'
8734 include 'COMMON.CONTACTS'
8735 include 'COMMON.TORSION'
8736 include 'COMMON.VAR'
8737 include 'COMMON.GEO'
8738 include 'COMMON.FFIELD'
8739 double precision ggg1(3),ggg2(3)
8740 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8745 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
8753 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8754 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8758 derx(lll,kkk,iii)=0.0d0
8762 cd eij=facont_hb(jj,i)
8763 cd ekl=facont_hb(kk,k)
8769 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8770 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8771 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8772 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8773 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8774 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8776 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8777 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8778 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8779 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8780 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8781 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8785 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8787 C If turn contributions are considered, they will be handled separately.
8788 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8789 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8790 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8791 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8792 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8793 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8794 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8796 if (j.lt.nres-1) then
8803 if (l.lt.nres-1) then
8811 cgrad ggg1(ll)=eel6*g_contij(ll,1)
8812 cgrad ggg2(ll)=eel6*g_contij(ll,2)
8813 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8814 cgrad ghalf=0.5d0*ggg1(ll)
8816 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8817 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8818 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8819 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8820 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8821 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8822 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8823 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8824 cgrad ghalf=0.5d0*ggg2(ll)
8825 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8827 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8828 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8829 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8830 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8831 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8832 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8837 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8838 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8843 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8844 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8850 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8855 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8859 cd write (2,*) iii,g_corr6_loc(iii)
8862 cd write (2,*) 'ekont',ekont
8863 cd write (iout,*) 'eello6',ekont*eel6
8866 c--------------------------------------------------------------------------
8867 double precision function eello6_graph1(i,j,k,l,imat,swap)
8868 implicit real*8 (a-h,o-z)
8869 include 'DIMENSIONS'
8870 include 'COMMON.IOUNITS'
8871 include 'COMMON.CHAIN'
8872 include 'COMMON.DERIV'
8873 include 'COMMON.INTERACT'
8874 include 'COMMON.CONTACTS'
8875 include 'COMMON.TORSION'
8876 include 'COMMON.VAR'
8877 include 'COMMON.GEO'
8878 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8882 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8884 C Parallel Antiparallel
8890 C \ j|/k\| / \ |/k\|l /
8895 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8896 itk=itortyp(itype(k))
8897 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8898 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8899 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8900 call transpose2(EUgC(1,1,k),auxmat(1,1))
8901 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8902 vv1(1)=pizda1(1,1)-pizda1(2,2)
8903 vv1(2)=pizda1(1,2)+pizda1(2,1)
8904 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8905 vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8906 vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8907 s5=scalar2(vv(1),Dtobr2(1,i))
8908 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8909 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8910 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8911 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8912 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8913 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8914 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8915 & +scalar2(vv(1),Dtobr2der(1,i)))
8916 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8917 vv1(1)=pizda1(1,1)-pizda1(2,2)
8918 vv1(2)=pizda1(1,2)+pizda1(2,1)
8919 vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8920 vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8922 g_corr6_loc(l-1)=g_corr6_loc(l-1)
8923 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8924 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8925 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8926 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8928 g_corr6_loc(j-1)=g_corr6_loc(j-1)
8929 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8930 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8931 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8932 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8934 call transpose2(EUgCder(1,1,k),auxmat(1,1))
8935 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8936 vv1(1)=pizda1(1,1)-pizda1(2,2)
8937 vv1(2)=pizda1(1,2)+pizda1(2,1)
8938 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8939 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8940 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8941 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8950 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8951 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8952 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8953 call transpose2(EUgC(1,1,k),auxmat(1,1))
8954 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8956 vv1(1)=pizda1(1,1)-pizda1(2,2)
8957 vv1(2)=pizda1(1,2)+pizda1(2,1)
8958 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8959 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8960 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8961 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8962 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8963 s5=scalar2(vv(1),Dtobr2(1,i))
8964 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8970 c----------------------------------------------------------------------------
8971 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8972 implicit real*8 (a-h,o-z)
8973 include 'DIMENSIONS'
8974 include 'COMMON.IOUNITS'
8975 include 'COMMON.CHAIN'
8976 include 'COMMON.DERIV'
8977 include 'COMMON.INTERACT'
8978 include 'COMMON.CONTACTS'
8979 include 'COMMON.TORSION'
8980 include 'COMMON.VAR'
8981 include 'COMMON.GEO'
8983 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8984 & auxvec1(2),auxvec2(2),auxmat1(2,2)
8987 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8989 C Parallel Antiparallel C
8995 C \ j|/k\| \ |/k\|l C
9000 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9001 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9002 C AL 7/4/01 s1 would occur in the sixth-order moment,
9003 C but not in a cluster cumulant
9005 s1=dip(1,jj,i)*dip(1,kk,k)
9007 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9008 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9009 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9010 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9011 call transpose2(EUg(1,1,k),auxmat(1,1))
9012 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9013 vv(1)=pizda(1,1)-pizda(2,2)
9014 vv(2)=pizda(1,2)+pizda(2,1)
9015 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9016 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9018 eello6_graph2=-(s1+s2+s3+s4)
9020 eello6_graph2=-(s2+s3+s4)
9023 C Derivatives in gamma(i-1)
9026 s1=dipderg(1,jj,i)*dip(1,kk,k)
9028 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9029 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9030 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9031 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9033 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9035 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9037 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9039 C Derivatives in gamma(k-1)
9041 s1=dip(1,jj,i)*dipderg(1,kk,k)
9043 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9044 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9045 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9046 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9047 call transpose2(EUgder(1,1,k),auxmat1(1,1))
9048 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9049 vv(1)=pizda(1,1)-pizda(2,2)
9050 vv(2)=pizda(1,2)+pizda(2,1)
9051 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9053 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9055 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9057 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9058 C Derivatives in gamma(j-1) or gamma(l-1)
9061 s1=dipderg(3,jj,i)*dip(1,kk,k)
9063 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9064 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9065 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9066 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9067 vv(1)=pizda(1,1)-pizda(2,2)
9068 vv(2)=pizda(1,2)+pizda(2,1)
9069 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9072 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9074 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9077 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9078 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9080 C Derivatives in gamma(l-1) or gamma(j-1)
9083 s1=dip(1,jj,i)*dipderg(3,kk,k)
9085 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9086 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9087 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9088 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9089 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9090 vv(1)=pizda(1,1)-pizda(2,2)
9091 vv(2)=pizda(1,2)+pizda(2,1)
9092 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9095 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9097 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9100 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9101 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9103 C Cartesian derivatives.
9105 write (2,*) 'In eello6_graph2'
9107 write (2,*) 'iii=',iii
9109 write (2,*) 'kkk=',kkk
9111 write (2,'(3(2f10.5),5x)')
9112 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9122 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9124 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9127 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9129 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9130 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9132 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9133 call transpose2(EUg(1,1,k),auxmat(1,1))
9134 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9136 vv(1)=pizda(1,1)-pizda(2,2)
9137 vv(2)=pizda(1,2)+pizda(2,1)
9138 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9139 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9141 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9143 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9146 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9148 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9155 c----------------------------------------------------------------------------
9156 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9157 implicit real*8 (a-h,o-z)
9158 include 'DIMENSIONS'
9159 include 'COMMON.IOUNITS'
9160 include 'COMMON.CHAIN'
9161 include 'COMMON.DERIV'
9162 include 'COMMON.INTERACT'
9163 include 'COMMON.CONTACTS'
9164 include 'COMMON.TORSION'
9165 include 'COMMON.VAR'
9166 include 'COMMON.GEO'
9167 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9169 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9171 C Parallel Antiparallel C
9177 C j|/k\| / |/k\|l / C
9182 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9184 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9185 C energy moment and not to the cluster cumulant.
9186 iti=itortyp(itype(i))
9187 if (j.lt.nres-1) then
9188 itj1=itortyp(itype(j+1))
9192 itk=itortyp(itype(k))
9193 itk1=itortyp(itype(k+1))
9194 if (l.lt.nres-1) then
9195 itl1=itortyp(itype(l+1))
9200 s1=dip(4,jj,i)*dip(4,kk,k)
9202 call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9203 s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9204 call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9205 s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9206 call transpose2(EE(1,1,itk),auxmat(1,1))
9207 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9208 vv(1)=pizda(1,1)+pizda(2,2)
9209 vv(2)=pizda(2,1)-pizda(1,2)
9210 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9211 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9212 cd & "sum",-(s2+s3+s4)
9214 eello6_graph3=-(s1+s2+s3+s4)
9216 eello6_graph3=-(s2+s3+s4)
9219 C Derivatives in gamma(k-1)
9220 call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9221 s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9222 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9223 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9224 C Derivatives in gamma(l-1)
9225 call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9226 s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9227 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9228 vv(1)=pizda(1,1)+pizda(2,2)
9229 vv(2)=pizda(2,1)-pizda(1,2)
9230 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9231 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9232 C Cartesian derivatives.
9238 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9240 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9243 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
9245 s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9246 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
9248 s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9249 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9251 vv(1)=pizda(1,1)+pizda(2,2)
9252 vv(2)=pizda(2,1)-pizda(1,2)
9253 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9255 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9257 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9260 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9262 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9264 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9270 c----------------------------------------------------------------------------
9271 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9272 implicit real*8 (a-h,o-z)
9273 include 'DIMENSIONS'
9274 include 'COMMON.IOUNITS'
9275 include 'COMMON.CHAIN'
9276 include 'COMMON.DERIV'
9277 include 'COMMON.INTERACT'
9278 include 'COMMON.CONTACTS'
9279 include 'COMMON.TORSION'
9280 include 'COMMON.VAR'
9281 include 'COMMON.GEO'
9282 include 'COMMON.FFIELD'
9283 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9284 & auxvec1(2),auxmat1(2,2)
9286 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9288 C Parallel Antiparallel C
9294 C \ j|/k\| \ |/k\|l C
9299 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9301 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9302 C energy moment and not to the cluster cumulant.
9303 cd write (2,*) 'eello_graph4: wturn6',wturn6
9304 iti=itortyp(itype(i))
9305 itj=itortyp(itype(j))
9306 if (j.lt.nres-1) then
9307 itj1=itortyp(itype(j+1))
9311 itk=itortyp(itype(k))
9312 if (k.lt.nres-1) then
9313 itk1=itortyp(itype(k+1))
9317 itl=itortyp(itype(l))
9318 if (l.lt.nres-1) then
9319 itl1=itortyp(itype(l+1))
9323 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9324 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9325 cd & ' itl',itl,' itl1',itl1
9328 s1=dip(3,jj,i)*dip(3,kk,k)
9330 s1=dip(2,jj,j)*dip(2,kk,l)
9333 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9334 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9336 call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9337 s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9339 call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9340 s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9342 call transpose2(EUg(1,1,k),auxmat(1,1))
9343 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9344 vv(1)=pizda(1,1)-pizda(2,2)
9345 vv(2)=pizda(2,1)+pizda(1,2)
9346 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9347 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9349 eello6_graph4=-(s1+s2+s3+s4)
9351 eello6_graph4=-(s2+s3+s4)
9353 C Derivatives in gamma(i-1)
9357 s1=dipderg(2,jj,i)*dip(3,kk,k)
9359 s1=dipderg(4,jj,j)*dip(2,kk,l)
9362 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9364 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9365 s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9367 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9368 s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9370 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9371 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9372 cd write (2,*) 'turn6 derivatives'
9374 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9376 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9380 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9382 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9386 C Derivatives in gamma(k-1)
9389 s1=dip(3,jj,i)*dipderg(2,kk,k)
9391 s1=dip(2,jj,j)*dipderg(4,kk,l)
9394 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9395 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9397 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9398 s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9400 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9401 s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9403 call transpose2(EUgder(1,1,k),auxmat1(1,1))
9404 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9405 vv(1)=pizda(1,1)-pizda(2,2)
9406 vv(2)=pizda(2,1)+pizda(1,2)
9407 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9408 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9410 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9412 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9416 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9418 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9421 C Derivatives in gamma(j-1) or gamma(l-1)
9422 if (l.eq.j+1 .and. l.gt.1) then
9423 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9424 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9425 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9426 vv(1)=pizda(1,1)-pizda(2,2)
9427 vv(2)=pizda(2,1)+pizda(1,2)
9428 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9429 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9430 else if (j.gt.1) then
9431 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9432 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9433 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9434 vv(1)=pizda(1,1)-pizda(2,2)
9435 vv(2)=pizda(2,1)+pizda(1,2)
9436 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9437 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9438 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9440 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9443 C Cartesian derivatives.
9450 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9452 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9456 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9458 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9462 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9464 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9466 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9467 & b1(1,itj1),auxvec(1))
9468 s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9470 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9471 & b1(1,itl1),auxvec(1))
9472 s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9474 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9476 vv(1)=pizda(1,1)-pizda(2,2)
9477 vv(2)=pizda(2,1)+pizda(1,2)
9478 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9480 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9482 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9485 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9488 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9491 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9493 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9495 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9499 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9501 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9504 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9506 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9514 c----------------------------------------------------------------------------
9515 double precision function eello_turn6(i,jj,kk)
9516 implicit real*8 (a-h,o-z)
9517 include 'DIMENSIONS'
9518 include 'COMMON.IOUNITS'
9519 include 'COMMON.CHAIN'
9520 include 'COMMON.DERIV'
9521 include 'COMMON.INTERACT'
9522 include 'COMMON.CONTACTS'
9523 include 'COMMON.TORSION'
9524 include 'COMMON.VAR'
9525 include 'COMMON.GEO'
9526 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9527 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9529 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9530 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9531 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9532 C the respective energy moment and not to the cluster cumulant.
9541 iti=itortyp(itype(i))
9542 itk=itortyp(itype(k))
9543 itk1=itortyp(itype(k+1))
9544 itl=itortyp(itype(l))
9545 itj=itortyp(itype(j))
9546 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9547 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
9548 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9553 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
9555 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
9559 derx_turn(lll,kkk,iii)=0.0d0
9566 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9568 cd write (2,*) 'eello6_5',eello6_5
9570 call transpose2(AEA(1,1,1),auxmat(1,1))
9571 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9572 ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9573 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9575 call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9576 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9577 s2 = scalar2(b1(1,itk),vtemp1(1))
9579 call transpose2(AEA(1,1,2),atemp(1,1))
9580 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9581 call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9582 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9584 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9585 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9586 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9588 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9589 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9590 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9591 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9592 ss13 = scalar2(b1(1,itk),vtemp4(1))
9593 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9595 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9601 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9602 C Derivatives in gamma(i+2)
9606 call transpose2(AEA(1,1,1),auxmatd(1,1))
9607 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9608 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9609 call transpose2(AEAderg(1,1,2),atempd(1,1))
9610 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9611 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9613 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9614 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9615 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9621 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9622 C Derivatives in gamma(i+3)
9624 call transpose2(AEA(1,1,1),auxmatd(1,1))
9625 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9626 ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9627 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9629 call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9630 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9631 s2d = scalar2(b1(1,itk),vtemp1d(1))
9633 call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9634 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9636 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9638 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9639 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9640 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9648 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9649 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9651 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9652 & -0.5d0*ekont*(s2d+s12d)
9654 C Derivatives in gamma(i+4)
9655 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9656 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9657 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9659 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9660 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9661 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9669 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9671 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9673 C Derivatives in gamma(i+5)
9675 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9676 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9677 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9679 call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9680 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9681 s2d = scalar2(b1(1,itk),vtemp1d(1))
9683 call transpose2(AEA(1,1,2),atempd(1,1))
9684 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9685 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9687 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9688 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9690 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9691 ss13d = scalar2(b1(1,itk),vtemp4d(1))
9692 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9700 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9701 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9703 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9704 & -0.5d0*ekont*(s2d+s12d)
9706 C Cartesian derivatives
9711 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9712 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9713 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9715 call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9716 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9718 s2d = scalar2(b1(1,itk),vtemp1d(1))
9720 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9721 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9722 s8d = -(atempd(1,1)+atempd(2,2))*
9723 & scalar2(cc(1,1,itl),vtemp2(1))
9725 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9727 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9728 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9735 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9738 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9742 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9743 & - 0.5d0*(s8d+s12d)
9745 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9754 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9756 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9757 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9758 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9759 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9760 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9762 ss13d = scalar2(b1(1,itk),vtemp4d(1))
9763 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9764 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9768 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9769 cd & 16*eel_turn6_num
9771 if (j.lt.nres-1) then
9778 if (l.lt.nres-1) then
9786 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
9787 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
9788 cgrad ghalf=0.5d0*ggg1(ll)
9790 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9791 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9792 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9793 & +ekont*derx_turn(ll,2,1)
9794 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9795 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9796 & +ekont*derx_turn(ll,4,1)
9797 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9798 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9799 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9800 cgrad ghalf=0.5d0*ggg2(ll)
9802 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9803 & +ekont*derx_turn(ll,2,2)
9804 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9805 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9806 & +ekont*derx_turn(ll,4,2)
9807 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9808 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9809 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9814 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9819 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9825 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9830 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9834 cd write (2,*) iii,g_corr6_loc(iii)
9836 eello_turn6=ekont*eel_turn6
9837 cd write (2,*) 'ekont',ekont
9838 cd write (2,*) 'eel_turn6',ekont*eel_turn6
9842 C-----------------------------------------------------------------------------
9843 double precision function scalar(u,v)
9844 !DIR$ INLINEALWAYS scalar
9846 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9849 double precision u(3),v(3)
9850 cd double precision sc
9858 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9861 crc-------------------------------------------------
9862 SUBROUTINE MATVEC2(A1,V1,V2)
9863 !DIR$ INLINEALWAYS MATVEC2
9865 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9867 implicit real*8 (a-h,o-z)
9868 include 'DIMENSIONS'
9869 DIMENSION A1(2,2),V1(2),V2(2)
9873 c 3 VI=VI+A1(I,K)*V1(K)
9877 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9878 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9883 C---------------------------------------
9884 SUBROUTINE MATMAT2(A1,A2,A3)
9886 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9888 implicit real*8 (a-h,o-z)
9889 include 'DIMENSIONS'
9890 DIMENSION A1(2,2),A2(2,2),A3(2,2)
9891 c DIMENSION AI3(2,2)
9895 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
9901 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9902 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9903 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9904 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9912 c-------------------------------------------------------------------------
9913 double precision function scalar2(u,v)
9914 !DIR$ INLINEALWAYS scalar2
9916 double precision u(2),v(2)
9919 scalar2=u(1)*v(1)+u(2)*v(2)
9923 C-----------------------------------------------------------------------------
9925 subroutine transpose2(a,at)
9926 !DIR$ INLINEALWAYS transpose2
9928 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9931 double precision a(2,2),at(2,2)
9938 c--------------------------------------------------------------------------
9939 subroutine transpose(n,a,at)
9942 double precision a(n,n),at(n,n)
9950 C---------------------------------------------------------------------------
9951 subroutine prodmat3(a1,a2,kk,transp,prod)
9952 !DIR$ INLINEALWAYS prodmat3
9954 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9958 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9960 crc double precision auxmat(2,2),prod_(2,2)
9963 crc call transpose2(kk(1,1),auxmat(1,1))
9964 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9965 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9967 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9968 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9969 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9970 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9971 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9972 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9973 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9974 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9977 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9978 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9980 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9981 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9982 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9983 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9984 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9985 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9986 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9987 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9990 c call transpose2(a2(1,1),a2t(1,1))
9993 crc print *,((prod_(i,j),i=1,2),j=1,2)
9994 crc print *,((prod(i,j),i=1,2),j=1,2)