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 integer status(MPI_STATUS_SIZE)
16 include 'COMMON.SETUP'
17 include 'COMMON.IOUNITS'
18 double precision energia(0:n_ene)
19 include 'COMMON.LOCAL'
20 include 'COMMON.FFIELD'
21 include 'COMMON.DERIV'
22 include 'COMMON.INTERACT'
23 include 'COMMON.SBRIDGE'
24 include 'COMMON.CHAIN'
27 include 'COMMON.CONTROL'
28 include 'COMMON.TIME1'
29 include 'COMMON.SPLITELE'
30 include 'COMMON.SHIELD'
32 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
33 c & " nfgtasks",nfgtasks
34 if (nfgtasks.gt.1) then
36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
37 if (fg_rank.eq.0) then
38 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
39 c print *,"Processor",myrank," BROADCAST iorder"
40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
41 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 print *,'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.)
106 C Compute the side-chain and electrostatic interaction energy
109 goto (101,102,103,104,105,106) ipot
110 C Lennard-Jones potential.
112 cd print '(a)','Exit ELJ'
114 C Lennard-Jones-Kihara potential (shifted).
117 C Berne-Pechukas potential (dilated LJ, angular dependence).
120 C Gay-Berne potential (shifted LJ, angular dependence).
122 C print *,"bylem w egb"
124 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
127 C Soft-sphere potential
128 106 call e_softsphere(evdw)
130 C Calculate electrostatic (H-bonding) energy of the main chain.
134 cmc Sep-06: egb takes care of dynamic ss bonds too
136 c if (dyn_ss) call dyn_set_nss
138 c print *,"Processor",myrank," computed USCSC"
144 time_vec=time_vec+MPI_Wtime()-time01
146 C Introduction of shielding effect first for each peptide group
147 C the shielding factor is set this factor is describing how each
148 C peptide group is shielded by side-chains
149 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
150 C write (iout,*) "shield_mode",shield_mode
151 if (shield_mode.eq.1) then
153 else if (shield_mode.eq.2) then
155 if (nfgtasks.gt.1) then
158 write(iout,*) "befor reduce fac_shield reduce"
160 write(2,*) "fac",itype(i),fac_shield(i),grad_shield(1,i)
161 write(2,*) "list", shield_list(1,i),ishield_list(i),
162 & grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
165 call MPI_Allgatherv(fac_shield(ivec_start),ivec_count(fg_rank1),
166 & MPI_DOUBLE_PRECISION,fac_shield(1),ivec_count(0),ivec_displ(0),
167 & MPI_DOUBLE_PRECISION,FG_COMM,IERR)
168 call MPI_Allgatherv(shield_list(1,ivec_start),
169 & ivec_count(fg_rank1),
170 & MPI_I50,shield_list(1,1),ivec_count(0),
172 & MPI_I50,FG_COMM,IERR)
173 call MPI_Allgatherv(ishield_list(ivec_start),
174 & ivec_count(fg_rank1),
175 & MPI_INTEGER,ishield_list(1),ivec_count(0),
177 & MPI_INTEGER,FG_COMM,IERR)
178 call MPI_Allgatherv(grad_shield(1,ivec_start),
179 & ivec_count(fg_rank1),
180 & MPI_UYZ,grad_shield(1,1),ivec_count(0),
182 & MPI_UYZ,FG_COMM,IERR)
183 call MPI_Allgatherv(grad_shield_side(1,1,ivec_start),
184 & ivec_count(fg_rank1),
185 & MPI_SHI,grad_shield_side(1,1,1),ivec_count(0),
187 & MPI_SHI,FG_COMM,IERR)
188 call MPI_Allgatherv(grad_shield_loc(1,1,ivec_start),
189 & ivec_count(fg_rank1),
190 & MPI_SHI,grad_shield_loc(1,1,1),ivec_count(0),
192 & MPI_SHI,FG_COMM,IERR)
194 write(iout,*) "after reduce fac_shield reduce"
196 write(2,*) "fac",itype(i),fac_shield(i),grad_shield(1,i)
197 write(2,*) "list", shield_list(1,i),ishield_list(i),
198 & grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
205 write(iout,*) fac_shield(i),ishield_list(i),i,grad_shield(1,i)
206 do j=1,ishield_list(i)
207 write(iout,*) "grad", grad_shield_side(1,j,i),
208 & grad_shield_loc(1,j,i)
213 c print *,"Processor",myrank," left VEC_AND_DERIV"
216 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
217 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
218 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
219 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
221 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
222 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
223 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
224 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
226 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
235 write (iout,*) "Soft-spheer ELEC potential"
236 c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
239 c print *,"Processor",myrank," computed UELEC"
241 C Calculate excluded-volume interaction energy between peptide groups
246 call escp(evdw2,evdw2_14)
252 c write (iout,*) "Soft-sphere SCP potential"
253 call escp_soft_sphere(evdw2,evdw2_14)
256 c Calculate the bond-stretching energy
260 C Calculate the disulfide-bridge and other energy and the contributions
261 C from other distance constraints.
262 cd print *,'Calling EHPB'
264 cd print *,'EHPB exitted succesfully.'
266 C Calculate the virtual-bond-angle energy.
268 if (wang.gt.0d0) then
269 if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
270 call ebend(ebe,ethetacnstr)
272 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
274 if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
275 call ebend_kcc(ebe,ethetacnstr)
281 c print *,"Processor",myrank," computed UB"
283 C Calculate the SC local energy.
285 C print *,"TU DOCHODZE?"
287 c print *,"Processor",myrank," computed USC"
289 C Calculate the virtual-bond torsional energy.
291 cd print *,'nterm=',nterm
292 C print *,"tor",tor_mode
294 if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
295 call etor(etors,edihcnstr)
297 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
299 if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
300 call etor_kcc(etors,edihcnstr)
306 c print *,"Processor",myrank," computed Utor"
308 C 6/23/01 Calculate double-torsional energy
310 if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
315 c print *,"Processor",myrank," computed Utord"
317 C 21/5/07 Calculate local sicdechain correlation energy
319 if (wsccor.gt.0.0d0) then
320 call eback_sc_corr(esccor)
324 C print *,"PRZED MULIt"
325 c print *,"Processor",myrank," computed Usccorr"
327 C 12/1/95 Multi-body terms
331 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
332 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
333 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
334 cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
335 cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
342 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
343 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
344 cd write (iout,*) "multibody_hb ecorr",ecorr
346 c print *,"Processor",myrank," computed Ucorr"
348 C If performing constraint dynamics, call the constraint energy
349 C after the equilibration time
350 if(usampl.and.totT.gt.eq_time) then
357 C 01/27/2015 added by adasko
358 C the energy component below is energy transfer into lipid environment
359 C based on partition function
360 C print *,"przed lipidami"
361 if (wliptran.gt.0) then
362 call Eliptransfer(eliptran)
366 C print *,"za lipidami"
367 if (AFMlog.gt.0) then
368 call AFMforce(Eafmforce)
369 else if (selfguide.gt.0) then
370 call AFMvel(Eafmforce)
372 if (TUBElog.eq.1) then
373 C print *,"just before call"
375 elseif (TUBElog.eq.2) then
376 call calctube2(Etube)
382 time_enecalc=time_enecalc+MPI_Wtime()-time00
384 c print *,"Processor",myrank," computed Uconstr"
393 energia(2)=evdw2-evdw2_14
410 energia(8)=eello_turn3
411 energia(9)=eello_turn4
418 energia(19)=edihcnstr
420 energia(20)=Uconst+Uconst_back
423 energia(23)=Eafmforce
424 energia(24)=ethetacnstr
426 c Here are the energies showed per procesor if the are more processors
427 c per molecule then we sum it up in sum_energy subroutine
428 c print *," Processor",myrank," calls SUM_ENERGY"
429 call sum_energy(energia,.true.)
430 if (dyn_ss) call dyn_set_nss
431 c print *," Processor",myrank," left SUM_ENERGY"
433 time_sumene=time_sumene+MPI_Wtime()-time00
437 c-------------------------------------------------------------------------------
438 subroutine sum_energy(energia,reduce)
439 implicit real*8 (a-h,o-z)
444 cMS$ATTRIBUTES C :: proc_proc
450 include 'COMMON.SETUP'
451 include 'COMMON.IOUNITS'
452 double precision energia(0:n_ene),enebuff(0:n_ene+1)
453 include 'COMMON.FFIELD'
454 include 'COMMON.DERIV'
455 include 'COMMON.INTERACT'
456 include 'COMMON.SBRIDGE'
457 include 'COMMON.CHAIN'
459 include 'COMMON.CONTROL'
460 include 'COMMON.TIME1'
463 if (nfgtasks.gt.1 .and. reduce) then
465 write (iout,*) "energies before REDUCE"
466 call enerprint(energia)
470 enebuff(i)=energia(i)
473 call MPI_Barrier(FG_COMM,IERR)
474 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
476 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
477 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
479 write (iout,*) "energies after REDUCE"
480 call enerprint(energia)
483 time_Reduce=time_Reduce+MPI_Wtime()-time00
485 if (fg_rank.eq.0) then
489 evdw2=energia(2)+energia(18)
505 eello_turn3=energia(8)
506 eello_turn4=energia(9)
513 edihcnstr=energia(19)
518 Eafmforce=energia(23)
519 ethetacnstr=energia(24)
522 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
523 & +wang*ebe+wtor*etors+wscloc*escloc
524 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
525 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
526 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
527 & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
528 & +ethetacnstr+wtube*Etube
530 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
531 & +wang*ebe+wtor*etors+wscloc*escloc
532 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
533 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
534 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
535 & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
537 & +ethetacnstr+wtube*Etube
543 if (isnan(etot).ne.0) energia(0)=1.0d+99
545 if (isnan(etot)) energia(0)=1.0d+99
550 idumm=proc_proc(etot,i)
552 call proc_proc(etot,i)
554 if(i.eq.1)energia(0)=1.0d+99
561 c-------------------------------------------------------------------------------
562 subroutine sum_gradient
563 implicit real*8 (a-h,o-z)
568 cMS$ATTRIBUTES C :: proc_proc
574 double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
575 & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
576 & ,gloc_scbuf(3,-1:maxres)
577 include 'COMMON.SETUP'
578 include 'COMMON.IOUNITS'
579 include 'COMMON.FFIELD'
580 include 'COMMON.DERIV'
581 include 'COMMON.INTERACT'
582 include 'COMMON.SBRIDGE'
583 include 'COMMON.CHAIN'
585 include 'COMMON.CONTROL'
586 include 'COMMON.TIME1'
587 include 'COMMON.MAXGRAD'
588 include 'COMMON.SCCOR'
593 write (iout,*) "sum_gradient gvdwc, gvdwx"
595 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
596 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
601 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
602 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
603 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
606 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
607 C in virtual-bond-vector coordinates
610 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
612 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
613 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
615 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
617 c write (iout,'(i5,3f10.5,2x,f10.5)')
618 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
620 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
622 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
623 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
631 gradbufc(j,i)=wsc*gvdwc(j,i)+
632 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
633 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
634 & wel_loc*gel_loc_long(j,i)+
635 & wcorr*gradcorr_long(j,i)+
636 & wcorr5*gradcorr5_long(j,i)+
637 & wcorr6*gradcorr6_long(j,i)+
638 & wturn6*gcorr6_turn_long(j,i)+
640 & +wliptran*gliptranc(j,i)
642 & +welec*gshieldc(j,i)
643 & +wcorr*gshieldc_ec(j,i)
644 & +wturn3*gshieldc_t3(j,i)
645 & +wturn4*gshieldc_t4(j,i)
646 & +wel_loc*gshieldc_ll(j,i)
647 & +wtube*gg_tube(j,i)
656 gradbufc(j,i)=wsc*gvdwc(j,i)+
657 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
658 & welec*gelc_long(j,i)+
660 & wel_loc*gel_loc_long(j,i)+
661 & wcorr*gradcorr_long(j,i)+
662 & wcorr5*gradcorr5_long(j,i)+
663 & wcorr6*gradcorr6_long(j,i)+
664 & wturn6*gcorr6_turn_long(j,i)+
666 & +wliptran*gliptranc(j,i)
668 & +welec*gshieldc(j,i)
669 & +wcorr*gshieldc_ec(j,i)
670 & +wturn4*gshieldc_t4(j,i)
671 & +wel_loc*gshieldc_ll(j,i)
672 & +wtube*gg_tube(j,i)
680 if (nfgtasks.gt.1) then
683 write (iout,*) "gradbufc before allreduce"
685 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
691 gradbufc_sum(j,i)=gradbufc(j,i)
694 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
695 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
696 c time_reduce=time_reduce+MPI_Wtime()-time00
698 c write (iout,*) "gradbufc_sum after allreduce"
700 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
705 c time_allreduce=time_allreduce+MPI_Wtime()-time00
713 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
714 write (iout,*) (i," jgrad_start",jgrad_start(i),
715 & " jgrad_end ",jgrad_end(i),
716 & i=igrad_start,igrad_end)
719 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
720 c do not parallelize this part.
722 c do i=igrad_start,igrad_end
723 c do j=jgrad_start(i),jgrad_end(i)
725 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
730 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
734 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
738 write (iout,*) "gradbufc after summing"
740 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
747 write (iout,*) "gradbufc"
749 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
755 gradbufc_sum(j,i)=gradbufc(j,i)
760 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
764 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
769 c gradbufc(k,i)=0.0d0
773 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
778 write (iout,*) "gradbufc after summing"
780 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
788 gradbufc(k,nres)=0.0d0
793 C print *,gradbufc(1,13)
794 C print *,welec*gelc(1,13)
795 C print *,wel_loc*gel_loc(1,13)
796 C print *,0.5d0*(wscp*gvdwc_scpp(1,13))
797 C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
798 C print *,wel_loc*gel_loc_long(1,13)
799 C print *,gradafm(1,13),"AFM"
800 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
801 & wel_loc*gel_loc(j,i)+
802 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
803 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
804 & wel_loc*gel_loc_long(j,i)+
805 & wcorr*gradcorr_long(j,i)+
806 & wcorr5*gradcorr5_long(j,i)+
807 & wcorr6*gradcorr6_long(j,i)+
808 & wturn6*gcorr6_turn_long(j,i))+
810 & wcorr*gradcorr(j,i)+
811 & wturn3*gcorr3_turn(j,i)+
812 & wturn4*gcorr4_turn(j,i)+
813 & wcorr5*gradcorr5(j,i)+
814 & wcorr6*gradcorr6(j,i)+
815 & wturn6*gcorr6_turn(j,i)+
816 & wsccor*gsccorc(j,i)
817 & +wscloc*gscloc(j,i)
818 & +wliptran*gliptranc(j,i)
820 & +welec*gshieldc(j,i)
821 & +welec*gshieldc_loc(j,i)
822 & +wcorr*gshieldc_ec(j,i)
823 & +wcorr*gshieldc_loc_ec(j,i)
824 & +wturn3*gshieldc_t3(j,i)
825 & +wturn3*gshieldc_loc_t3(j,i)
826 & +wturn4*gshieldc_t4(j,i)
827 & +wturn4*gshieldc_loc_t4(j,i)
828 & +wel_loc*gshieldc_ll(j,i)
829 & +wel_loc*gshieldc_loc_ll(j,i)
830 & +wtube*gg_tube(j,i)
833 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
834 & wel_loc*gel_loc(j,i)+
835 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
836 & welec*gelc_long(j,i)+
837 & wel_loc*gel_loc_long(j,i)+
838 & wcorr*gcorr_long(j,i)+
839 & wcorr5*gradcorr5_long(j,i)+
840 & wcorr6*gradcorr6_long(j,i)+
841 & wturn6*gcorr6_turn_long(j,i))+
843 & wcorr*gradcorr(j,i)+
844 & wturn3*gcorr3_turn(j,i)+
845 & wturn4*gcorr4_turn(j,i)+
846 & wcorr5*gradcorr5(j,i)+
847 & wcorr6*gradcorr6(j,i)+
848 & wturn6*gcorr6_turn(j,i)+
849 & wsccor*gsccorc(j,i)
850 & +wscloc*gscloc(j,i)
851 & +wliptran*gliptranc(j,i)
853 & +welec*gshieldc(j,i)
854 & +welec*gshieldc_loc(j,i)
855 & +wcorr*gshieldc_ec(j,i)
856 & +wcorr*gshieldc_loc_ec(j,i)
857 & +wturn3*gshieldc_t3(j,i)
858 & +wturn3*gshieldc_loc_t3(j,i)
859 & +wturn4*gshieldc_t4(j,i)
860 & +wturn4*gshieldc_loc_t4(j,i)
861 & +wel_loc*gshieldc_ll(j,i)
862 & +wel_loc*gshieldc_loc_ll(j,i)
863 & +wtube*gg_tube(j,i)
867 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
869 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
870 & wsccor*gsccorx(j,i)
871 & +wscloc*gsclocx(j,i)
872 & +wliptran*gliptranx(j,i)
873 & +welec*gshieldx(j,i)
874 & +wcorr*gshieldx_ec(j,i)
875 & +wturn3*gshieldx_t3(j,i)
876 & +wturn4*gshieldx_t4(j,i)
877 & +wel_loc*gshieldx_ll(j,i)
878 & +wtube*gg_tube_sc(j,i)
885 write (iout,*) "gloc before adding corr"
887 write (iout,*) i,gloc(i,icg)
891 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
892 & +wcorr5*g_corr5_loc(i)
893 & +wcorr6*g_corr6_loc(i)
894 & +wturn4*gel_loc_turn4(i)
895 & +wturn3*gel_loc_turn3(i)
896 & +wturn6*gel_loc_turn6(i)
897 & +wel_loc*gel_loc_loc(i)
900 write (iout,*) "gloc after adding corr"
902 write (iout,*) i,gloc(i,icg)
906 if (nfgtasks.gt.1) then
909 gradbufc(j,i)=gradc(j,i,icg)
910 gradbufx(j,i)=gradx(j,i,icg)
914 glocbuf(i)=gloc(i,icg)
918 write (iout,*) "gloc_sc before reduce"
921 write (iout,*) i,j,gloc_sc(j,i,icg)
928 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
932 call MPI_Barrier(FG_COMM,IERR)
933 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
935 call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
936 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
937 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
938 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
939 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
940 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
941 time_reduce=time_reduce+MPI_Wtime()-time00
942 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
943 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
944 time_reduce=time_reduce+MPI_Wtime()-time00
947 write (iout,*) "gloc_sc after reduce"
950 write (iout,*) i,j,gloc_sc(j,i,icg)
956 write (iout,*) "gloc after reduce"
958 write (iout,*) i,gloc(i,icg)
963 if (gnorm_check) then
965 c Compute the maximum elements of the gradient
975 gcorr3_turn_max=0.0d0
976 gcorr4_turn_max=0.0d0
979 gcorr6_turn_max=0.0d0
989 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
990 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
991 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
992 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
993 & gvdwc_scp_max=gvdwc_scp_norm
994 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
995 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
996 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
997 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
998 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
999 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1000 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1001 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1002 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1003 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1004 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1005 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1006 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1007 & gcorr3_turn(1,i)))
1008 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1009 & gcorr3_turn_max=gcorr3_turn_norm
1010 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1011 & gcorr4_turn(1,i)))
1012 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1013 & gcorr4_turn_max=gcorr4_turn_norm
1014 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1015 if (gradcorr5_norm.gt.gradcorr5_max)
1016 & gradcorr5_max=gradcorr5_norm
1017 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1018 if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1019 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1020 & gcorr6_turn(1,i)))
1021 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1022 & gcorr6_turn_max=gcorr6_turn_norm
1023 gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1024 if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1025 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1026 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1027 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1028 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1029 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1030 if (gradx_scp_norm.gt.gradx_scp_max)
1031 & gradx_scp_max=gradx_scp_norm
1032 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1033 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1034 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1035 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1036 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1037 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1038 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1039 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1043 open(istat,file=statname,position="append")
1045 open(istat,file=statname,access="append")
1047 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1048 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1049 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1050 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1051 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1052 & gsccorx_max,gsclocx_max
1054 if (gvdwc_max.gt.1.0d4) then
1055 write (iout,*) "gvdwc gvdwx gradb gradbx"
1057 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1058 & gradb(j,i),gradbx(j,i),j=1,3)
1060 call pdbout(0.0d0,'cipiszcze',iout)
1066 write (iout,*) "gradc gradx gloc"
1068 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1069 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1073 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1077 c-------------------------------------------------------------------------------
1078 subroutine rescale_weights(t_bath)
1079 implicit real*8 (a-h,o-z)
1080 include 'DIMENSIONS'
1081 include 'COMMON.IOUNITS'
1082 include 'COMMON.FFIELD'
1083 include 'COMMON.SBRIDGE'
1084 include 'COMMON.CONTROL'
1085 double precision kfac /2.4d0/
1086 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1088 c facT=2*temp0/(t_bath+temp0)
1089 if (rescale_mode.eq.0) then
1095 else if (rescale_mode.eq.1) then
1096 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1097 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1098 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1099 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1100 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1101 else if (rescale_mode.eq.2) then
1107 facT=licznik/dlog(dexp(x)+dexp(-x))
1108 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1109 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1110 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1111 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1113 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1114 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1116 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1120 if (shield_mode.gt.0) then
1121 wscp=weights(2)*fact
1123 wvdwpp=weights(16)*fact
1125 welec=weights(3)*fact
1126 wcorr=weights(4)*fact3
1127 wcorr5=weights(5)*fact4
1128 wcorr6=weights(6)*fact5
1129 wel_loc=weights(7)*fact2
1130 wturn3=weights(8)*fact2
1131 wturn4=weights(9)*fact3
1132 wturn6=weights(10)*fact5
1133 wtor=weights(13)*fact
1134 wtor_d=weights(14)*fact2
1135 wsccor=weights(21)*fact
1139 C------------------------------------------------------------------------
1140 subroutine enerprint(energia)
1141 implicit real*8 (a-h,o-z)
1142 include 'DIMENSIONS'
1143 include 'COMMON.IOUNITS'
1144 include 'COMMON.FFIELD'
1145 include 'COMMON.SBRIDGE'
1147 double precision energia(0:n_ene)
1152 evdw2=energia(2)+energia(18)
1164 eello_turn3=energia(8)
1165 eello_turn4=energia(9)
1166 eello_turn6=energia(10)
1172 edihcnstr=energia(19)
1176 eliptran=energia(22)
1177 Eafmforce=energia(23)
1178 ethetacnstr=energia(24)
1181 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1182 & estr,wbond,ebe,wang,
1183 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1185 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1186 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1187 & ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1190 10 format (/'Virtual-chain energies:'//
1191 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1192 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1193 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1194 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1195 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1196 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1197 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1198 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1199 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1200 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
1201 & ' (SS bridges & dist. cnstr.)'/
1202 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1203 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1204 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1205 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1206 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1207 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1208 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1209 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1210 & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1211 & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1212 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1213 & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1214 & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1215 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1216 & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1217 & 'ETOT= ',1pE16.6,' (total)')
1220 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1221 & estr,wbond,ebe,wang,
1222 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1224 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1225 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1226 & ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1229 10 format (/'Virtual-chain energies:'//
1230 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1231 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1232 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1233 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1234 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1235 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1236 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1237 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1238 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
1239 & ' (SS bridges & dist. cnstr.)'/
1240 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1241 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1242 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1243 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1244 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1245 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1246 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1247 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1248 & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1249 & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1250 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1251 & 'UCONST=',1pE16.6,' (Constraint energy)'/
1252 & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1253 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1254 & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1255 & 'ETOT= ',1pE16.6,' (total)')
1259 C-----------------------------------------------------------------------
1260 subroutine elj(evdw)
1262 C This subroutine calculates the interaction energy of nonbonded side chains
1263 C assuming the LJ potential of interaction.
1265 implicit real*8 (a-h,o-z)
1266 include 'DIMENSIONS'
1267 parameter (accur=1.0d-10)
1268 include 'COMMON.GEO'
1269 include 'COMMON.VAR'
1270 include 'COMMON.LOCAL'
1271 include 'COMMON.CHAIN'
1272 include 'COMMON.DERIV'
1273 include 'COMMON.INTERACT'
1274 include 'COMMON.TORSION'
1275 include 'COMMON.SBRIDGE'
1276 include 'COMMON.NAMES'
1277 include 'COMMON.IOUNITS'
1278 include 'COMMON.CONTACTS'
1280 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1282 do i=iatsc_s,iatsc_e
1283 itypi=iabs(itype(i))
1284 if (itypi.eq.ntyp1) cycle
1285 itypi1=iabs(itype(i+1))
1292 C Calculate SC interaction energy.
1294 do iint=1,nint_gr(i)
1295 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1296 cd & 'iend=',iend(i,iint)
1297 do j=istart(i,iint),iend(i,iint)
1298 itypj=iabs(itype(j))
1299 if (itypj.eq.ntyp1) cycle
1303 C Change 12/1/95 to calculate four-body interactions
1304 rij=xj*xj+yj*yj+zj*zj
1306 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1307 eps0ij=eps(itypi,itypj)
1309 C have you changed here?
1313 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1314 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1315 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1316 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1317 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1318 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1321 C Calculate the components of the gradient in DC and X
1323 fac=-rrij*(e1+evdwij)
1328 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1329 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1330 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1331 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1335 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1339 C 12/1/95, revised on 5/20/97
1341 C Calculate the contact function. The ith column of the array JCONT will
1342 C contain the numbers of atoms that make contacts with the atom I (of numbers
1343 C greater than I). The arrays FACONT and GACONT will contain the values of
1344 C the contact function and its derivative.
1346 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1347 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1348 C Uncomment next line, if the correlation interactions are contact function only
1349 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1351 sigij=sigma(itypi,itypj)
1352 r0ij=rs0(itypi,itypj)
1354 C Check whether the SC's are not too far to make a contact.
1357 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1358 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1360 if (fcont.gt.0.0D0) then
1361 C If the SC-SC distance if close to sigma, apply spline.
1362 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1363 cAdam & fcont1,fprimcont1)
1364 cAdam fcont1=1.0d0-fcont1
1365 cAdam if (fcont1.gt.0.0d0) then
1366 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1367 cAdam fcont=fcont*fcont1
1369 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1370 cga eps0ij=1.0d0/dsqrt(eps0ij)
1372 cga gg(k)=gg(k)*eps0ij
1374 cga eps0ij=-evdwij*eps0ij
1375 C Uncomment for AL's type of SC correlation interactions.
1376 cadam eps0ij=-evdwij
1377 num_conti=num_conti+1
1378 jcont(num_conti,i)=j
1379 facont(num_conti,i)=fcont*eps0ij
1380 fprimcont=eps0ij*fprimcont/rij
1382 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1383 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1384 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1385 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1386 gacont(1,num_conti,i)=-fprimcont*xj
1387 gacont(2,num_conti,i)=-fprimcont*yj
1388 gacont(3,num_conti,i)=-fprimcont*zj
1389 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1390 cd write (iout,'(2i3,3f10.5)')
1391 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1397 num_cont(i)=num_conti
1401 gvdwc(j,i)=expon*gvdwc(j,i)
1402 gvdwx(j,i)=expon*gvdwx(j,i)
1405 C******************************************************************************
1409 C To save time, the factor of EXPON has been extracted from ALL components
1410 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1413 C******************************************************************************
1416 C-----------------------------------------------------------------------------
1417 subroutine eljk(evdw)
1419 C This subroutine calculates the interaction energy of nonbonded side chains
1420 C assuming the LJK potential of interaction.
1422 implicit real*8 (a-h,o-z)
1423 include 'DIMENSIONS'
1424 include 'COMMON.GEO'
1425 include 'COMMON.VAR'
1426 include 'COMMON.LOCAL'
1427 include 'COMMON.CHAIN'
1428 include 'COMMON.DERIV'
1429 include 'COMMON.INTERACT'
1430 include 'COMMON.IOUNITS'
1431 include 'COMMON.NAMES'
1434 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1436 do i=iatsc_s,iatsc_e
1437 itypi=iabs(itype(i))
1438 if (itypi.eq.ntyp1) cycle
1439 itypi1=iabs(itype(i+1))
1444 C Calculate SC interaction energy.
1446 do iint=1,nint_gr(i)
1447 do j=istart(i,iint),iend(i,iint)
1448 itypj=iabs(itype(j))
1449 if (itypj.eq.ntyp1) cycle
1453 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1454 fac_augm=rrij**expon
1455 e_augm=augm(itypi,itypj)*fac_augm
1456 r_inv_ij=dsqrt(rrij)
1458 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1459 fac=r_shift_inv**expon
1460 C have you changed here?
1464 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1465 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1466 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1467 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1468 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1469 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1470 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1473 C Calculate the components of the gradient in DC and X
1475 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1480 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1481 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1482 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1483 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1487 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1495 gvdwc(j,i)=expon*gvdwc(j,i)
1496 gvdwx(j,i)=expon*gvdwx(j,i)
1501 C-----------------------------------------------------------------------------
1502 subroutine ebp(evdw)
1504 C This subroutine calculates the interaction energy of nonbonded side chains
1505 C assuming the Berne-Pechukas potential of interaction.
1507 implicit real*8 (a-h,o-z)
1508 include 'DIMENSIONS'
1509 include 'COMMON.GEO'
1510 include 'COMMON.VAR'
1511 include 'COMMON.LOCAL'
1512 include 'COMMON.CHAIN'
1513 include 'COMMON.DERIV'
1514 include 'COMMON.NAMES'
1515 include 'COMMON.INTERACT'
1516 include 'COMMON.IOUNITS'
1517 include 'COMMON.CALC'
1518 common /srutu/ icall
1519 c double precision rrsave(maxdim)
1522 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1524 c if (icall.eq.0) then
1530 do i=iatsc_s,iatsc_e
1531 itypi=iabs(itype(i))
1532 if (itypi.eq.ntyp1) cycle
1533 itypi1=iabs(itype(i+1))
1537 dxi=dc_norm(1,nres+i)
1538 dyi=dc_norm(2,nres+i)
1539 dzi=dc_norm(3,nres+i)
1540 c dsci_inv=dsc_inv(itypi)
1541 dsci_inv=vbld_inv(i+nres)
1543 C Calculate SC interaction energy.
1545 do iint=1,nint_gr(i)
1546 do j=istart(i,iint),iend(i,iint)
1548 itypj=iabs(itype(j))
1549 if (itypj.eq.ntyp1) cycle
1550 c dscj_inv=dsc_inv(itypj)
1551 dscj_inv=vbld_inv(j+nres)
1552 chi1=chi(itypi,itypj)
1553 chi2=chi(itypj,itypi)
1560 alf12=0.5D0*(alf1+alf2)
1561 C For diagnostics only!!!
1574 dxj=dc_norm(1,nres+j)
1575 dyj=dc_norm(2,nres+j)
1576 dzj=dc_norm(3,nres+j)
1577 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1578 cd if (icall.eq.0) then
1584 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1586 C Calculate whole angle-dependent part of epsilon and contributions
1587 C to its derivatives
1588 C have you changed here?
1589 fac=(rrij*sigsq)**expon2
1592 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1593 eps2der=evdwij*eps3rt
1594 eps3der=evdwij*eps2rt
1595 evdwij=evdwij*eps2rt*eps3rt
1598 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1600 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1601 cd & restyp(itypi),i,restyp(itypj),j,
1602 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1603 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1604 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1607 C Calculate gradient components.
1608 e1=e1*eps1*eps2rt**2*eps3rt**2
1609 fac=-expon*(e1+evdwij)
1612 C Calculate radial part of the gradient
1616 C Calculate the angular part of the gradient and sum add the contributions
1617 C to the appropriate components of the Cartesian gradient.
1625 C-----------------------------------------------------------------------------
1626 subroutine egb(evdw)
1628 C This subroutine calculates the interaction energy of nonbonded side chains
1629 C assuming the Gay-Berne potential of interaction.
1631 implicit real*8 (a-h,o-z)
1632 include 'DIMENSIONS'
1633 include 'COMMON.GEO'
1634 include 'COMMON.VAR'
1635 include 'COMMON.LOCAL'
1636 include 'COMMON.CHAIN'
1637 include 'COMMON.DERIV'
1638 include 'COMMON.NAMES'
1639 include 'COMMON.INTERACT'
1640 include 'COMMON.IOUNITS'
1641 include 'COMMON.CALC'
1642 include 'COMMON.CONTROL'
1643 include 'COMMON.SPLITELE'
1644 include 'COMMON.SBRIDGE'
1646 integer xshift,yshift,zshift
1649 ccccc energy_dec=.false.
1650 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1653 c if (icall.eq.0) lprn=.false.
1655 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1656 C we have the original box)
1660 do i=iatsc_s,iatsc_e
1661 itypi=iabs(itype(i))
1662 if (itypi.eq.ntyp1) cycle
1663 itypi1=iabs(itype(i+1))
1667 C Return atom into box, boxxsize is size of box in x dimension
1669 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1670 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1671 C Condition for being inside the proper box
1672 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1673 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
1677 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1678 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1679 C Condition for being inside the proper box
1680 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1681 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
1685 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1686 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1687 C Condition for being inside the proper box
1688 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1689 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
1693 if (xi.lt.0) xi=xi+boxxsize
1695 if (yi.lt.0) yi=yi+boxysize
1697 if (zi.lt.0) zi=zi+boxzsize
1698 C define scaling factor for lipids
1700 C if (positi.le.0) positi=positi+boxzsize
1702 C first for peptide groups
1703 c for each residue check if it is in lipid or lipid water border area
1704 if ((zi.gt.bordlipbot)
1705 &.and.(zi.lt.bordliptop)) then
1706 C the energy transfer exist
1707 if (zi.lt.buflipbot) then
1708 C what fraction I am in
1710 & ((zi-bordlipbot)/lipbufthick)
1711 C lipbufthick is thickenes of lipid buffore
1712 sslipi=sscalelip(fracinbuf)
1713 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1714 elseif (zi.gt.bufliptop) then
1715 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1716 sslipi=sscalelip(fracinbuf)
1717 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1727 C xi=xi+xshift*boxxsize
1728 C yi=yi+yshift*boxysize
1729 C zi=zi+zshift*boxzsize
1731 dxi=dc_norm(1,nres+i)
1732 dyi=dc_norm(2,nres+i)
1733 dzi=dc_norm(3,nres+i)
1734 c dsci_inv=dsc_inv(itypi)
1735 dsci_inv=vbld_inv(i+nres)
1736 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1737 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1739 C Calculate SC interaction energy.
1741 do iint=1,nint_gr(i)
1742 do j=istart(i,iint),iend(i,iint)
1743 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1745 c write(iout,*) "PRZED ZWYKLE", evdwij
1746 call dyn_ssbond_ene(i,j,evdwij)
1747 c write(iout,*) "PO ZWYKLE", evdwij
1750 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1751 & 'evdw',i,j,evdwij,' ss'
1752 C triple bond artifac removal
1753 do k=j+1,iend(i,iint)
1754 C search over all next residues
1755 if (dyn_ss_mask(k)) then
1756 C check if they are cysteins
1757 C write(iout,*) 'k=',k
1759 c write(iout,*) "PRZED TRI", evdwij
1760 evdwij_przed_tri=evdwij
1761 call triple_ssbond_ene(i,j,k,evdwij)
1762 c if(evdwij_przed_tri.ne.evdwij) then
1763 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1766 c write(iout,*) "PO TRI", evdwij
1767 C call the energy function that removes the artifical triple disulfide
1768 C bond the soubroutine is located in ssMD.F
1770 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1771 & 'evdw',i,j,evdwij,'tss'
1772 endif!dyn_ss_mask(k)
1776 itypj=iabs(itype(j))
1777 if (itypj.eq.ntyp1) cycle
1778 c dscj_inv=dsc_inv(itypj)
1779 dscj_inv=vbld_inv(j+nres)
1780 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1781 c & 1.0d0/vbld(j+nres)
1782 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1783 sig0ij=sigma(itypi,itypj)
1784 chi1=chi(itypi,itypj)
1785 chi2=chi(itypj,itypi)
1792 alf12=0.5D0*(alf1+alf2)
1793 C For diagnostics only!!!
1806 C Return atom J into box the original box
1808 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1809 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1810 C Condition for being inside the proper box
1811 c if ((xj.gt.((0.5d0)*boxxsize)).or.
1812 c & (xj.lt.((-0.5d0)*boxxsize))) then
1816 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1817 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1818 C Condition for being inside the proper box
1819 c if ((yj.gt.((0.5d0)*boxysize)).or.
1820 c & (yj.lt.((-0.5d0)*boxysize))) then
1824 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1825 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1826 C Condition for being inside the proper box
1827 c if ((zj.gt.((0.5d0)*boxzsize)).or.
1828 c & (zj.lt.((-0.5d0)*boxzsize))) then
1832 if (xj.lt.0) xj=xj+boxxsize
1834 if (yj.lt.0) yj=yj+boxysize
1836 if (zj.lt.0) zj=zj+boxzsize
1837 if ((zj.gt.bordlipbot)
1838 &.and.(zj.lt.bordliptop)) then
1839 C the energy transfer exist
1840 if (zj.lt.buflipbot) then
1841 C what fraction I am in
1843 & ((zj-bordlipbot)/lipbufthick)
1844 C lipbufthick is thickenes of lipid buffore
1845 sslipj=sscalelip(fracinbuf)
1846 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1847 elseif (zj.gt.bufliptop) then
1848 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1849 sslipj=sscalelip(fracinbuf)
1850 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1859 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1860 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1861 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1862 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1863 C write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1864 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1865 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1866 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1867 C print *,sslipi,sslipj,bordlipbot,zi,zj
1868 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1876 xj=xj_safe+xshift*boxxsize
1877 yj=yj_safe+yshift*boxysize
1878 zj=zj_safe+zshift*boxzsize
1879 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1880 if(dist_temp.lt.dist_init) then
1890 if (subchap.eq.1) then
1899 dxj=dc_norm(1,nres+j)
1900 dyj=dc_norm(2,nres+j)
1901 dzj=dc_norm(3,nres+j)
1905 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1906 c write (iout,*) "j",j," dc_norm",
1907 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1908 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1910 sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1911 sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1913 c write (iout,'(a7,4f8.3)')
1914 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1915 if (sss.gt.0.0d0) then
1916 C Calculate angle-dependent terms of energy and contributions to their
1920 sig=sig0ij*dsqrt(sigsq)
1921 rij_shift=1.0D0/rij-sig+sig0ij
1922 c for diagnostics; uncomment
1923 c rij_shift=1.2*sig0ij
1924 C I hate to put IF's in the loops, but here don't have another choice!!!!
1925 if (rij_shift.le.0.0D0) then
1927 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1928 cd & restyp(itypi),i,restyp(itypj),j,
1929 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1933 c---------------------------------------------------------------
1934 rij_shift=1.0D0/rij_shift
1935 fac=rij_shift**expon
1936 C here to start with
1941 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1942 eps2der=evdwij*eps3rt
1943 eps3der=evdwij*eps2rt
1944 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1945 C &((sslipi+sslipj)/2.0d0+
1946 C &(2.0d0-sslipi-sslipj)/2.0d0)
1947 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1948 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1949 evdwij=evdwij*eps2rt*eps3rt
1950 evdw=evdw+evdwij*sss
1952 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1954 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1955 & restyp(itypi),i,restyp(itypj),j,
1956 & epsi,sigm,chi1,chi2,chip1,chip2,
1957 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1958 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1962 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1965 C Calculate gradient components.
1966 e1=e1*eps1*eps2rt**2*eps3rt**2
1967 fac=-expon*(e1+evdwij)*rij_shift
1970 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
1971 c & evdwij,fac,sigma(itypi,itypj),expon
1972 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1974 C Calculate the radial part of the gradient
1975 gg_lipi(3)=eps1*(eps2rt*eps2rt)
1976 &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1977 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1978 &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1979 gg_lipj(3)=ssgradlipj*gg_lipi(3)
1980 gg_lipi(3)=gg_lipi(3)*ssgradlipi
1986 C Calculate angular part of the gradient.
1996 c write (iout,*) "Number of loop steps in EGB:",ind
1997 cccc energy_dec=.false.
2000 C-----------------------------------------------------------------------------
2001 subroutine egbv(evdw)
2003 C This subroutine calculates the interaction energy of nonbonded side chains
2004 C assuming the Gay-Berne-Vorobjev potential of interaction.
2006 implicit real*8 (a-h,o-z)
2007 include 'DIMENSIONS'
2008 include 'COMMON.GEO'
2009 include 'COMMON.VAR'
2010 include 'COMMON.LOCAL'
2011 include 'COMMON.CHAIN'
2012 include 'COMMON.DERIV'
2013 include 'COMMON.NAMES'
2014 include 'COMMON.INTERACT'
2015 include 'COMMON.IOUNITS'
2016 include 'COMMON.CALC'
2017 common /srutu/ icall
2020 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2023 c if (icall.eq.0) lprn=.true.
2025 do i=iatsc_s,iatsc_e
2026 itypi=iabs(itype(i))
2027 if (itypi.eq.ntyp1) cycle
2028 itypi1=iabs(itype(i+1))
2033 if (xi.lt.0) xi=xi+boxxsize
2035 if (yi.lt.0) yi=yi+boxysize
2037 if (zi.lt.0) zi=zi+boxzsize
2038 C define scaling factor for lipids
2040 C if (positi.le.0) positi=positi+boxzsize
2042 C first for peptide groups
2043 c for each residue check if it is in lipid or lipid water border area
2044 if ((zi.gt.bordlipbot)
2045 &.and.(zi.lt.bordliptop)) then
2046 C the energy transfer exist
2047 if (zi.lt.buflipbot) then
2048 C what fraction I am in
2050 & ((zi-bordlipbot)/lipbufthick)
2051 C lipbufthick is thickenes of lipid buffore
2052 sslipi=sscalelip(fracinbuf)
2053 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2054 elseif (zi.gt.bufliptop) then
2055 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2056 sslipi=sscalelip(fracinbuf)
2057 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2067 dxi=dc_norm(1,nres+i)
2068 dyi=dc_norm(2,nres+i)
2069 dzi=dc_norm(3,nres+i)
2070 c dsci_inv=dsc_inv(itypi)
2071 dsci_inv=vbld_inv(i+nres)
2073 C Calculate SC interaction energy.
2075 do iint=1,nint_gr(i)
2076 do j=istart(i,iint),iend(i,iint)
2078 itypj=iabs(itype(j))
2079 if (itypj.eq.ntyp1) cycle
2080 c dscj_inv=dsc_inv(itypj)
2081 dscj_inv=vbld_inv(j+nres)
2082 sig0ij=sigma(itypi,itypj)
2083 r0ij=r0(itypi,itypj)
2084 chi1=chi(itypi,itypj)
2085 chi2=chi(itypj,itypi)
2092 alf12=0.5D0*(alf1+alf2)
2093 C For diagnostics only!!!
2107 if (xj.lt.0) xj=xj+boxxsize
2109 if (yj.lt.0) yj=yj+boxysize
2111 if (zj.lt.0) zj=zj+boxzsize
2112 if ((zj.gt.bordlipbot)
2113 &.and.(zj.lt.bordliptop)) then
2114 C the energy transfer exist
2115 if (zj.lt.buflipbot) then
2116 C what fraction I am in
2118 & ((zj-bordlipbot)/lipbufthick)
2119 C lipbufthick is thickenes of lipid buffore
2120 sslipj=sscalelip(fracinbuf)
2121 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2122 elseif (zj.gt.bufliptop) then
2123 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2124 sslipj=sscalelip(fracinbuf)
2125 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2134 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2135 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2136 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2137 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2138 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2139 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2140 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2141 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2149 xj=xj_safe+xshift*boxxsize
2150 yj=yj_safe+yshift*boxysize
2151 zj=zj_safe+zshift*boxzsize
2152 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2153 if(dist_temp.lt.dist_init) then
2163 if (subchap.eq.1) then
2172 dxj=dc_norm(1,nres+j)
2173 dyj=dc_norm(2,nres+j)
2174 dzj=dc_norm(3,nres+j)
2175 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2177 C Calculate angle-dependent terms of energy and contributions to their
2181 sig=sig0ij*dsqrt(sigsq)
2182 rij_shift=1.0D0/rij-sig+r0ij
2183 C I hate to put IF's in the loops, but here don't have another choice!!!!
2184 if (rij_shift.le.0.0D0) then
2189 c---------------------------------------------------------------
2190 rij_shift=1.0D0/rij_shift
2191 fac=rij_shift**expon
2194 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2195 eps2der=evdwij*eps3rt
2196 eps3der=evdwij*eps2rt
2197 fac_augm=rrij**expon
2198 e_augm=augm(itypi,itypj)*fac_augm
2199 evdwij=evdwij*eps2rt*eps3rt
2200 evdw=evdw+evdwij+e_augm
2202 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2204 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2205 & restyp(itypi),i,restyp(itypj),j,
2206 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2207 & chi1,chi2,chip1,chip2,
2208 & eps1,eps2rt**2,eps3rt**2,
2209 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2212 C Calculate gradient components.
2213 e1=e1*eps1*eps2rt**2*eps3rt**2
2214 fac=-expon*(e1+evdwij)*rij_shift
2216 fac=rij*fac-2*expon*rrij*e_augm
2217 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2218 C Calculate the radial part of the gradient
2222 C Calculate angular part of the gradient.
2228 C-----------------------------------------------------------------------------
2229 subroutine sc_angular
2230 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2231 C om12. Called by ebp, egb, and egbv.
2233 include 'COMMON.CALC'
2234 include 'COMMON.IOUNITS'
2238 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2239 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2240 om12=dxi*dxj+dyi*dyj+dzi*dzj
2242 C Calculate eps1(om12) and its derivative in om12
2243 faceps1=1.0D0-om12*chiom12
2244 faceps1_inv=1.0D0/faceps1
2245 eps1=dsqrt(faceps1_inv)
2246 C Following variable is eps1*deps1/dom12
2247 eps1_om12=faceps1_inv*chiom12
2252 c write (iout,*) "om12",om12," eps1",eps1
2253 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2258 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2259 sigsq=1.0D0-facsig*faceps1_inv
2260 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2261 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2262 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2268 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2269 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2271 C Calculate eps2 and its derivatives in om1, om2, and om12.
2274 chipom12=chip12*om12
2275 facp=1.0D0-om12*chipom12
2277 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2278 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2279 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2280 C Following variable is the square root of eps2
2281 eps2rt=1.0D0-facp1*facp_inv
2282 C Following three variables are the derivatives of the square root of eps
2283 C in om1, om2, and om12.
2284 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2285 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2286 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2287 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2288 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2289 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2290 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2291 c & " eps2rt_om12",eps2rt_om12
2292 C Calculate whole angle-dependent part of epsilon and contributions
2293 C to its derivatives
2296 C----------------------------------------------------------------------------
2298 implicit real*8 (a-h,o-z)
2299 include 'DIMENSIONS'
2300 include 'COMMON.CHAIN'
2301 include 'COMMON.DERIV'
2302 include 'COMMON.CALC'
2303 include 'COMMON.IOUNITS'
2304 double precision dcosom1(3),dcosom2(3)
2305 cc print *,'sss=',sss
2306 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2307 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2308 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2309 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2313 c eom12=evdwij*eps1_om12
2315 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2316 c & " sigder",sigder
2317 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2318 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2320 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2321 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2324 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2326 c write (iout,*) "gg",(gg(k),k=1,3)
2328 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2329 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2330 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2331 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2332 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2333 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2334 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2335 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2336 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2337 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2340 C Calculate the components of the gradient in DC and X
2344 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2348 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2349 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2353 C-----------------------------------------------------------------------
2354 subroutine e_softsphere(evdw)
2356 C This subroutine calculates the interaction energy of nonbonded side chains
2357 C assuming the LJ potential of interaction.
2359 implicit real*8 (a-h,o-z)
2360 include 'DIMENSIONS'
2361 parameter (accur=1.0d-10)
2362 include 'COMMON.GEO'
2363 include 'COMMON.VAR'
2364 include 'COMMON.LOCAL'
2365 include 'COMMON.CHAIN'
2366 include 'COMMON.DERIV'
2367 include 'COMMON.INTERACT'
2368 include 'COMMON.TORSION'
2369 include 'COMMON.SBRIDGE'
2370 include 'COMMON.NAMES'
2371 include 'COMMON.IOUNITS'
2372 include 'COMMON.CONTACTS'
2374 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2376 do i=iatsc_s,iatsc_e
2377 itypi=iabs(itype(i))
2378 if (itypi.eq.ntyp1) cycle
2379 itypi1=iabs(itype(i+1))
2384 C Calculate SC interaction energy.
2386 do iint=1,nint_gr(i)
2387 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2388 cd & 'iend=',iend(i,iint)
2389 do j=istart(i,iint),iend(i,iint)
2390 itypj=iabs(itype(j))
2391 if (itypj.eq.ntyp1) cycle
2395 rij=xj*xj+yj*yj+zj*zj
2396 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2397 r0ij=r0(itypi,itypj)
2399 c print *,i,j,r0ij,dsqrt(rij)
2400 if (rij.lt.r0ijsq) then
2401 evdwij=0.25d0*(rij-r0ijsq)**2
2409 C Calculate the components of the gradient in DC and X
2415 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2416 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2417 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2418 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2422 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2430 C--------------------------------------------------------------------------
2431 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2434 C Soft-sphere potential of p-p interaction
2436 implicit real*8 (a-h,o-z)
2437 include 'DIMENSIONS'
2438 include 'COMMON.CONTROL'
2439 include 'COMMON.IOUNITS'
2440 include 'COMMON.GEO'
2441 include 'COMMON.VAR'
2442 include 'COMMON.LOCAL'
2443 include 'COMMON.CHAIN'
2444 include 'COMMON.DERIV'
2445 include 'COMMON.INTERACT'
2446 include 'COMMON.CONTACTS'
2447 include 'COMMON.TORSION'
2448 include 'COMMON.VECTORS'
2449 include 'COMMON.FFIELD'
2451 C write(iout,*) 'In EELEC_soft_sphere'
2458 do i=iatel_s,iatel_e
2459 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2463 xmedi=c(1,i)+0.5d0*dxi
2464 ymedi=c(2,i)+0.5d0*dyi
2465 zmedi=c(3,i)+0.5d0*dzi
2466 xmedi=mod(xmedi,boxxsize)
2467 if (xmedi.lt.0) xmedi=xmedi+boxxsize
2468 ymedi=mod(ymedi,boxysize)
2469 if (ymedi.lt.0) ymedi=ymedi+boxysize
2470 zmedi=mod(zmedi,boxzsize)
2471 if (zmedi.lt.0) zmedi=zmedi+boxzsize
2473 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2474 do j=ielstart(i),ielend(i)
2475 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2479 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2480 r0ij=rpp(iteli,itelj)
2489 if (xj.lt.0) xj=xj+boxxsize
2491 if (yj.lt.0) yj=yj+boxysize
2493 if (zj.lt.0) zj=zj+boxzsize
2494 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2502 xj=xj_safe+xshift*boxxsize
2503 yj=yj_safe+yshift*boxysize
2504 zj=zj_safe+zshift*boxzsize
2505 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2506 if(dist_temp.lt.dist_init) then
2516 if (isubchap.eq.1) then
2525 rij=xj*xj+yj*yj+zj*zj
2526 sss=sscale(sqrt(rij))
2527 sssgrad=sscagrad(sqrt(rij))
2528 if (rij.lt.r0ijsq) then
2529 evdw1ij=0.25d0*(rij-r0ijsq)**2
2535 evdw1=evdw1+evdw1ij*sss
2537 C Calculate contributions to the Cartesian gradient.
2539 ggg(1)=fac*xj*sssgrad
2540 ggg(2)=fac*yj*sssgrad
2541 ggg(3)=fac*zj*sssgrad
2543 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2544 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2547 * Loop over residues i+1 thru j-1.
2551 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2556 cgrad do i=nnt,nct-1
2558 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2560 cgrad do j=i+1,nct-1
2562 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2568 c------------------------------------------------------------------------------
2569 subroutine vec_and_deriv
2570 implicit real*8 (a-h,o-z)
2571 include 'DIMENSIONS'
2575 include 'COMMON.IOUNITS'
2576 include 'COMMON.GEO'
2577 include 'COMMON.VAR'
2578 include 'COMMON.LOCAL'
2579 include 'COMMON.CHAIN'
2580 include 'COMMON.VECTORS'
2581 include 'COMMON.SETUP'
2582 include 'COMMON.TIME1'
2583 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2584 C Compute the local reference systems. For reference system (i), the
2585 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2586 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2588 do i=ivec_start,ivec_end
2592 if (i.eq.nres-1) then
2593 C Case of the last full residue
2594 C Compute the Z-axis
2595 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2596 costh=dcos(pi-theta(nres))
2597 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2601 C Compute the derivatives of uz
2603 uzder(2,1,1)=-dc_norm(3,i-1)
2604 uzder(3,1,1)= dc_norm(2,i-1)
2605 uzder(1,2,1)= dc_norm(3,i-1)
2607 uzder(3,2,1)=-dc_norm(1,i-1)
2608 uzder(1,3,1)=-dc_norm(2,i-1)
2609 uzder(2,3,1)= dc_norm(1,i-1)
2612 uzder(2,1,2)= dc_norm(3,i)
2613 uzder(3,1,2)=-dc_norm(2,i)
2614 uzder(1,2,2)=-dc_norm(3,i)
2616 uzder(3,2,2)= dc_norm(1,i)
2617 uzder(1,3,2)= dc_norm(2,i)
2618 uzder(2,3,2)=-dc_norm(1,i)
2620 C Compute the Y-axis
2623 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2625 C Compute the derivatives of uy
2628 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2629 & -dc_norm(k,i)*dc_norm(j,i-1)
2630 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2632 uyder(j,j,1)=uyder(j,j,1)-costh
2633 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2638 uygrad(l,k,j,i)=uyder(l,k,j)
2639 uzgrad(l,k,j,i)=uzder(l,k,j)
2643 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2644 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2645 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2646 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2649 C Compute the Z-axis
2650 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2651 costh=dcos(pi-theta(i+2))
2652 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2656 C Compute the derivatives of uz
2658 uzder(2,1,1)=-dc_norm(3,i+1)
2659 uzder(3,1,1)= dc_norm(2,i+1)
2660 uzder(1,2,1)= dc_norm(3,i+1)
2662 uzder(3,2,1)=-dc_norm(1,i+1)
2663 uzder(1,3,1)=-dc_norm(2,i+1)
2664 uzder(2,3,1)= dc_norm(1,i+1)
2667 uzder(2,1,2)= dc_norm(3,i)
2668 uzder(3,1,2)=-dc_norm(2,i)
2669 uzder(1,2,2)=-dc_norm(3,i)
2671 uzder(3,2,2)= dc_norm(1,i)
2672 uzder(1,3,2)= dc_norm(2,i)
2673 uzder(2,3,2)=-dc_norm(1,i)
2675 C Compute the Y-axis
2678 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2680 C Compute the derivatives of uy
2683 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2684 & -dc_norm(k,i)*dc_norm(j,i+1)
2685 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2687 uyder(j,j,1)=uyder(j,j,1)-costh
2688 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2693 uygrad(l,k,j,i)=uyder(l,k,j)
2694 uzgrad(l,k,j,i)=uzder(l,k,j)
2698 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2699 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2700 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2701 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2705 vbld_inv_temp(1)=vbld_inv(i+1)
2706 if (i.lt.nres-1) then
2707 vbld_inv_temp(2)=vbld_inv(i+2)
2709 vbld_inv_temp(2)=vbld_inv(i)
2714 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2715 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2720 #if defined(PARVEC) && defined(MPI)
2721 if (nfgtasks1.gt.1) then
2723 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2724 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2725 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2726 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2727 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2729 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2730 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2732 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2733 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2734 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2735 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2736 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2737 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2738 time_gather=time_gather+MPI_Wtime()-time00
2740 c if (fg_rank.eq.0) then
2741 c write (iout,*) "Arrays UY and UZ"
2743 c write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2750 C-----------------------------------------------------------------------------
2751 subroutine check_vecgrad
2752 implicit real*8 (a-h,o-z)
2753 include 'DIMENSIONS'
2754 include 'COMMON.IOUNITS'
2755 include 'COMMON.GEO'
2756 include 'COMMON.VAR'
2757 include 'COMMON.LOCAL'
2758 include 'COMMON.CHAIN'
2759 include 'COMMON.VECTORS'
2760 dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2761 dimension uyt(3,maxres),uzt(3,maxres)
2762 dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2763 double precision delta /1.0d-7/
2766 crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2767 crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2768 crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2769 cd write(iout,'(2i5,2(3f10.5,5x))') i,1,
2770 cd & (dc_norm(if90,i),if90=1,3)
2771 cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2772 cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2773 cd write(iout,'(a)')
2779 uygradt(l,k,j,i)=uygrad(l,k,j,i)
2780 uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2793 cd write (iout,*) 'i=',i
2795 erij(k)=dc_norm(k,i)
2799 dc_norm(k,i)=erij(k)
2801 dc_norm(j,i)=dc_norm(j,i)+delta
2802 c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2804 c dc_norm(k,i)=dc_norm(k,i)/fac
2806 c write (iout,*) (dc_norm(k,i),k=1,3)
2807 c write (iout,*) (erij(k),k=1,3)
2810 uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2811 uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2812 uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2813 uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2815 c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2816 c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2817 c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2820 dc_norm(k,i)=erij(k)
2823 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2824 cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2825 cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2826 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2827 cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2828 cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2829 cd write (iout,'(a)')
2834 C--------------------------------------------------------------------------
2835 subroutine set_matrices
2836 implicit real*8 (a-h,o-z)
2837 include 'DIMENSIONS'
2840 include "COMMON.SETUP"
2842 integer status(MPI_STATUS_SIZE)
2844 include 'COMMON.IOUNITS'
2845 include 'COMMON.GEO'
2846 include 'COMMON.VAR'
2847 include 'COMMON.LOCAL'
2848 include 'COMMON.CHAIN'
2849 include 'COMMON.DERIV'
2850 include 'COMMON.INTERACT'
2851 include 'COMMON.CONTACTS'
2852 include 'COMMON.TORSION'
2853 include 'COMMON.VECTORS'
2854 include 'COMMON.FFIELD'
2855 double precision auxvec(2),auxmat(2,2)
2857 C Compute the virtual-bond-torsional-angle dependent quantities needed
2858 C to calculate the el-loc multibody terms of various order.
2860 c write(iout,*) 'nphi=',nphi,nres
2862 do i=ivec_start+2,ivec_end+2
2867 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2868 iti = itype2loc(itype(i-2))
2872 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2873 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2874 iti1 = itype2loc(itype(i-1))
2879 b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2880 & +bnew1(2,1,iti)*dsin(theta(i-1))
2881 & +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2882 gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2883 & +bnew1(2,1,iti)*dcos(theta(i-1))
2884 & -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2885 c & +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2886 c &*(cos(theta(i)/2.0)
2887 b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2888 & +bnew2(2,1,iti)*dsin(theta(i-1))
2889 & +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2890 c & +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2891 c &*(cos(theta(i)/2.0)
2892 gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2893 & +bnew2(2,1,iti)*dcos(theta(i-1))
2894 & -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2895 c if (ggb1(1,i).eq.0.0d0) then
2896 c write(iout,*) 'i=',i,ggb1(1,i),
2897 c &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2898 c &bnew1(2,1,iti)*cos(theta(i)),
2899 c &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2901 b1(2,i-2)=bnew1(1,2,iti)
2903 b2(2,i-2)=bnew2(1,2,iti)
2905 EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2906 EE(1,2,i-2)=eeold(1,2,iti)
2907 EE(2,1,i-2)=eeold(2,1,iti)
2908 EE(2,2,i-2)=eeold(2,2,iti)
2909 gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2914 c EE(1,2,iti)=0.5d0*eenew(1,iti)
2915 c EE(2,1,iti)=0.5d0*eenew(1,iti)
2916 c b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2917 c b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2918 b1tilde(1,i-2)=b1(1,i-2)
2919 b1tilde(2,i-2)=-b1(2,i-2)
2920 b2tilde(1,i-2)=b2(1,i-2)
2921 b2tilde(2,i-2)=-b2(2,i-2)
2922 c write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2923 c write(iout,*) 'b1=',b1(1,i-2)
2924 c write (iout,*) 'theta=', theta(i-1)
2927 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2928 iti = itype2loc(itype(i-2))
2932 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2933 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2934 iti1 = itype2loc(itype(i-1))
2942 b1tilde(1,i-2)=b1(1,i-2)
2943 b1tilde(2,i-2)=-b1(2,i-2)
2944 b2tilde(1,i-2)=b2(1,i-2)
2945 b2tilde(2,i-2)=-b2(2,i-2)
2946 EE(1,2,i-2)=eeold(1,2,iti)
2947 EE(2,1,i-2)=eeold(2,1,iti)
2948 EE(2,2,i-2)=eeold(2,2,iti)
2949 EE(1,1,i-2)=eeold(1,1,iti)
2953 do i=ivec_start+2,ivec_end+2
2957 if (i .lt. nres+1) then
2994 if (i .gt. 3 .and. i .lt. nres+1) then
2995 obrot_der(1,i-2)=-sin1
2996 obrot_der(2,i-2)= cos1
2997 Ugder(1,1,i-2)= sin1
2998 Ugder(1,2,i-2)=-cos1
2999 Ugder(2,1,i-2)=-cos1
3000 Ugder(2,2,i-2)=-sin1
3003 obrot2_der(1,i-2)=-dwasin2
3004 obrot2_der(2,i-2)= dwacos2
3005 Ug2der(1,1,i-2)= dwasin2
3006 Ug2der(1,2,i-2)=-dwacos2
3007 Ug2der(2,1,i-2)=-dwacos2
3008 Ug2der(2,2,i-2)=-dwasin2
3010 obrot_der(1,i-2)=0.0d0
3011 obrot_der(2,i-2)=0.0d0
3012 Ugder(1,1,i-2)=0.0d0
3013 Ugder(1,2,i-2)=0.0d0
3014 Ugder(2,1,i-2)=0.0d0
3015 Ugder(2,2,i-2)=0.0d0
3016 obrot2_der(1,i-2)=0.0d0
3017 obrot2_der(2,i-2)=0.0d0
3018 Ug2der(1,1,i-2)=0.0d0
3019 Ug2der(1,2,i-2)=0.0d0
3020 Ug2der(2,1,i-2)=0.0d0
3021 Ug2der(2,2,i-2)=0.0d0
3023 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3024 if (i.gt. nnt+2 .and. i.lt.nct+2) then
3025 iti = itype2loc(itype(i-2))
3029 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3030 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3031 iti1 = itype2loc(itype(i-1))
3035 cd write (iout,*) '*******i',i,' iti1',iti
3036 cd write (iout,*) 'b1',b1(:,iti)
3037 cd write (iout,*) 'b2',b2(:,iti)
3038 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3039 c if (i .gt. iatel_s+2) then
3040 if (i .gt. nnt+2) then
3041 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3043 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3044 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3046 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3047 c & EE(1,2,iti),EE(2,2,i)
3048 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3049 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3050 c write(iout,*) "Macierz EUG",
3051 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3053 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3055 call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3056 call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3057 call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3058 call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3059 call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3070 DtUg2(l,k,i-2)=0.0d0
3074 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3075 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3077 muder(k,i-2)=Ub2der(k,i-2)
3079 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3080 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3081 if (itype(i-1).le.ntyp) then
3082 iti1 = itype2loc(itype(i-1))
3090 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3093 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3094 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3095 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3096 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3097 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3098 & ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3100 cd write (iout,*) 'mu1',mu1(:,i-2)
3101 cd write (iout,*) 'mu2',mu2(:,i-2)
3102 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3104 call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3105 call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3106 call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3107 call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3108 call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3109 C Vectors and matrices dependent on a single virtual-bond dihedral.
3110 call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3111 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3112 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3113 call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3114 call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3115 call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3116 call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3117 call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3118 call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3121 C Matrices dependent on two consecutive virtual-bond dihedrals.
3122 C The order of matrices is from left to right.
3123 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3125 c do i=max0(ivec_start,2),ivec_end
3127 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3128 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3129 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3130 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3131 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3132 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3133 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3134 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3137 #if defined(MPI) && defined(PARMAT)
3139 c if (fg_rank.eq.0) then
3140 write (iout,*) "Arrays UG and UGDER before GATHER"
3142 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3143 & ((ug(l,k,i),l=1,2),k=1,2),
3144 & ((ugder(l,k,i),l=1,2),k=1,2)
3146 write (iout,*) "Arrays UG2 and UG2DER"
3148 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3149 & ((ug2(l,k,i),l=1,2),k=1,2),
3150 & ((ug2der(l,k,i),l=1,2),k=1,2)
3152 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3154 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3155 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3156 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3158 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3160 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3161 & costab(i),sintab(i),costab2(i),sintab2(i)
3163 write (iout,*) "Array MUDER"
3165 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3169 if (nfgtasks.gt.1) then
3171 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3172 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3173 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3175 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3176 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3178 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3179 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3181 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3182 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3184 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3185 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3187 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3188 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3190 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3191 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3193 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3194 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3195 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3196 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3197 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3198 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3199 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3200 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3201 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3202 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3203 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3204 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3205 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3207 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3208 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3210 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3211 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3213 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3214 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3216 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3217 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3219 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3220 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3222 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3223 & ivec_count(fg_rank1),
3224 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3226 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3227 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3229 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3230 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3232 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3233 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3235 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3236 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3238 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3239 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3241 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3242 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3244 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3245 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3247 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3248 & ivec_count(fg_rank1),
3249 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3251 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3252 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3254 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3255 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3257 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3258 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3260 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3261 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3263 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3264 & ivec_count(fg_rank1),
3265 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3267 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3268 & ivec_count(fg_rank1),
3269 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3271 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3272 & ivec_count(fg_rank1),
3273 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3274 & MPI_MAT2,FG_COMM1,IERR)
3275 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3276 & ivec_count(fg_rank1),
3277 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3278 & MPI_MAT2,FG_COMM1,IERR)
3281 c Passes matrix info through the ring
3284 if (irecv.lt.0) irecv=nfgtasks1-1
3287 if (inext.ge.nfgtasks1) inext=0
3289 c write (iout,*) "isend",isend," irecv",irecv
3291 lensend=lentyp(isend)
3292 lenrecv=lentyp(irecv)
3293 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3294 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3295 c & MPI_ROTAT1(lensend),inext,2200+isend,
3296 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3297 c & iprev,2200+irecv,FG_COMM,status,IERR)
3298 c write (iout,*) "Gather ROTAT1"
3300 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3301 c & MPI_ROTAT2(lensend),inext,3300+isend,
3302 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3303 c & iprev,3300+irecv,FG_COMM,status,IERR)
3304 c write (iout,*) "Gather ROTAT2"
3306 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3307 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3308 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3309 & iprev,4400+irecv,FG_COMM,status,IERR)
3310 c write (iout,*) "Gather ROTAT_OLD"
3312 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3313 & MPI_PRECOMP11(lensend),inext,5500+isend,
3314 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3315 & iprev,5500+irecv,FG_COMM,status,IERR)
3316 c write (iout,*) "Gather PRECOMP11"
3318 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3319 & MPI_PRECOMP12(lensend),inext,6600+isend,
3320 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3321 & iprev,6600+irecv,FG_COMM,status,IERR)
3322 c write (iout,*) "Gather PRECOMP12"
3324 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3326 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3327 & MPI_ROTAT2(lensend),inext,7700+isend,
3328 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3329 & iprev,7700+irecv,FG_COMM,status,IERR)
3330 c write (iout,*) "Gather PRECOMP21"
3332 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3333 & MPI_PRECOMP22(lensend),inext,8800+isend,
3334 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3335 & iprev,8800+irecv,FG_COMM,status,IERR)
3336 c write (iout,*) "Gather PRECOMP22"
3338 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3339 & MPI_PRECOMP23(lensend),inext,9900+isend,
3340 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3341 & MPI_PRECOMP23(lenrecv),
3342 & iprev,9900+irecv,FG_COMM,status,IERR)
3343 c write (iout,*) "Gather PRECOMP23"
3348 if (irecv.lt.0) irecv=nfgtasks1-1
3351 time_gather=time_gather+MPI_Wtime()-time00
3354 c if (fg_rank.eq.0) then
3355 write (iout,*) "Arrays UG and UGDER"
3357 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3358 & ((ug(l,k,i),l=1,2),k=1,2),
3359 & ((ugder(l,k,i),l=1,2),k=1,2)
3361 write (iout,*) "Arrays UG2 and UG2DER"
3363 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3364 & ((ug2(l,k,i),l=1,2),k=1,2),
3365 & ((ug2der(l,k,i),l=1,2),k=1,2)
3367 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3369 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3370 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3371 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3373 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3375 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3376 & costab(i),sintab(i),costab2(i),sintab2(i)
3378 write (iout,*) "Array MUDER"
3380 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3386 cd iti = itype2loc(itype(i))
3389 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3390 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3395 C--------------------------------------------------------------------------
3396 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3398 C This subroutine calculates the average interaction energy and its gradient
3399 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3400 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3401 C The potential depends both on the distance of peptide-group centers and on
3402 C the orientation of the CA-CA virtual bonds.
3404 implicit real*8 (a-h,o-z)
3408 include 'DIMENSIONS'
3409 include 'COMMON.CONTROL'
3410 include 'COMMON.SETUP'
3411 include 'COMMON.IOUNITS'
3412 include 'COMMON.GEO'
3413 include 'COMMON.VAR'
3414 include 'COMMON.LOCAL'
3415 include 'COMMON.CHAIN'
3416 include 'COMMON.DERIV'
3417 include 'COMMON.INTERACT'
3418 include 'COMMON.CONTACTS'
3419 include 'COMMON.TORSION'
3420 include 'COMMON.VECTORS'
3421 include 'COMMON.FFIELD'
3422 include 'COMMON.TIME1'
3423 include 'COMMON.SPLITELE'
3424 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3425 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3426 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3427 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3428 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3429 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3431 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3433 double precision scal_el /1.0d0/
3435 double precision scal_el /0.5d0/
3438 C 13-go grudnia roku pamietnego...
3439 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3440 & 0.0d0,1.0d0,0.0d0,
3441 & 0.0d0,0.0d0,1.0d0/
3442 cd write(iout,*) 'In EELEC'
3444 cd write(iout,*) 'Type',i
3445 cd write(iout,*) 'B1',B1(:,i)
3446 cd write(iout,*) 'B2',B2(:,i)
3447 cd write(iout,*) 'CC',CC(:,:,i)
3448 cd write(iout,*) 'DD',DD(:,:,i)
3449 cd write(iout,*) 'EE',EE(:,:,i)
3451 cd call check_vecgrad
3453 if (icheckgrad.eq.1) then
3455 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3457 dc_norm(k,i)=dc(k,i)*fac
3459 c write (iout,*) 'i',i,' fac',fac
3462 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3463 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3464 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3465 c call vec_and_deriv
3471 time_mat=time_mat+MPI_Wtime()-time01
3475 cd write (iout,*) 'i=',i
3477 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3480 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3481 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3494 cd print '(a)','Enter EELEC'
3495 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3497 gel_loc_loc(i)=0.0d0
3502 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3504 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3506 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3507 do i=iturn3_start,iturn3_end
3509 C write(iout,*) "tu jest i",i
3510 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3511 C changes suggested by Ana to avoid out of bounds
3512 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3513 c & .or.((i+4).gt.nres)
3514 c & .or.((i-1).le.0)
3515 C end of changes by Ana
3516 & .or. itype(i+2).eq.ntyp1
3517 & .or. itype(i+3).eq.ntyp1) cycle
3518 C Adam: Instructions below will switch off existing interactions
3520 c if(itype(i-1).eq.ntyp1)cycle
3522 c if(i.LT.nres-3)then
3523 c if (itype(i+4).eq.ntyp1) cycle
3528 dx_normi=dc_norm(1,i)
3529 dy_normi=dc_norm(2,i)
3530 dz_normi=dc_norm(3,i)
3531 xmedi=c(1,i)+0.5d0*dxi
3532 ymedi=c(2,i)+0.5d0*dyi
3533 zmedi=c(3,i)+0.5d0*dzi
3534 xmedi=mod(xmedi,boxxsize)
3535 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3536 ymedi=mod(ymedi,boxysize)
3537 if (ymedi.lt.0) ymedi=ymedi+boxysize
3538 zmedi=mod(zmedi,boxzsize)
3539 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3541 call eelecij(i,i+2,ees,evdw1,eel_loc)
3542 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3543 num_cont_hb(i)=num_conti
3545 do i=iturn4_start,iturn4_end
3547 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3548 C changes suggested by Ana to avoid out of bounds
3549 c & .or.((i+5).gt.nres)
3550 c & .or.((i-1).le.0)
3551 C end of changes suggested by Ana
3552 & .or. itype(i+3).eq.ntyp1
3553 & .or. itype(i+4).eq.ntyp1
3554 c & .or. itype(i+5).eq.ntyp1
3555 c & .or. itype(i).eq.ntyp1
3556 c & .or. itype(i-1).eq.ntyp1
3561 dx_normi=dc_norm(1,i)
3562 dy_normi=dc_norm(2,i)
3563 dz_normi=dc_norm(3,i)
3564 xmedi=c(1,i)+0.5d0*dxi
3565 ymedi=c(2,i)+0.5d0*dyi
3566 zmedi=c(3,i)+0.5d0*dzi
3567 C Return atom into box, boxxsize is size of box in x dimension
3569 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3570 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3571 C Condition for being inside the proper box
3572 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3573 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3577 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3578 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3579 C Condition for being inside the proper box
3580 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3581 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3585 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3586 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3587 C Condition for being inside the proper box
3588 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3589 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3592 xmedi=mod(xmedi,boxxsize)
3593 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3594 ymedi=mod(ymedi,boxysize)
3595 if (ymedi.lt.0) ymedi=ymedi+boxysize
3596 zmedi=mod(zmedi,boxzsize)
3597 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3599 num_conti=num_cont_hb(i)
3600 c write(iout,*) "JESTEM W PETLI"
3601 call eelecij(i,i+3,ees,evdw1,eel_loc)
3602 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3603 & call eturn4(i,eello_turn4)
3604 num_cont_hb(i)=num_conti
3606 C Loop over all neighbouring boxes
3611 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3614 do i=iatel_s,iatel_e
3617 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3618 C changes suggested by Ana to avoid out of bounds
3619 c & .or.((i+2).gt.nres)
3620 c & .or.((i-1).le.0)
3621 C end of changes by Ana
3622 c & .or. itype(i+2).eq.ntyp1
3623 c & .or. itype(i-1).eq.ntyp1
3628 dx_normi=dc_norm(1,i)
3629 dy_normi=dc_norm(2,i)
3630 dz_normi=dc_norm(3,i)
3631 xmedi=c(1,i)+0.5d0*dxi
3632 ymedi=c(2,i)+0.5d0*dyi
3633 zmedi=c(3,i)+0.5d0*dzi
3634 xmedi=mod(xmedi,boxxsize)
3635 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3636 ymedi=mod(ymedi,boxysize)
3637 if (ymedi.lt.0) ymedi=ymedi+boxysize
3638 zmedi=mod(zmedi,boxzsize)
3639 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3640 C xmedi=xmedi+xshift*boxxsize
3641 C ymedi=ymedi+yshift*boxysize
3642 C zmedi=zmedi+zshift*boxzsize
3644 C Return tom into box, boxxsize is size of box in x dimension
3646 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3647 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3648 C Condition for being inside the proper box
3649 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3650 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3654 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3655 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3656 C Condition for being inside the proper box
3657 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3658 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3662 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3663 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3664 cC Condition for being inside the proper box
3665 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3666 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3670 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3671 num_conti=num_cont_hb(i)
3673 do j=ielstart(i),ielend(i)
3675 C write (iout,*) i,j
3677 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3678 C changes suggested by Ana to avoid out of bounds
3679 c & .or.((j+2).gt.nres)
3680 c & .or.((j-1).le.0)
3681 C end of changes by Ana
3682 c & .or.itype(j+2).eq.ntyp1
3683 c & .or.itype(j-1).eq.ntyp1
3685 call eelecij(i,j,ees,evdw1,eel_loc)
3687 num_cont_hb(i)=num_conti
3693 c write (iout,*) "Number of loop steps in EELEC:",ind
3695 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3696 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3698 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3699 ccc eel_loc=eel_loc+eello_turn3
3700 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3703 C-------------------------------------------------------------------------------
3704 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3705 implicit real*8 (a-h,o-z)
3706 include 'DIMENSIONS'
3710 include 'COMMON.CONTROL'
3711 include 'COMMON.IOUNITS'
3712 include 'COMMON.GEO'
3713 include 'COMMON.VAR'
3714 include 'COMMON.LOCAL'
3715 include 'COMMON.CHAIN'
3716 include 'COMMON.DERIV'
3717 include 'COMMON.INTERACT'
3718 include 'COMMON.CONTACTS'
3719 include 'COMMON.TORSION'
3720 include 'COMMON.VECTORS'
3721 include 'COMMON.FFIELD'
3722 include 'COMMON.TIME1'
3723 include 'COMMON.SPLITELE'
3724 include 'COMMON.SHIELD'
3725 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3726 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3727 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3728 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3729 & gmuij2(4),gmuji2(4)
3730 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3731 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3733 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3735 double precision scal_el /1.0d0/
3737 double precision scal_el /0.5d0/
3740 C 13-go grudnia roku pamietnego...
3741 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3742 & 0.0d0,1.0d0,0.0d0,
3743 & 0.0d0,0.0d0,1.0d0/
3744 integer xshift,yshift,zshift
3745 c time00=MPI_Wtime()
3746 cd write (iout,*) "eelecij",i,j
3750 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3751 aaa=app(iteli,itelj)
3752 bbb=bpp(iteli,itelj)
3753 ael6i=ael6(iteli,itelj)
3754 ael3i=ael3(iteli,itelj)
3758 dx_normj=dc_norm(1,j)
3759 dy_normj=dc_norm(2,j)
3760 dz_normj=dc_norm(3,j)
3761 C xj=c(1,j)+0.5D0*dxj-xmedi
3762 C yj=c(2,j)+0.5D0*dyj-ymedi
3763 C zj=c(3,j)+0.5D0*dzj-zmedi
3768 if (xj.lt.0) xj=xj+boxxsize
3770 if (yj.lt.0) yj=yj+boxysize
3772 if (zj.lt.0) zj=zj+boxzsize
3773 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3774 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3782 xj=xj_safe+xshift*boxxsize
3783 yj=yj_safe+yshift*boxysize
3784 zj=zj_safe+zshift*boxzsize
3785 dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3786 if(dist_temp.lt.dist_init) then
3796 if (isubchap.eq.1) then
3805 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3807 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3808 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3809 C Condition for being inside the proper box
3810 c if ((xj.gt.((0.5d0)*boxxsize)).or.
3811 c & (xj.lt.((-0.5d0)*boxxsize))) then
3815 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3816 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3817 C Condition for being inside the proper box
3818 c if ((yj.gt.((0.5d0)*boxysize)).or.
3819 c & (yj.lt.((-0.5d0)*boxysize))) then
3823 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3824 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3825 C Condition for being inside the proper box
3826 c if ((zj.gt.((0.5d0)*boxzsize)).or.
3827 c & (zj.lt.((-0.5d0)*boxzsize))) then
3830 C endif !endPBC condintion
3834 rij=xj*xj+yj*yj+zj*zj
3836 sss=sscale(sqrt(rij))
3837 sssgrad=sscagrad(sqrt(rij))
3838 c if (sss.gt.0.0d0) then
3844 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3845 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3846 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3847 fac=cosa-3.0D0*cosb*cosg
3849 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3850 if (j.eq.i+2) ev1=scal_el*ev1
3855 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3859 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3860 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3861 if (shield_mode.gt.0) then
3864 el1=el1*fac_shield(i)**2*fac_shield(j)**2
3865 el2=el2*fac_shield(i)**2*fac_shield(j)**2
3874 evdw1=evdw1+evdwij*sss
3875 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3876 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3877 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
3878 cd & xmedi,ymedi,zmedi,xj,yj,zj
3880 if (energy_dec) then
3881 write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3883 &,iteli,itelj,aaa,evdw1
3885 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3886 &fac_shield(i),fac_shield(j)
3890 C Calculate contributions to the Cartesian gradient.
3893 facvdw=-6*rrmij*(ev1+evdwij)*sss
3894 facel=-3*rrmij*(el1+eesij)
3901 * Radial derivatives. First process both termini of the fragment (i,j)
3906 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3907 & (shield_mode.gt.0)) then
3909 do ilist=1,ishield_list(i)
3910 iresshield=shield_list(ilist,i)
3912 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3914 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3916 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3917 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3918 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3919 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3920 C if (iresshield.gt.i) then
3921 C do ishi=i+1,iresshield-1
3922 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3923 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3927 C do ishi=iresshield,i
3928 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3929 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3935 do ilist=1,ishield_list(j)
3936 iresshield=shield_list(ilist,j)
3938 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3940 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3942 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3943 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3945 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3946 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3947 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3948 C if (iresshield.gt.j) then
3949 C do ishi=j+1,iresshield-1
3950 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3951 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3955 C do ishi=iresshield,j
3956 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3957 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
3964 gshieldc(k,i)=gshieldc(k,i)+
3965 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
3966 gshieldc(k,j)=gshieldc(k,j)+
3967 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
3968 gshieldc(k,i-1)=gshieldc(k,i-1)+
3969 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
3970 gshieldc(k,j-1)=gshieldc(k,j-1)+
3971 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
3976 c ghalf=0.5D0*ggg(k)
3977 c gelc(k,i)=gelc(k,i)+ghalf
3978 c gelc(k,j)=gelc(k,j)+ghalf
3980 c 9/28/08 AL Gradient compotents will be summed only at the end
3981 C print *,"before", gelc_long(1,i), gelc_long(1,j)
3983 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3984 C & +grad_shield(k,j)*eesij/fac_shield(j)
3985 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3986 C & +grad_shield(k,i)*eesij/fac_shield(i)
3987 C gelc_long(k,i-1)=gelc_long(k,i-1)
3988 C & +grad_shield(k,i)*eesij/fac_shield(i)
3989 C gelc_long(k,j-1)=gelc_long(k,j-1)
3990 C & +grad_shield(k,j)*eesij/fac_shield(j)
3992 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
3995 * Loop over residues i+1 thru j-1.
3999 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4002 if (sss.gt.0.0) then
4003 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4004 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4005 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4012 c ghalf=0.5D0*ggg(k)
4013 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4014 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4016 c 9/28/08 AL Gradient compotents will be summed only at the end
4018 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4019 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4022 * Loop over residues i+1 thru j-1.
4026 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4031 facvdw=(ev1+evdwij)*sss
4034 fac=-3*rrmij*(facvdw+facvdw+facel)
4039 * Radial derivatives. First process both termini of the fragment (i,j)
4042 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4044 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4046 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4048 c ghalf=0.5D0*ggg(k)
4049 c gelc(k,i)=gelc(k,i)+ghalf
4050 c gelc(k,j)=gelc(k,j)+ghalf
4052 c 9/28/08 AL Gradient compotents will be summed only at the end
4054 gelc_long(k,j)=gelc(k,j)+ggg(k)
4055 gelc_long(k,i)=gelc(k,i)-ggg(k)
4058 * Loop over residues i+1 thru j-1.
4062 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4065 c 9/28/08 AL Gradient compotents will be summed only at the end
4066 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4067 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4068 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4070 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4071 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4077 ecosa=2.0D0*fac3*fac1+fac4
4080 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4081 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4083 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4084 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4086 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4087 cd & (dcosg(k),k=1,3)
4089 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4090 & fac_shield(i)**2*fac_shield(j)**2
4093 c ghalf=0.5D0*ggg(k)
4094 c gelc(k,i)=gelc(k,i)+ghalf
4095 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4096 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4097 c gelc(k,j)=gelc(k,j)+ghalf
4098 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4099 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4103 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4106 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4109 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4110 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4111 & *fac_shield(i)**2*fac_shield(j)**2
4113 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4114 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4115 & *fac_shield(i)**2*fac_shield(j)**2
4116 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4117 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4119 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4123 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4124 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4125 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4127 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4128 C energy of a peptide unit is assumed in the form of a second-order
4129 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4130 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4131 C are computed for EVERY pair of non-contiguous peptide groups.
4134 if (j.lt.nres-1) then
4146 muij(kkk)=mu(k,i)*mu(l,j)
4147 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4149 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4150 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4151 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4152 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4153 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4154 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4158 cd write (iout,*) 'EELEC: i',i,' j',j
4159 cd write (iout,*) 'j',j,' j1',j1,' j2',j2
4160 cd write(iout,*) 'muij',muij
4161 ury=scalar(uy(1,i),erij)
4162 urz=scalar(uz(1,i),erij)
4163 vry=scalar(uy(1,j),erij)
4164 vrz=scalar(uz(1,j),erij)
4165 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4166 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4167 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4168 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4169 fac=dsqrt(-ael6i)*r3ij
4174 cd write (iout,'(4i5,4f10.5)')
4175 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4176 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4177 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4178 cd & uy(:,j),uz(:,j)
4179 cd write (iout,'(4f10.5)')
4180 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4181 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4182 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4183 cd write (iout,'(9f10.5/)')
4184 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4185 C Derivatives of the elements of A in virtual-bond vectors
4186 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4188 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4189 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4190 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4191 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4192 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4193 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4194 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4195 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4196 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4197 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4198 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4199 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4201 C Compute radial contributions to the gradient
4219 C Add the contributions coming from er
4222 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4223 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4224 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4225 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4228 C Derivatives in DC(i)
4229 cgrad ghalf1=0.5d0*agg(k,1)
4230 cgrad ghalf2=0.5d0*agg(k,2)
4231 cgrad ghalf3=0.5d0*agg(k,3)
4232 cgrad ghalf4=0.5d0*agg(k,4)
4233 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4234 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4235 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4236 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4237 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4238 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4239 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4240 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4241 C Derivatives in DC(i+1)
4242 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4243 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4244 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4245 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4246 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4247 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4248 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4249 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4250 C Derivatives in DC(j)
4251 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4252 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4253 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4254 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4255 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4256 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4257 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4258 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4259 C Derivatives in DC(j+1) or DC(nres-1)
4260 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4261 & -3.0d0*vryg(k,3)*ury)
4262 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4263 & -3.0d0*vrzg(k,3)*ury)
4264 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4265 & -3.0d0*vryg(k,3)*urz)
4266 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4267 & -3.0d0*vrzg(k,3)*urz)
4268 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4270 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4283 aggi(k,l)=-aggi(k,l)
4284 aggi1(k,l)=-aggi1(k,l)
4285 aggj(k,l)=-aggj(k,l)
4286 aggj1(k,l)=-aggj1(k,l)
4289 if (j.lt.nres-1) then
4295 aggi(k,l)=-aggi(k,l)
4296 aggi1(k,l)=-aggi1(k,l)
4297 aggj(k,l)=-aggj(k,l)
4298 aggj1(k,l)=-aggj1(k,l)
4309 aggi(k,l)=-aggi(k,l)
4310 aggi1(k,l)=-aggi1(k,l)
4311 aggj(k,l)=-aggj(k,l)
4312 aggj1(k,l)=-aggj1(k,l)
4317 IF (wel_loc.gt.0.0d0) THEN
4318 C Contribution to the local-electrostatic energy coming from the i-j pair
4319 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4321 if (shield_mode.eq.0) then
4328 eel_loc_ij=eel_loc_ij
4329 & *fac_shield(i)*fac_shield(j)
4330 C Now derivative over eel_loc
4331 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4332 & (shield_mode.gt.0)) then
4335 do ilist=1,ishield_list(i)
4336 iresshield=shield_list(ilist,i)
4338 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4341 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4343 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4344 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4348 do ilist=1,ishield_list(j)
4349 iresshield=shield_list(ilist,j)
4351 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4354 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4356 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4357 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4364 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4365 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4366 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4367 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4368 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4369 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4370 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4371 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4376 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4377 c & ' eel_loc_ij',eel_loc_ij
4378 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4379 C Calculate patrial derivative for theta angle
4381 geel_loc_ij=(a22*gmuij1(1)
4385 & *fac_shield(i)*fac_shield(j)
4386 c write(iout,*) "derivative over thatai"
4387 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4389 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4390 & geel_loc_ij*wel_loc
4391 c write(iout,*) "derivative over thatai-1"
4392 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4399 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4400 & geel_loc_ij*wel_loc
4401 & *fac_shield(i)*fac_shield(j)
4403 c Derivative over j residue
4404 geel_loc_ji=a22*gmuji1(1)
4408 c write(iout,*) "derivative over thataj"
4409 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4412 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4413 & geel_loc_ji*wel_loc
4414 & *fac_shield(i)*fac_shield(j)
4421 c write(iout,*) "derivative over thataj-1"
4422 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4424 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4425 & geel_loc_ji*wel_loc
4426 & *fac_shield(i)*fac_shield(j)
4428 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4430 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4431 & 'eelloc',i,j,eel_loc_ij
4432 c if (eel_loc_ij.ne.0)
4433 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4434 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4436 eel_loc=eel_loc+eel_loc_ij
4437 C Partial derivatives in virtual-bond dihedral angles gamma
4439 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4440 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4441 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4442 & *fac_shield(i)*fac_shield(j)
4444 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4445 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4446 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4447 & *fac_shield(i)*fac_shield(j)
4448 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4450 ggg(l)=(agg(l,1)*muij(1)+
4451 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4452 & *fac_shield(i)*fac_shield(j)
4453 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4454 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4455 cgrad ghalf=0.5d0*ggg(l)
4456 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4457 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4461 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4464 C Remaining derivatives of eello
4466 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4467 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4468 & *fac_shield(i)*fac_shield(j)
4470 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4471 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4472 & *fac_shield(i)*fac_shield(j)
4474 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4475 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4476 & *fac_shield(i)*fac_shield(j)
4478 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4479 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4480 & *fac_shield(i)*fac_shield(j)
4484 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4485 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4486 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4487 & .and. num_conti.le.maxconts) then
4488 c write (iout,*) i,j," entered corr"
4490 C Calculate the contact function. The ith column of the array JCONT will
4491 C contain the numbers of atoms that make contacts with the atom I (of numbers
4492 C greater than I). The arrays FACONT and GACONT will contain the values of
4493 C the contact function and its derivative.
4494 c r0ij=1.02D0*rpp(iteli,itelj)
4495 c r0ij=1.11D0*rpp(iteli,itelj)
4496 r0ij=2.20D0*rpp(iteli,itelj)
4497 c r0ij=1.55D0*rpp(iteli,itelj)
4498 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4499 if (fcont.gt.0.0D0) then
4500 num_conti=num_conti+1
4501 if (num_conti.gt.maxconts) then
4502 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4503 & ' will skip next contacts for this conf.'
4505 jcont_hb(num_conti,i)=j
4506 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4507 cd & " jcont_hb",jcont_hb(num_conti,i)
4508 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4509 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4510 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4512 d_cont(num_conti,i)=rij
4513 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4514 C --- Electrostatic-interaction matrix ---
4515 a_chuj(1,1,num_conti,i)=a22
4516 a_chuj(1,2,num_conti,i)=a23
4517 a_chuj(2,1,num_conti,i)=a32
4518 a_chuj(2,2,num_conti,i)=a33
4519 C --- Gradient of rij
4521 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4528 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4529 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4530 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4531 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4532 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4537 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4538 C Calculate contact energies
4540 wij=cosa-3.0D0*cosb*cosg
4543 c fac3=dsqrt(-ael6i)/r0ij**3
4544 fac3=dsqrt(-ael6i)*r3ij
4545 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4546 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4547 if (ees0tmp.gt.0) then
4548 ees0pij=dsqrt(ees0tmp)
4552 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4553 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4554 if (ees0tmp.gt.0) then
4555 ees0mij=dsqrt(ees0tmp)
4560 if (shield_mode.eq.0) then
4564 ees0plist(num_conti,i)=j
4565 C fac_shield(i)=0.4d0
4566 C fac_shield(j)=0.6d0
4568 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4569 & *fac_shield(i)*fac_shield(j)
4570 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4571 & *fac_shield(i)*fac_shield(j)
4572 C Diagnostics. Comment out or remove after debugging!
4573 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4574 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4575 c ees0m(num_conti,i)=0.0D0
4577 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4578 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4579 C Angular derivatives of the contact function
4580 ees0pij1=fac3/ees0pij
4581 ees0mij1=fac3/ees0mij
4582 fac3p=-3.0D0*fac3*rrmij
4583 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4584 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4586 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4587 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4588 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4589 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4590 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4591 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4592 ecosap=ecosa1+ecosa2
4593 ecosbp=ecosb1+ecosb2
4594 ecosgp=ecosg1+ecosg2
4595 ecosam=ecosa1-ecosa2
4596 ecosbm=ecosb1-ecosb2
4597 ecosgm=ecosg1-ecosg2
4606 facont_hb(num_conti,i)=fcont
4607 fprimcont=fprimcont/rij
4608 cd facont_hb(num_conti,i)=1.0D0
4609 C Following line is for diagnostics.
4612 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4613 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4616 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4617 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4619 gggp(1)=gggp(1)+ees0pijp*xj
4620 gggp(2)=gggp(2)+ees0pijp*yj
4621 gggp(3)=gggp(3)+ees0pijp*zj
4622 gggm(1)=gggm(1)+ees0mijp*xj
4623 gggm(2)=gggm(2)+ees0mijp*yj
4624 gggm(3)=gggm(3)+ees0mijp*zj
4625 C Derivatives due to the contact function
4626 gacont_hbr(1,num_conti,i)=fprimcont*xj
4627 gacont_hbr(2,num_conti,i)=fprimcont*yj
4628 gacont_hbr(3,num_conti,i)=fprimcont*zj
4631 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4632 c following the change of gradient-summation algorithm.
4634 cgrad ghalfp=0.5D0*gggp(k)
4635 cgrad ghalfm=0.5D0*gggm(k)
4636 gacontp_hb1(k,num_conti,i)=!ghalfp
4637 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4638 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4639 & *fac_shield(i)*fac_shield(j)
4641 gacontp_hb2(k,num_conti,i)=!ghalfp
4642 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4643 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4644 & *fac_shield(i)*fac_shield(j)
4646 gacontp_hb3(k,num_conti,i)=gggp(k)
4647 & *fac_shield(i)*fac_shield(j)
4649 gacontm_hb1(k,num_conti,i)=!ghalfm
4650 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4651 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4652 & *fac_shield(i)*fac_shield(j)
4654 gacontm_hb2(k,num_conti,i)=!ghalfm
4655 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4656 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4657 & *fac_shield(i)*fac_shield(j)
4659 gacontm_hb3(k,num_conti,i)=gggm(k)
4660 & *fac_shield(i)*fac_shield(j)
4663 C Diagnostics. Comment out or remove after debugging!
4665 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4666 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4667 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4668 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4669 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4670 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4673 endif ! num_conti.le.maxconts
4676 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4679 ghalf=0.5d0*agg(l,k)
4680 aggi(l,k)=aggi(l,k)+ghalf
4681 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4682 aggj(l,k)=aggj(l,k)+ghalf
4685 if (j.eq.nres-1 .and. i.lt.j-2) then
4688 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4693 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4696 C-----------------------------------------------------------------------------
4697 subroutine eturn3(i,eello_turn3)
4698 C Third- and fourth-order contributions from turns
4699 implicit real*8 (a-h,o-z)
4700 include 'DIMENSIONS'
4701 include 'COMMON.IOUNITS'
4702 include 'COMMON.GEO'
4703 include 'COMMON.VAR'
4704 include 'COMMON.LOCAL'
4705 include 'COMMON.CHAIN'
4706 include 'COMMON.DERIV'
4707 include 'COMMON.INTERACT'
4708 include 'COMMON.CONTACTS'
4709 include 'COMMON.TORSION'
4710 include 'COMMON.VECTORS'
4711 include 'COMMON.FFIELD'
4712 include 'COMMON.CONTROL'
4713 include 'COMMON.SHIELD'
4715 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4716 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4717 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4718 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4719 & auxgmat2(2,2),auxgmatt2(2,2)
4720 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4721 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4722 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4723 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4726 c write (iout,*) "eturn3",i,j,j1,j2
4731 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4733 C Third-order contributions
4740 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4741 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4742 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4743 c auxalary matices for theta gradient
4744 c auxalary matrix for i+1 and constant i+2
4745 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4746 c auxalary matrix for i+2 and constant i+1
4747 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4748 call transpose2(auxmat(1,1),auxmat1(1,1))
4749 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4750 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4751 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4752 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4753 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4754 if (shield_mode.eq.0) then
4762 C & write(iout,*) i,j,fac_shield(i),fac_shield(j)
4763 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4764 & *fac_shield(i)*fac_shield(j)
4765 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4766 & *fac_shield(i)*fac_shield(j)
4768 C Derivatives in theta
4769 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4770 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4771 & *fac_shield(i)*fac_shield(j)
4772 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4773 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4774 & *fac_shield(i)*fac_shield(j)
4777 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4778 C Derivatives in shield mode
4779 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4780 & (shield_mode.gt.0)) then
4783 do ilist=1,ishield_list(i)
4784 iresshield=shield_list(ilist,i)
4786 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4788 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4790 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4791 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4795 do ilist=1,ishield_list(j)
4796 iresshield=shield_list(ilist,j)
4798 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4800 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4802 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4803 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4810 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4811 & grad_shield(k,i)*eello_t3/fac_shield(i)
4812 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4813 & grad_shield(k,j)*eello_t3/fac_shield(j)
4814 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4815 & grad_shield(k,i)*eello_t3/fac_shield(i)
4816 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4817 & grad_shield(k,j)*eello_t3/fac_shield(j)
4821 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4822 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
4823 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
4824 cd & ' eello_turn3_num',4*eello_turn3_num
4825 C Derivatives in gamma(i)
4826 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4827 call transpose2(auxmat2(1,1),auxmat3(1,1))
4828 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4829 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4830 & *fac_shield(i)*fac_shield(j)
4831 C Derivatives in gamma(i+1)
4832 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4833 call transpose2(auxmat2(1,1),auxmat3(1,1))
4834 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4835 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4836 & +0.5d0*(pizda(1,1)+pizda(2,2))
4837 & *fac_shield(i)*fac_shield(j)
4838 C Cartesian derivatives
4840 c ghalf1=0.5d0*agg(l,1)
4841 c ghalf2=0.5d0*agg(l,2)
4842 c ghalf3=0.5d0*agg(l,3)
4843 c ghalf4=0.5d0*agg(l,4)
4844 a_temp(1,1)=aggi(l,1)!+ghalf1
4845 a_temp(1,2)=aggi(l,2)!+ghalf2
4846 a_temp(2,1)=aggi(l,3)!+ghalf3
4847 a_temp(2,2)=aggi(l,4)!+ghalf4
4848 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4849 gcorr3_turn(l,i)=gcorr3_turn(l,i)
4850 & +0.5d0*(pizda(1,1)+pizda(2,2))
4851 & *fac_shield(i)*fac_shield(j)
4853 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4854 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4855 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4856 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4857 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4858 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4859 & +0.5d0*(pizda(1,1)+pizda(2,2))
4860 & *fac_shield(i)*fac_shield(j)
4861 a_temp(1,1)=aggj(l,1)!+ghalf1
4862 a_temp(1,2)=aggj(l,2)!+ghalf2
4863 a_temp(2,1)=aggj(l,3)!+ghalf3
4864 a_temp(2,2)=aggj(l,4)!+ghalf4
4865 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4866 gcorr3_turn(l,j)=gcorr3_turn(l,j)
4867 & +0.5d0*(pizda(1,1)+pizda(2,2))
4868 & *fac_shield(i)*fac_shield(j)
4869 a_temp(1,1)=aggj1(l,1)
4870 a_temp(1,2)=aggj1(l,2)
4871 a_temp(2,1)=aggj1(l,3)
4872 a_temp(2,2)=aggj1(l,4)
4873 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4874 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4875 & +0.5d0*(pizda(1,1)+pizda(2,2))
4876 & *fac_shield(i)*fac_shield(j)
4880 C-------------------------------------------------------------------------------
4881 subroutine eturn4(i,eello_turn4)
4882 C Third- and fourth-order contributions from turns
4883 implicit real*8 (a-h,o-z)
4884 include 'DIMENSIONS'
4885 include 'COMMON.IOUNITS'
4886 include 'COMMON.GEO'
4887 include 'COMMON.VAR'
4888 include 'COMMON.LOCAL'
4889 include 'COMMON.CHAIN'
4890 include 'COMMON.DERIV'
4891 include 'COMMON.INTERACT'
4892 include 'COMMON.CONTACTS'
4893 include 'COMMON.TORSION'
4894 include 'COMMON.VECTORS'
4895 include 'COMMON.FFIELD'
4896 include 'COMMON.CONTROL'
4897 include 'COMMON.SHIELD'
4899 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4900 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4901 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4902 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4903 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
4904 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4905 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4906 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4907 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4908 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4909 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4912 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4914 C Fourth-order contributions
4922 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4923 cd call checkint_turn4(i,a_temp,eello_turn4_num)
4924 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4925 c write(iout,*)"WCHODZE W PROGRAM"
4930 iti1=itype2loc(itype(i+1))
4931 iti2=itype2loc(itype(i+2))
4932 iti3=itype2loc(itype(i+3))
4933 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4934 call transpose2(EUg(1,1,i+1),e1t(1,1))
4935 call transpose2(Eug(1,1,i+2),e2t(1,1))
4936 call transpose2(Eug(1,1,i+3),e3t(1,1))
4937 C Ematrix derivative in theta
4938 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4939 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4940 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4941 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4942 c eta1 in derivative theta
4943 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4944 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4945 c auxgvec is derivative of Ub2 so i+3 theta
4946 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4947 c auxalary matrix of E i+1
4948 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4951 s1=scalar2(b1(1,i+2),auxvec(1))
4952 c derivative of theta i+2 with constant i+3
4953 gs23=scalar2(gtb1(1,i+2),auxvec(1))
4954 c derivative of theta i+2 with constant i+2
4955 gs32=scalar2(b1(1,i+2),auxgvec(1))
4956 c derivative of E matix in theta of i+1
4957 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4959 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4960 c ea31 in derivative theta
4961 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4962 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4963 c auxilary matrix auxgvec of Ub2 with constant E matirx
4964 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
4965 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
4966 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
4970 s2=scalar2(b1(1,i+1),auxvec(1))
4971 c derivative of theta i+1 with constant i+3
4972 gs13=scalar2(gtb1(1,i+1),auxvec(1))
4973 c derivative of theta i+2 with constant i+1
4974 gs21=scalar2(b1(1,i+1),auxgvec(1))
4975 c derivative of theta i+3 with constant i+1
4976 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
4977 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
4979 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4980 c two derivatives over diffetent matrices
4981 c gtae3e2 is derivative over i+3
4982 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
4983 c ae3gte2 is derivative over i+2
4984 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
4985 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4986 c three possible derivative over theta E matices
4988 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
4990 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
4992 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
4993 s3=0.5d0*(pizda(1,1)+pizda(2,2))
4995 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
4996 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
4997 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
4998 if (shield_mode.eq.0) then
5005 eello_turn4=eello_turn4-(s1+s2+s3)
5006 & *fac_shield(i)*fac_shield(j)
5007 eello_t4=-(s1+s2+s3)
5008 & *fac_shield(i)*fac_shield(j)
5009 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5010 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5011 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5012 C Now derivative over shield:
5013 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5014 & (shield_mode.gt.0)) then
5017 do ilist=1,ishield_list(i)
5018 iresshield=shield_list(ilist,i)
5020 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5022 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5024 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5025 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5029 do ilist=1,ishield_list(j)
5030 iresshield=shield_list(ilist,j)
5032 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5034 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5036 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5037 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5044 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5045 & grad_shield(k,i)*eello_t4/fac_shield(i)
5046 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5047 & grad_shield(k,j)*eello_t4/fac_shield(j)
5048 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5049 & grad_shield(k,i)*eello_t4/fac_shield(i)
5050 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5051 & grad_shield(k,j)*eello_t4/fac_shield(j)
5060 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5061 cd & ' eello_turn4_num',8*eello_turn4_num
5063 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5064 & -(gs13+gsE13+gsEE1)*wturn4
5065 & *fac_shield(i)*fac_shield(j)
5066 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5067 & -(gs23+gs21+gsEE2)*wturn4
5068 & *fac_shield(i)*fac_shield(j)
5070 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5071 & -(gs32+gsE31+gsEE3)*wturn4
5072 & *fac_shield(i)*fac_shield(j)
5074 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5077 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5078 & 'eturn4',i,j,-(s1+s2+s3)
5079 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5080 c & ' eello_turn4_num',8*eello_turn4_num
5081 C Derivatives in gamma(i)
5082 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5083 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5084 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5085 s1=scalar2(b1(1,i+2),auxvec(1))
5086 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5087 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5088 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5089 & *fac_shield(i)*fac_shield(j)
5090 C Derivatives in gamma(i+1)
5091 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5092 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5093 s2=scalar2(b1(1,i+1),auxvec(1))
5094 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5095 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5096 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5097 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5098 & *fac_shield(i)*fac_shield(j)
5099 C Derivatives in gamma(i+2)
5100 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5101 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5102 s1=scalar2(b1(1,i+2),auxvec(1))
5103 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5104 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5105 s2=scalar2(b1(1,i+1),auxvec(1))
5106 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5107 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5108 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5109 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5110 & *fac_shield(i)*fac_shield(j)
5111 C Cartesian derivatives
5112 C Derivatives of this turn contributions in DC(i+2)
5113 if (j.lt.nres-1) then
5115 a_temp(1,1)=agg(l,1)
5116 a_temp(1,2)=agg(l,2)
5117 a_temp(2,1)=agg(l,3)
5118 a_temp(2,2)=agg(l,4)
5119 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5120 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5121 s1=scalar2(b1(1,i+2),auxvec(1))
5122 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5123 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5124 s2=scalar2(b1(1,i+1),auxvec(1))
5125 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5126 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5127 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5129 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5130 & *fac_shield(i)*fac_shield(j)
5133 C Remaining derivatives of this turn contribution
5135 a_temp(1,1)=aggi(l,1)
5136 a_temp(1,2)=aggi(l,2)
5137 a_temp(2,1)=aggi(l,3)
5138 a_temp(2,2)=aggi(l,4)
5139 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5140 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5141 s1=scalar2(b1(1,i+2),auxvec(1))
5142 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5143 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5144 s2=scalar2(b1(1,i+1),auxvec(1))
5145 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5146 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5147 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5148 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5149 & *fac_shield(i)*fac_shield(j)
5150 a_temp(1,1)=aggi1(l,1)
5151 a_temp(1,2)=aggi1(l,2)
5152 a_temp(2,1)=aggi1(l,3)
5153 a_temp(2,2)=aggi1(l,4)
5154 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5155 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5156 s1=scalar2(b1(1,i+2),auxvec(1))
5157 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5158 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5159 s2=scalar2(b1(1,i+1),auxvec(1))
5160 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5161 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5162 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5163 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5164 & *fac_shield(i)*fac_shield(j)
5165 a_temp(1,1)=aggj(l,1)
5166 a_temp(1,2)=aggj(l,2)
5167 a_temp(2,1)=aggj(l,3)
5168 a_temp(2,2)=aggj(l,4)
5169 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5170 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5171 s1=scalar2(b1(1,i+2),auxvec(1))
5172 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5173 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5174 s2=scalar2(b1(1,i+1),auxvec(1))
5175 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5176 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5177 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5178 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5179 & *fac_shield(i)*fac_shield(j)
5180 a_temp(1,1)=aggj1(l,1)
5181 a_temp(1,2)=aggj1(l,2)
5182 a_temp(2,1)=aggj1(l,3)
5183 a_temp(2,2)=aggj1(l,4)
5184 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5185 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5186 s1=scalar2(b1(1,i+2),auxvec(1))
5187 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5188 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5189 s2=scalar2(b1(1,i+1),auxvec(1))
5190 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5191 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5192 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5193 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5194 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5195 & *fac_shield(i)*fac_shield(j)
5199 C-----------------------------------------------------------------------------
5200 subroutine vecpr(u,v,w)
5201 implicit real*8(a-h,o-z)
5202 dimension u(3),v(3),w(3)
5203 w(1)=u(2)*v(3)-u(3)*v(2)
5204 w(2)=-u(1)*v(3)+u(3)*v(1)
5205 w(3)=u(1)*v(2)-u(2)*v(1)
5208 C-----------------------------------------------------------------------------
5209 subroutine unormderiv(u,ugrad,unorm,ungrad)
5210 C This subroutine computes the derivatives of a normalized vector u, given
5211 C the derivatives computed without normalization conditions, ugrad. Returns
5214 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5215 double precision vec(3)
5216 double precision scalar
5218 c write (2,*) 'ugrad',ugrad
5221 vec(i)=scalar(ugrad(1,i),u(1))
5223 c write (2,*) 'vec',vec
5226 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5229 c write (2,*) 'ungrad',ungrad
5232 C-----------------------------------------------------------------------------
5233 subroutine escp_soft_sphere(evdw2,evdw2_14)
5235 C This subroutine calculates the excluded-volume interaction energy between
5236 C peptide-group centers and side chains and its gradient in virtual-bond and
5237 C side-chain vectors.
5239 implicit real*8 (a-h,o-z)
5240 include 'DIMENSIONS'
5241 include 'COMMON.GEO'
5242 include 'COMMON.VAR'
5243 include 'COMMON.LOCAL'
5244 include 'COMMON.CHAIN'
5245 include 'COMMON.DERIV'
5246 include 'COMMON.INTERACT'
5247 include 'COMMON.FFIELD'
5248 include 'COMMON.IOUNITS'
5249 include 'COMMON.CONTROL'
5254 cd print '(a)','Enter ESCP'
5255 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5259 do i=iatscp_s,iatscp_e
5260 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5262 xi=0.5D0*(c(1,i)+c(1,i+1))
5263 yi=0.5D0*(c(2,i)+c(2,i+1))
5264 zi=0.5D0*(c(3,i)+c(3,i+1))
5265 C Return atom into box, boxxsize is size of box in x dimension
5267 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5268 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5269 C Condition for being inside the proper box
5270 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5271 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5275 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5276 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5277 C Condition for being inside the proper box
5278 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5279 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5283 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5284 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5285 cC Condition for being inside the proper box
5286 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5287 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5291 if (xi.lt.0) xi=xi+boxxsize
5293 if (yi.lt.0) yi=yi+boxysize
5295 if (zi.lt.0) zi=zi+boxzsize
5296 C xi=xi+xshift*boxxsize
5297 C yi=yi+yshift*boxysize
5298 C zi=zi+zshift*boxzsize
5299 do iint=1,nscp_gr(i)
5301 do j=iscpstart(i,iint),iscpend(i,iint)
5302 if (itype(j).eq.ntyp1) cycle
5303 itypj=iabs(itype(j))
5304 C Uncomment following three lines for SC-p interactions
5308 C Uncomment following three lines for Ca-p interactions
5313 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5314 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5315 C Condition for being inside the proper box
5316 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5317 c & (xj.lt.((-0.5d0)*boxxsize))) then
5321 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5322 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5323 cC Condition for being inside the proper box
5324 c if ((yj.gt.((0.5d0)*boxysize)).or.
5325 c & (yj.lt.((-0.5d0)*boxysize))) then
5329 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5330 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5331 C Condition for being inside the proper box
5332 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5333 c & (zj.lt.((-0.5d0)*boxzsize))) then
5336 if (xj.lt.0) xj=xj+boxxsize
5338 if (yj.lt.0) yj=yj+boxysize
5340 if (zj.lt.0) zj=zj+boxzsize
5341 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5349 xj=xj_safe+xshift*boxxsize
5350 yj=yj_safe+yshift*boxysize
5351 zj=zj_safe+zshift*boxzsize
5352 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5353 if(dist_temp.lt.dist_init) then
5363 if (subchap.eq.1) then
5376 rij=xj*xj+yj*yj+zj*zj
5380 if (rij.lt.r0ijsq) then
5381 evdwij=0.25d0*(rij-r0ijsq)**2
5389 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5394 cgrad if (j.lt.i) then
5395 cd write (iout,*) 'j<i'
5396 C Uncomment following three lines for SC-p interactions
5398 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5401 cd write (iout,*) 'j>i'
5403 cgrad ggg(k)=-ggg(k)
5404 C Uncomment following line for SC-p interactions
5405 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5409 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5411 cgrad kstart=min0(i+1,j)
5412 cgrad kend=max0(i-1,j-1)
5413 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5414 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5415 cgrad do k=kstart,kend
5417 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5421 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5422 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5433 C-----------------------------------------------------------------------------
5434 subroutine escp(evdw2,evdw2_14)
5436 C This subroutine calculates the excluded-volume interaction energy between
5437 C peptide-group centers and side chains and its gradient in virtual-bond and
5438 C side-chain vectors.
5440 implicit real*8 (a-h,o-z)
5441 include 'DIMENSIONS'
5442 include 'COMMON.GEO'
5443 include 'COMMON.VAR'
5444 include 'COMMON.LOCAL'
5445 include 'COMMON.CHAIN'
5446 include 'COMMON.DERIV'
5447 include 'COMMON.INTERACT'
5448 include 'COMMON.FFIELD'
5449 include 'COMMON.IOUNITS'
5450 include 'COMMON.CONTROL'
5451 include 'COMMON.SPLITELE'
5455 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5456 cd print '(a)','Enter ESCP'
5457 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5461 do i=iatscp_s,iatscp_e
5462 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5464 xi=0.5D0*(c(1,i)+c(1,i+1))
5465 yi=0.5D0*(c(2,i)+c(2,i+1))
5466 zi=0.5D0*(c(3,i)+c(3,i+1))
5468 if (xi.lt.0) xi=xi+boxxsize
5470 if (yi.lt.0) yi=yi+boxysize
5472 if (zi.lt.0) zi=zi+boxzsize
5473 c xi=xi+xshift*boxxsize
5474 c yi=yi+yshift*boxysize
5475 c zi=zi+zshift*boxzsize
5476 c print *,xi,yi,zi,'polozenie i'
5477 C Return atom into box, boxxsize is size of box in x dimension
5479 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5480 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5481 C Condition for being inside the proper box
5482 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5483 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5487 c print *,xi,boxxsize,"pierwszy"
5489 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5490 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5491 C Condition for being inside the proper box
5492 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5493 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5497 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5498 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5499 C Condition for being inside the proper box
5500 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5501 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5504 do iint=1,nscp_gr(i)
5506 do j=iscpstart(i,iint),iscpend(i,iint)
5507 itypj=iabs(itype(j))
5508 if (itypj.eq.ntyp1) cycle
5509 C Uncomment following three lines for SC-p interactions
5513 C Uncomment following three lines for Ca-p interactions
5518 if (xj.lt.0) xj=xj+boxxsize
5520 if (yj.lt.0) yj=yj+boxysize
5522 if (zj.lt.0) zj=zj+boxzsize
5524 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5525 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5526 C Condition for being inside the proper box
5527 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5528 c & (xj.lt.((-0.5d0)*boxxsize))) then
5532 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5533 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5534 cC Condition for being inside the proper box
5535 c if ((yj.gt.((0.5d0)*boxysize)).or.
5536 c & (yj.lt.((-0.5d0)*boxysize))) then
5540 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5541 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5542 C Condition for being inside the proper box
5543 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5544 c & (zj.lt.((-0.5d0)*boxzsize))) then
5547 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5548 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5556 xj=xj_safe+xshift*boxxsize
5557 yj=yj_safe+yshift*boxysize
5558 zj=zj_safe+zshift*boxzsize
5559 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5560 if(dist_temp.lt.dist_init) then
5570 if (subchap.eq.1) then
5579 c print *,xj,yj,zj,'polozenie j'
5580 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5582 sss=sscale(1.0d0/(dsqrt(rrij)))
5583 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5584 c if (sss.eq.0) print *,'czasem jest OK'
5585 if (sss.le.0.0d0) cycle
5586 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5588 e1=fac*fac*aad(itypj,iteli)
5589 e2=fac*bad(itypj,iteli)
5590 if (iabs(j-i) .le. 2) then
5593 evdw2_14=evdw2_14+(e1+e2)*sss
5596 evdw2=evdw2+evdwij*sss
5597 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5598 & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5601 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5603 fac=-(evdwij+e1)*rrij*sss
5604 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5608 cgrad if (j.lt.i) then
5609 cd write (iout,*) 'j<i'
5610 C Uncomment following three lines for SC-p interactions
5612 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5615 cd write (iout,*) 'j>i'
5617 cgrad ggg(k)=-ggg(k)
5618 C Uncomment following line for SC-p interactions
5619 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5620 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5624 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5626 cgrad kstart=min0(i+1,j)
5627 cgrad kend=max0(i-1,j-1)
5628 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5629 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5630 cgrad do k=kstart,kend
5632 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5636 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5637 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5639 c endif !endif for sscale cutoff
5649 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5650 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5651 gradx_scp(j,i)=expon*gradx_scp(j,i)
5654 C******************************************************************************
5658 C To save time the factor EXPON has been extracted from ALL components
5659 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5662 C******************************************************************************
5665 C--------------------------------------------------------------------------
5666 subroutine edis(ehpb)
5668 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5670 implicit real*8 (a-h,o-z)
5671 include 'DIMENSIONS'
5672 include 'COMMON.SBRIDGE'
5673 include 'COMMON.CHAIN'
5674 include 'COMMON.DERIV'
5675 include 'COMMON.VAR'
5676 include 'COMMON.INTERACT'
5677 include 'COMMON.IOUNITS'
5678 include 'COMMON.CONTROL'
5684 C write (iout,*) ,"link_end",link_end,constr_dist
5685 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5686 cd write(iout,*)'link_start=',link_start,' link_end=',link_end
5687 if (link_end.eq.0) return
5688 do i=link_start,link_end
5689 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5690 C CA-CA distance used in regularization of structure.
5693 C iii and jjj point to the residues for which the distance is assigned.
5694 if (ii.gt.nres) then
5701 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5702 c & dhpb(i),dhpb1(i),forcon(i)
5703 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5704 C distance and angle dependent SS bond potential.
5705 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5706 C & iabs(itype(jjj)).eq.1) then
5707 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5708 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5709 if (.not.dyn_ss .and. i.le.nss) then
5710 C 15/02/13 CC dynamic SSbond - additional check
5711 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5712 & iabs(itype(jjj)).eq.1) then
5713 call ssbond_ene(iii,jjj,eij)
5716 cd write (iout,*) "eij",eij
5717 cd & ' waga=',waga,' fac=',fac
5718 else if (ii.gt.nres .and. jj.gt.nres) then
5719 c Restraints from contact prediction
5721 if (constr_dist.eq.11) then
5722 ehpb=ehpb+fordepth(i)**4.0d0
5723 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5724 fac=fordepth(i)**4.0d0
5725 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5726 if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5727 & ehpb,fordepth(i),dd
5729 if (dhpb1(i).gt.0.0d0) then
5730 ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5731 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5732 c write (iout,*) "beta nmr",
5733 c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5737 C Get the force constant corresponding to this distance.
5739 C Calculate the contribution to energy.
5740 ehpb=ehpb+waga*rdis*rdis
5741 c write (iout,*) "beta reg",dd,waga*rdis*rdis
5743 C Evaluate gradient.
5749 ggg(j)=fac*(c(j,jj)-c(j,ii))
5752 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5753 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5756 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5757 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5760 C Calculate the distance between the two points and its difference from the
5763 if (constr_dist.eq.11) then
5764 ehpb=ehpb+fordepth(i)**4.0d0
5765 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5766 fac=fordepth(i)**4.0d0
5767 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5768 if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5769 & ehpb,fordepth(i),dd
5771 if (dhpb1(i).gt.0.0d0) then
5772 ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5773 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5774 c write (iout,*) "alph nmr",
5775 c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5778 C Get the force constant corresponding to this distance.
5780 C Calculate the contribution to energy.
5781 ehpb=ehpb+waga*rdis*rdis
5782 c write (iout,*) "alpha reg",dd,waga*rdis*rdis
5784 C Evaluate gradient.
5790 ggg(j)=fac*(c(j,jj)-c(j,ii))
5792 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5793 C If this is a SC-SC distance, we need to calculate the contributions to the
5794 C Cartesian gradient in the SC vectors (ghpbx).
5797 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5798 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5801 cgrad do j=iii,jjj-1
5803 cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5807 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5808 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5812 if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5815 C--------------------------------------------------------------------------
5816 subroutine ssbond_ene(i,j,eij)
5818 C Calculate the distance and angle dependent SS-bond potential energy
5819 C using a free-energy function derived based on RHF/6-31G** ab initio
5820 C calculations of diethyl disulfide.
5822 C A. Liwo and U. Kozlowska, 11/24/03
5824 implicit real*8 (a-h,o-z)
5825 include 'DIMENSIONS'
5826 include 'COMMON.SBRIDGE'
5827 include 'COMMON.CHAIN'
5828 include 'COMMON.DERIV'
5829 include 'COMMON.LOCAL'
5830 include 'COMMON.INTERACT'
5831 include 'COMMON.VAR'
5832 include 'COMMON.IOUNITS'
5833 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5834 itypi=iabs(itype(i))
5838 dxi=dc_norm(1,nres+i)
5839 dyi=dc_norm(2,nres+i)
5840 dzi=dc_norm(3,nres+i)
5841 c dsci_inv=dsc_inv(itypi)
5842 dsci_inv=vbld_inv(nres+i)
5843 itypj=iabs(itype(j))
5844 c dscj_inv=dsc_inv(itypj)
5845 dscj_inv=vbld_inv(nres+j)
5849 dxj=dc_norm(1,nres+j)
5850 dyj=dc_norm(2,nres+j)
5851 dzj=dc_norm(3,nres+j)
5852 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5857 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5858 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5859 om12=dxi*dxj+dyi*dyj+dzi*dzj
5861 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5862 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5868 deltat12=om2-om1+2.0d0
5870 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5871 & +akct*deltad*deltat12
5872 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5873 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5874 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5875 c & " deltat12",deltat12," eij",eij
5876 ed=2*akcm*deltad+akct*deltat12
5878 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5879 eom1=-2*akth*deltat1-pom1-om2*pom2
5880 eom2= 2*akth*deltat2+pom1-om1*pom2
5883 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5884 ghpbx(k,i)=ghpbx(k,i)-ggk
5885 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5886 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5887 ghpbx(k,j)=ghpbx(k,j)+ggk
5888 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5889 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5890 ghpbc(k,i)=ghpbc(k,i)-ggk
5891 ghpbc(k,j)=ghpbc(k,j)+ggk
5894 C Calculate the components of the gradient in DC and X
5898 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
5903 C--------------------------------------------------------------------------
5904 subroutine ebond(estr)
5906 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5908 implicit real*8 (a-h,o-z)
5909 include 'DIMENSIONS'
5910 include 'COMMON.LOCAL'
5911 include 'COMMON.GEO'
5912 include 'COMMON.INTERACT'
5913 include 'COMMON.DERIV'
5914 include 'COMMON.VAR'
5915 include 'COMMON.CHAIN'
5916 include 'COMMON.IOUNITS'
5917 include 'COMMON.NAMES'
5918 include 'COMMON.FFIELD'
5919 include 'COMMON.CONTROL'
5920 include 'COMMON.SETUP'
5921 double precision u(3),ud(3)
5924 do i=ibondp_start,ibondp_end
5925 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5926 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5928 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5929 c & *dc(j,i-1)/vbld(i)
5931 c if (energy_dec) write(iout,*)
5932 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5934 C Checking if it involves dummy (NH3+ or COO-) group
5935 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5936 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
5937 diff = vbld(i)-vbldpDUM
5938 if (energy_dec) write(iout,*) "dum_bond",i,diff
5940 C NO vbldp0 is the equlibrium lenght of spring for peptide group
5941 diff = vbld(i)-vbldp0
5943 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
5944 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5947 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5949 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5953 estr=0.5d0*AKP*estr+estr1
5955 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5957 do i=ibond_start,ibond_end
5959 if (iti.ne.10 .and. iti.ne.ntyp1) then
5962 diff=vbld(i+nres)-vbldsc0(1,iti)
5963 if (energy_dec) write (iout,*)
5964 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5965 & AKSC(1,iti),AKSC(1,iti)*diff*diff
5966 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5968 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5972 diff=vbld(i+nres)-vbldsc0(j,iti)
5973 ud(j)=aksc(j,iti)*diff
5974 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5988 uprod2=uprod2*u(k)*u(k)
5992 usumsqder=usumsqder+ud(j)*uprod2
5994 estr=estr+uprod/usum
5996 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6004 C--------------------------------------------------------------------------
6005 subroutine ebend(etheta,ethetacnstr)
6007 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6008 C angles gamma and its derivatives in consecutive thetas and gammas.
6010 implicit real*8 (a-h,o-z)
6011 include 'DIMENSIONS'
6012 include 'COMMON.LOCAL'
6013 include 'COMMON.GEO'
6014 include 'COMMON.INTERACT'
6015 include 'COMMON.DERIV'
6016 include 'COMMON.VAR'
6017 include 'COMMON.CHAIN'
6018 include 'COMMON.IOUNITS'
6019 include 'COMMON.NAMES'
6020 include 'COMMON.FFIELD'
6021 include 'COMMON.CONTROL'
6022 include 'COMMON.TORCNSTR'
6023 common /calcthet/ term1,term2,termm,diffak,ratak,
6024 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6025 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6026 double precision y(2),z(2)
6028 c time11=dexp(-2*time)
6031 c write (*,'(a,i2)') 'EBEND ICG=',icg
6032 do i=ithet_start,ithet_end
6033 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6034 & .or.itype(i).eq.ntyp1) cycle
6035 C Zero the energy function and its derivative at 0 or pi.
6036 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6038 ichir1=isign(1,itype(i-2))
6039 ichir2=isign(1,itype(i))
6040 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6041 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6042 if (itype(i-1).eq.10) then
6043 itype1=isign(10,itype(i-2))
6044 ichir11=isign(1,itype(i-2))
6045 ichir12=isign(1,itype(i-2))
6046 itype2=isign(10,itype(i))
6047 ichir21=isign(1,itype(i))
6048 ichir22=isign(1,itype(i))
6051 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6054 if (phii.ne.phii) phii=150.0
6064 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6067 if (phii1.ne.phii1) phii1=150.0
6079 C Calculate the "mean" value of theta from the part of the distribution
6080 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6081 C In following comments this theta will be referred to as t_c.
6082 thet_pred_mean=0.0d0
6084 athetk=athet(k,it,ichir1,ichir2)
6085 bthetk=bthet(k,it,ichir1,ichir2)
6087 athetk=athet(k,itype1,ichir11,ichir12)
6088 bthetk=bthet(k,itype2,ichir21,ichir22)
6090 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6091 c write(iout,*) 'chuj tu', y(k),z(k)
6093 dthett=thet_pred_mean*ssd
6094 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6095 C Derivatives of the "mean" values in gamma1 and gamma2.
6096 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6097 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6098 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6099 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6101 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6102 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6103 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6104 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6106 if (theta(i).gt.pi-delta) then
6107 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6109 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6110 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6111 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6113 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6115 else if (theta(i).lt.delta) then
6116 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6117 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6118 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6120 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6121 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6124 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6127 etheta=etheta+ethetai
6128 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6129 & 'ebend',i,ethetai,theta(i),itype(i)
6130 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6131 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6132 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6135 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
6136 do i=ithetaconstr_start,ithetaconstr_end
6137 itheta=itheta_constr(i)
6138 thetiii=theta(itheta)
6139 difi=pinorm(thetiii-theta_constr0(i))
6140 if (difi.gt.theta_drange(i)) then
6141 difi=difi-theta_drange(i)
6142 ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6143 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6144 & +for_thet_constr(i)*difi**3
6145 else if (difi.lt.-drange(i)) then
6147 ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6148 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6149 & +for_thet_constr(i)*difi**3
6153 if (energy_dec) then
6154 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6155 & i,itheta,rad2deg*thetiii,
6156 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
6157 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6158 & gloc(itheta+nphi-2,icg)
6162 C Ufff.... We've done all this!!!
6165 C---------------------------------------------------------------------------
6166 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6168 implicit real*8 (a-h,o-z)
6169 include 'DIMENSIONS'
6170 include 'COMMON.LOCAL'
6171 include 'COMMON.IOUNITS'
6172 common /calcthet/ term1,term2,termm,diffak,ratak,
6173 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6174 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6175 C Calculate the contributions to both Gaussian lobes.
6176 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6177 C The "polynomial part" of the "standard deviation" of this part of
6178 C the distributioni.
6179 ccc write (iout,*) thetai,thet_pred_mean
6182 sig=sig*thet_pred_mean+polthet(j,it)
6184 C Derivative of the "interior part" of the "standard deviation of the"
6185 C gamma-dependent Gaussian lobe in t_c.
6186 sigtc=3*polthet(3,it)
6188 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6191 C Set the parameters of both Gaussian lobes of the distribution.
6192 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6193 fac=sig*sig+sigc0(it)
6196 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6197 sigsqtc=-4.0D0*sigcsq*sigtc
6198 c print *,i,sig,sigtc,sigsqtc
6199 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6200 sigtc=-sigtc/(fac*fac)
6201 C Following variable is sigma(t_c)**(-2)
6202 sigcsq=sigcsq*sigcsq
6204 sig0inv=1.0D0/sig0i**2
6205 delthec=thetai-thet_pred_mean
6206 delthe0=thetai-theta0i
6207 term1=-0.5D0*sigcsq*delthec*delthec
6208 term2=-0.5D0*sig0inv*delthe0*delthe0
6209 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6210 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6211 C NaNs in taking the logarithm. We extract the largest exponent which is added
6212 C to the energy (this being the log of the distribution) at the end of energy
6213 C term evaluation for this virtual-bond angle.
6214 if (term1.gt.term2) then
6216 term2=dexp(term2-termm)
6220 term1=dexp(term1-termm)
6223 C The ratio between the gamma-independent and gamma-dependent lobes of
6224 C the distribution is a Gaussian function of thet_pred_mean too.
6225 diffak=gthet(2,it)-thet_pred_mean
6226 ratak=diffak/gthet(3,it)**2
6227 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6228 C Let's differentiate it in thet_pred_mean NOW.
6230 C Now put together the distribution terms to make complete distribution.
6231 termexp=term1+ak*term2
6232 termpre=sigc+ak*sig0i
6233 C Contribution of the bending energy from this theta is just the -log of
6234 C the sum of the contributions from the two lobes and the pre-exponential
6235 C factor. Simple enough, isn't it?
6236 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6237 C write (iout,*) 'termexp',termexp,termm,termpre,i
6238 C NOW the derivatives!!!
6239 C 6/6/97 Take into account the deformation.
6240 E_theta=(delthec*sigcsq*term1
6241 & +ak*delthe0*sig0inv*term2)/termexp
6242 E_tc=((sigtc+aktc*sig0i)/termpre
6243 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6244 & aktc*term2)/termexp)
6247 c-----------------------------------------------------------------------------
6248 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6249 implicit real*8 (a-h,o-z)
6250 include 'DIMENSIONS'
6251 include 'COMMON.LOCAL'
6252 include 'COMMON.IOUNITS'
6253 common /calcthet/ term1,term2,termm,diffak,ratak,
6254 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6255 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6256 delthec=thetai-thet_pred_mean
6257 delthe0=thetai-theta0i
6258 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6259 t3 = thetai-thet_pred_mean
6263 t14 = t12+t6*sigsqtc
6265 t21 = thetai-theta0i
6271 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6272 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6273 & *(-t12*t9-ak*sig0inv*t27)
6277 C--------------------------------------------------------------------------
6278 subroutine ebend(etheta,ethetacnstr)
6280 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6281 C angles gamma and its derivatives in consecutive thetas and gammas.
6282 C ab initio-derived potentials from
6283 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6285 implicit real*8 (a-h,o-z)
6286 include 'DIMENSIONS'
6287 include 'COMMON.LOCAL'
6288 include 'COMMON.GEO'
6289 include 'COMMON.INTERACT'
6290 include 'COMMON.DERIV'
6291 include 'COMMON.VAR'
6292 include 'COMMON.CHAIN'
6293 include 'COMMON.IOUNITS'
6294 include 'COMMON.NAMES'
6295 include 'COMMON.FFIELD'
6296 include 'COMMON.CONTROL'
6297 include 'COMMON.TORCNSTR'
6298 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6299 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6300 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6301 & sinph1ph2(maxdouble,maxdouble)
6302 logical lprn /.false./, lprn1 /.false./
6304 do i=ithet_start,ithet_end
6305 c print *,i,itype(i-1),itype(i),itype(i-2)
6306 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6307 & .or.itype(i).eq.ntyp1) cycle
6308 C print *,i,theta(i)
6309 if (iabs(itype(i+1)).eq.20) iblock=2
6310 if (iabs(itype(i+1)).ne.20) iblock=1
6314 theti2=0.5d0*theta(i)
6315 ityp2=ithetyp((itype(i-1)))
6317 coskt(k)=dcos(k*theti2)
6318 sinkt(k)=dsin(k*theti2)
6321 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6324 if (phii.ne.phii) phii=150.0
6328 ityp1=ithetyp((itype(i-2)))
6329 C propagation of chirality for glycine type
6331 cosph1(k)=dcos(k*phii)
6332 sinph1(k)=dsin(k*phii)
6337 ityp1=ithetyp((itype(i-2)))
6342 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6345 if (phii1.ne.phii1) phii1=150.0
6350 ityp3=ithetyp((itype(i)))
6352 cosph2(k)=dcos(k*phii1)
6353 sinph2(k)=dsin(k*phii1)
6357 ityp3=ithetyp((itype(i)))
6363 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6366 ccl=cosph1(l)*cosph2(k-l)
6367 ssl=sinph1(l)*sinph2(k-l)
6368 scl=sinph1(l)*cosph2(k-l)
6369 csl=cosph1(l)*sinph2(k-l)
6370 cosph1ph2(l,k)=ccl-ssl
6371 cosph1ph2(k,l)=ccl+ssl
6372 sinph1ph2(l,k)=scl+csl
6373 sinph1ph2(k,l)=scl-csl
6377 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6378 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6379 write (iout,*) "coskt and sinkt"
6381 write (iout,*) k,coskt(k),sinkt(k)
6385 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6386 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6389 & write (iout,*) "k",k,"
6390 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6391 & " ethetai",ethetai
6394 write (iout,*) "cosph and sinph"
6396 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6398 write (iout,*) "cosph1ph2 and sinph2ph2"
6401 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6402 & sinph1ph2(l,k),sinph1ph2(k,l)
6405 write(iout,*) "ethetai",ethetai
6410 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6411 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6412 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6413 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6414 ethetai=ethetai+sinkt(m)*aux
6415 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6416 dephii=dephii+k*sinkt(m)*(
6417 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6418 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6419 dephii1=dephii1+k*sinkt(m)*(
6420 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6421 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6423 & write (iout,*) "m",m," k",k," bbthet",
6424 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6425 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6426 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6427 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6428 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6431 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6432 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6433 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6434 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6436 & write(iout,*) "ethetai",ethetai
6437 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6441 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6442 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6443 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6444 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6445 ethetai=ethetai+sinkt(m)*aux
6446 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6447 dephii=dephii+l*sinkt(m)*(
6448 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6449 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6450 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6451 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6452 dephii1=dephii1+(k-l)*sinkt(m)*(
6453 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6454 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6455 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6456 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6458 write (iout,*) "m",m," k",k," l",l," ffthet",
6459 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6460 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6461 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6462 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6463 & " ethetai",ethetai
6464 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6465 & cosph1ph2(k,l)*sinkt(m),
6466 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6475 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6476 & i,theta(i)*rad2deg,phii*rad2deg,
6477 & phii1*rad2deg,ethetai
6479 etheta=etheta+ethetai
6480 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6481 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6482 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6486 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
6487 do i=ithetaconstr_start,ithetaconstr_end
6488 itheta=itheta_constr(i)
6489 thetiii=theta(itheta)
6490 difi=pinorm(thetiii-theta_constr0(i))
6491 if (difi.gt.theta_drange(i)) then
6492 difi=difi-theta_drange(i)
6493 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6494 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6495 & +for_thet_constr(i)*difi**3
6496 else if (difi.lt.-drange(i)) then
6498 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6499 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6500 & +for_thet_constr(i)*difi**3
6504 if (energy_dec) then
6505 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6506 & i,itheta,rad2deg*thetiii,
6507 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
6508 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6509 & gloc(itheta+nphi-2,icg)
6517 c-----------------------------------------------------------------------------
6518 subroutine esc(escloc)
6519 C Calculate the local energy of a side chain and its derivatives in the
6520 C corresponding virtual-bond valence angles THETA and the spherical angles
6522 implicit real*8 (a-h,o-z)
6523 include 'DIMENSIONS'
6524 include 'COMMON.GEO'
6525 include 'COMMON.LOCAL'
6526 include 'COMMON.VAR'
6527 include 'COMMON.INTERACT'
6528 include 'COMMON.DERIV'
6529 include 'COMMON.CHAIN'
6530 include 'COMMON.IOUNITS'
6531 include 'COMMON.NAMES'
6532 include 'COMMON.FFIELD'
6533 include 'COMMON.CONTROL'
6534 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6535 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6536 common /sccalc/ time11,time12,time112,theti,it,nlobit
6539 c write (iout,'(a)') 'ESC'
6540 do i=loc_start,loc_end
6542 if (it.eq.ntyp1) cycle
6543 if (it.eq.10) goto 1
6544 nlobit=nlob(iabs(it))
6545 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6546 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6547 theti=theta(i+1)-pipol
6552 if (x(2).gt.pi-delta) then
6556 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6558 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6559 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6561 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6562 & ddersc0(1),dersc(1))
6563 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6564 & ddersc0(3),dersc(3))
6566 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6568 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6569 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6570 & dersc0(2),esclocbi,dersc02)
6571 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6573 call splinthet(x(2),0.5d0*delta,ss,ssd)
6578 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6580 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6581 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6583 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6585 c write (iout,*) escloci
6586 else if (x(2).lt.delta) then
6590 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6592 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6593 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6595 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6596 & ddersc0(1),dersc(1))
6597 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6598 & ddersc0(3),dersc(3))
6600 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6602 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6603 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6604 & dersc0(2),esclocbi,dersc02)
6605 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6610 call splinthet(x(2),0.5d0*delta,ss,ssd)
6612 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6614 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6615 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6617 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6618 c write (iout,*) escloci
6620 call enesc(x,escloci,dersc,ddummy,.false.)
6623 escloc=escloc+escloci
6624 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6625 & 'escloc',i,escloci
6626 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6628 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6630 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6631 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6636 C---------------------------------------------------------------------------
6637 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6638 implicit real*8 (a-h,o-z)
6639 include 'DIMENSIONS'
6640 include 'COMMON.GEO'
6641 include 'COMMON.LOCAL'
6642 include 'COMMON.IOUNITS'
6643 common /sccalc/ time11,time12,time112,theti,it,nlobit
6644 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6645 double precision contr(maxlob,-1:1)
6647 c write (iout,*) 'it=',it,' nlobit=',nlobit
6651 if (mixed) ddersc(j)=0.0d0
6655 C Because of periodicity of the dependence of the SC energy in omega we have
6656 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6657 C To avoid underflows, first compute & store the exponents.
6665 z(k)=x(k)-censc(k,j,it)
6670 Axk=Axk+gaussc(l,k,j,it)*z(l)
6676 expfac=expfac+Ax(k,j,iii)*z(k)
6684 C As in the case of ebend, we want to avoid underflows in exponentiation and
6685 C subsequent NaNs and INFs in energy calculation.
6686 C Find the largest exponent
6690 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6694 cd print *,'it=',it,' emin=',emin
6696 C Compute the contribution to SC energy and derivatives
6701 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6702 if(adexp.ne.adexp) adexp=1.0
6705 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6707 cd print *,'j=',j,' expfac=',expfac
6708 escloc_i=escloc_i+expfac
6710 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6714 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6715 & +gaussc(k,2,j,it))*expfac
6722 dersc(1)=dersc(1)/cos(theti)**2
6723 ddersc(1)=ddersc(1)/cos(theti)**2
6726 escloci=-(dlog(escloc_i)-emin)
6728 dersc(j)=dersc(j)/escloc_i
6732 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6737 C------------------------------------------------------------------------------
6738 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6739 implicit real*8 (a-h,o-z)
6740 include 'DIMENSIONS'
6741 include 'COMMON.GEO'
6742 include 'COMMON.LOCAL'
6743 include 'COMMON.IOUNITS'
6744 common /sccalc/ time11,time12,time112,theti,it,nlobit
6745 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6746 double precision contr(maxlob)
6757 z(k)=x(k)-censc(k,j,it)
6763 Axk=Axk+gaussc(l,k,j,it)*z(l)
6769 expfac=expfac+Ax(k,j)*z(k)
6774 C As in the case of ebend, we want to avoid underflows in exponentiation and
6775 C subsequent NaNs and INFs in energy calculation.
6776 C Find the largest exponent
6779 if (emin.gt.contr(j)) emin=contr(j)
6783 C Compute the contribution to SC energy and derivatives
6787 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6788 escloc_i=escloc_i+expfac
6790 dersc(k)=dersc(k)+Ax(k,j)*expfac
6792 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6793 & +gaussc(1,2,j,it))*expfac
6797 dersc(1)=dersc(1)/cos(theti)**2
6798 dersc12=dersc12/cos(theti)**2
6799 escloci=-(dlog(escloc_i)-emin)
6801 dersc(j)=dersc(j)/escloc_i
6803 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6807 c----------------------------------------------------------------------------------
6808 subroutine esc(escloc)
6809 C Calculate the local energy of a side chain and its derivatives in the
6810 C corresponding virtual-bond valence angles THETA and the spherical angles
6811 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6812 C added by Urszula Kozlowska. 07/11/2007
6814 implicit real*8 (a-h,o-z)
6815 include 'DIMENSIONS'
6816 include 'COMMON.GEO'
6817 include 'COMMON.LOCAL'
6818 include 'COMMON.VAR'
6819 include 'COMMON.SCROT'
6820 include 'COMMON.INTERACT'
6821 include 'COMMON.DERIV'
6822 include 'COMMON.CHAIN'
6823 include 'COMMON.IOUNITS'
6824 include 'COMMON.NAMES'
6825 include 'COMMON.FFIELD'
6826 include 'COMMON.CONTROL'
6827 include 'COMMON.VECTORS'
6828 double precision x_prime(3),y_prime(3),z_prime(3)
6829 & , sumene,dsc_i,dp2_i,x(65),
6830 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6831 & de_dxx,de_dyy,de_dzz,de_dt
6832 double precision s1_t,s1_6_t,s2_t,s2_6_t
6834 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6835 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6836 & dt_dCi(3),dt_dCi1(3)
6837 common /sccalc/ time11,time12,time112,theti,it,nlobit
6840 do i=loc_start,loc_end
6841 if (itype(i).eq.ntyp1) cycle
6842 costtab(i+1) =dcos(theta(i+1))
6843 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6844 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6845 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6846 cosfac2=0.5d0/(1.0d0+costtab(i+1))
6847 cosfac=dsqrt(cosfac2)
6848 sinfac2=0.5d0/(1.0d0-costtab(i+1))
6849 sinfac=dsqrt(sinfac2)
6851 if (it.eq.10) goto 1
6853 C Compute the axes of tghe local cartesian coordinates system; store in
6854 c x_prime, y_prime and z_prime
6861 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6862 C & dc_norm(3,i+nres)
6864 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6865 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6868 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6871 c write (2,*) "x_prime",(x_prime(j),j=1,3)
6872 c write (2,*) "y_prime",(y_prime(j),j=1,3)
6873 c write (2,*) "z_prime",(z_prime(j),j=1,3)
6874 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6875 c & " xy",scalar(x_prime(1),y_prime(1)),
6876 c & " xz",scalar(x_prime(1),z_prime(1)),
6877 c & " yy",scalar(y_prime(1),y_prime(1)),
6878 c & " yz",scalar(y_prime(1),z_prime(1)),
6879 c & " zz",scalar(z_prime(1),z_prime(1))
6881 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6882 C to local coordinate system. Store in xx, yy, zz.
6888 xx = xx + x_prime(j)*dc_norm(j,i+nres)
6889 yy = yy + y_prime(j)*dc_norm(j,i+nres)
6890 zz = zz + z_prime(j)*dc_norm(j,i+nres)
6897 C Compute the energy of the ith side cbain
6899 c write (2,*) "xx",xx," yy",yy," zz",zz
6902 x(j) = sc_parmin(j,it)
6905 Cc diagnostics - remove later
6907 yy1 = dsin(alph(2))*dcos(omeg(2))
6908 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6909 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6910 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6912 C," --- ", xx_w,yy_w,zz_w
6915 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
6916 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
6918 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6919 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6921 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6922 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6923 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6924 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6925 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6927 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6928 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6929 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6930 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6931 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6933 dsc_i = 0.743d0+x(61)
6935 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6936 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6937 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6938 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6939 s1=(1+x(63))/(0.1d0 + dscp1)
6940 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6941 s2=(1+x(65))/(0.1d0 + dscp2)
6942 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6943 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6944 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6945 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6947 c & dscp1,dscp2,sumene
6948 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6949 escloc = escloc + sumene
6950 c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6955 C This section to check the numerical derivatives of the energy of ith side
6956 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6957 C #define DEBUG in the code to turn it on.
6959 write (2,*) "sumene =",sumene
6963 write (2,*) xx,yy,zz
6964 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6965 de_dxx_num=(sumenep-sumene)/aincr
6967 write (2,*) "xx+ sumene from enesc=",sumenep
6970 write (2,*) xx,yy,zz
6971 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6972 de_dyy_num=(sumenep-sumene)/aincr
6974 write (2,*) "yy+ sumene from enesc=",sumenep
6977 write (2,*) xx,yy,zz
6978 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6979 de_dzz_num=(sumenep-sumene)/aincr
6981 write (2,*) "zz+ sumene from enesc=",sumenep
6982 costsave=cost2tab(i+1)
6983 sintsave=sint2tab(i+1)
6984 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6985 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6986 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6987 de_dt_num=(sumenep-sumene)/aincr
6988 write (2,*) " t+ sumene from enesc=",sumenep
6989 cost2tab(i+1)=costsave
6990 sint2tab(i+1)=sintsave
6991 C End of diagnostics section.
6994 C Compute the gradient of esc
6996 c zz=zz*dsign(1.0,dfloat(itype(i)))
6997 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6998 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6999 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7000 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7001 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7002 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7003 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7004 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7005 pom1=(sumene3*sint2tab(i+1)+sumene1)
7006 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7007 pom2=(sumene4*cost2tab(i+1)+sumene2)
7008 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7009 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7010 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7011 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7013 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7014 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7015 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7017 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7018 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7019 & +(pom1+pom2)*pom_dx
7021 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7024 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7025 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7026 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7028 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7029 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7030 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7031 & +x(59)*zz**2 +x(60)*xx*zz
7032 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7033 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7034 & +(pom1-pom2)*pom_dy
7036 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7039 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7040 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7041 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7042 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7043 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7044 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7045 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7046 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7048 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7051 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7052 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7053 & +pom1*pom_dt1+pom2*pom_dt2
7055 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7060 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7061 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7062 cosfac2xx=cosfac2*xx
7063 sinfac2yy=sinfac2*yy
7065 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7067 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7069 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7070 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7071 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7072 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7073 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7074 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7075 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7076 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7077 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7078 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7082 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7083 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7084 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7085 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7088 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7089 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7090 dZZ_XYZ(k)=vbld_inv(i+nres)*
7091 & (z_prime(k)-zz*dC_norm(k,i+nres))
7093 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7094 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7098 dXX_Ctab(k,i)=dXX_Ci(k)
7099 dXX_C1tab(k,i)=dXX_Ci1(k)
7100 dYY_Ctab(k,i)=dYY_Ci(k)
7101 dYY_C1tab(k,i)=dYY_Ci1(k)
7102 dZZ_Ctab(k,i)=dZZ_Ci(k)
7103 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7104 dXX_XYZtab(k,i)=dXX_XYZ(k)
7105 dYY_XYZtab(k,i)=dYY_XYZ(k)
7106 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7110 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7111 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7112 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7113 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7114 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7116 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7117 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7118 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7119 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7120 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7121 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7122 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7123 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7125 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7126 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7128 C to check gradient call subroutine check_grad
7134 c------------------------------------------------------------------------------
7135 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7137 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7138 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7139 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7140 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7142 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7143 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7145 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7146 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7147 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7148 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7149 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7151 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7152 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7153 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7154 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7155 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7157 dsc_i = 0.743d0+x(61)
7159 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7160 & *(xx*cost2+yy*sint2))
7161 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7162 & *(xx*cost2-yy*sint2))
7163 s1=(1+x(63))/(0.1d0 + dscp1)
7164 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7165 s2=(1+x(65))/(0.1d0 + dscp2)
7166 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7167 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7168 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7173 c------------------------------------------------------------------------------
7174 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7176 C This procedure calculates two-body contact function g(rij) and its derivative:
7179 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7182 C where x=(rij-r0ij)/delta
7184 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7187 double precision rij,r0ij,eps0ij,fcont,fprimcont
7188 double precision x,x2,x4,delta
7192 if (x.lt.-1.0D0) then
7195 else if (x.le.1.0D0) then
7198 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7199 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7206 c------------------------------------------------------------------------------
7207 subroutine splinthet(theti,delta,ss,ssder)
7208 implicit real*8 (a-h,o-z)
7209 include 'DIMENSIONS'
7210 include 'COMMON.VAR'
7211 include 'COMMON.GEO'
7214 if (theti.gt.pipol) then
7215 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7217 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7222 c------------------------------------------------------------------------------
7223 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7225 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7226 double precision ksi,ksi2,ksi3,a1,a2,a3
7227 a1=fprim0*delta/(f1-f0)
7233 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7234 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7237 c------------------------------------------------------------------------------
7238 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7240 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7241 double precision ksi,ksi2,ksi3,a1,a2,a3
7246 a2=3*(f1x-f0x)-2*fprim0x*delta
7247 a3=fprim0x*delta-2*(f1x-f0x)
7248 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7251 C-----------------------------------------------------------------------------
7253 C-----------------------------------------------------------------------------
7254 subroutine etor(etors,edihcnstr)
7255 implicit real*8 (a-h,o-z)
7256 include 'DIMENSIONS'
7257 include 'COMMON.VAR'
7258 include 'COMMON.GEO'
7259 include 'COMMON.LOCAL'
7260 include 'COMMON.TORSION'
7261 include 'COMMON.INTERACT'
7262 include 'COMMON.DERIV'
7263 include 'COMMON.CHAIN'
7264 include 'COMMON.NAMES'
7265 include 'COMMON.IOUNITS'
7266 include 'COMMON.FFIELD'
7267 include 'COMMON.TORCNSTR'
7268 include 'COMMON.CONTROL'
7270 C Set lprn=.true. for debugging
7274 do i=iphi_start,iphi_end
7276 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7277 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7278 itori=itortyp(itype(i-2))
7279 itori1=itortyp(itype(i-1))
7282 C Proline-Proline pair is a special case...
7283 if (itori.eq.3 .and. itori1.eq.3) then
7284 if (phii.gt.-dwapi3) then
7286 fac=1.0D0/(1.0D0-cosphi)
7287 etorsi=v1(1,3,3)*fac
7288 etorsi=etorsi+etorsi
7289 etors=etors+etorsi-v1(1,3,3)
7290 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7291 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7294 v1ij=v1(j+1,itori,itori1)
7295 v2ij=v2(j+1,itori,itori1)
7298 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7299 if (energy_dec) etors_ii=etors_ii+
7300 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7301 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7305 v1ij=v1(j,itori,itori1)
7306 v2ij=v2(j,itori,itori1)
7309 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7310 if (energy_dec) etors_ii=etors_ii+
7311 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7312 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7315 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7318 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7319 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7320 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7321 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7322 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7324 ! 6/20/98 - dihedral angle constraints
7327 itori=idih_constr(i)
7330 if (difi.gt.drange(i)) then
7332 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7333 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7334 else if (difi.lt.-drange(i)) then
7336 edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7337 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7339 ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7340 ! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7342 ! write (iout,*) 'edihcnstr',edihcnstr
7345 c------------------------------------------------------------------------------
7346 subroutine etor_d(etors_d)
7350 c----------------------------------------------------------------------------
7352 subroutine etor(etors,edihcnstr)
7353 implicit real*8 (a-h,o-z)
7354 include 'DIMENSIONS'
7355 include 'COMMON.VAR'
7356 include 'COMMON.GEO'
7357 include 'COMMON.LOCAL'
7358 include 'COMMON.TORSION'
7359 include 'COMMON.INTERACT'
7360 include 'COMMON.DERIV'
7361 include 'COMMON.CHAIN'
7362 include 'COMMON.NAMES'
7363 include 'COMMON.IOUNITS'
7364 include 'COMMON.FFIELD'
7365 include 'COMMON.TORCNSTR'
7366 include 'COMMON.CONTROL'
7368 C Set lprn=.true. for debugging
7372 do i=iphi_start,iphi_end
7373 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7374 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7375 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7376 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7377 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7378 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7379 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7380 C For introducing the NH3+ and COO- group please check the etor_d for reference
7383 if (iabs(itype(i)).eq.20) then
7388 itori=itortyp(itype(i-2))
7389 itori1=itortyp(itype(i-1))
7392 C Regular cosine and sine terms
7393 do j=1,nterm(itori,itori1,iblock)
7394 v1ij=v1(j,itori,itori1,iblock)
7395 v2ij=v2(j,itori,itori1,iblock)
7398 etors=etors+v1ij*cosphi+v2ij*sinphi
7399 if (energy_dec) etors_ii=etors_ii+
7400 & v1ij*cosphi+v2ij*sinphi
7401 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7405 C E = SUM ----------------------------------- - v1
7406 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7408 cosphi=dcos(0.5d0*phii)
7409 sinphi=dsin(0.5d0*phii)
7410 do j=1,nlor(itori,itori1,iblock)
7411 vl1ij=vlor1(j,itori,itori1)
7412 vl2ij=vlor2(j,itori,itori1)
7413 vl3ij=vlor3(j,itori,itori1)
7414 pom=vl2ij*cosphi+vl3ij*sinphi
7415 pom1=1.0d0/(pom*pom+1.0d0)
7416 etors=etors+vl1ij*pom1
7417 if (energy_dec) etors_ii=etors_ii+
7420 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7422 C Subtract the constant term
7423 etors=etors-v0(itori,itori1,iblock)
7424 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7425 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7427 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7428 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7429 & (v1(j,itori,itori1,iblock),j=1,6),
7430 & (v2(j,itori,itori1,iblock),j=1,6)
7431 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7432 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7434 ! 6/20/98 - dihedral angle constraints
7436 c do i=1,ndih_constr
7437 do i=idihconstr_start,idihconstr_end
7438 itori=idih_constr(i)
7440 difi=pinorm(phii-phi0(i))
7441 if (difi.gt.drange(i)) then
7443 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7444 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7445 else if (difi.lt.-drange(i)) then
7447 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7448 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7452 if (energy_dec) then
7453 write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7454 & i,itori,rad2deg*phii,
7455 & rad2deg*phi0(i), rad2deg*drange(i),
7456 & rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7459 cd write (iout,*) 'edihcnstr',edihcnstr
7462 c----------------------------------------------------------------------------
7463 subroutine etor_d(etors_d)
7464 C 6/23/01 Compute double torsional energy
7465 implicit real*8 (a-h,o-z)
7466 include 'DIMENSIONS'
7467 include 'COMMON.VAR'
7468 include 'COMMON.GEO'
7469 include 'COMMON.LOCAL'
7470 include 'COMMON.TORSION'
7471 include 'COMMON.INTERACT'
7472 include 'COMMON.DERIV'
7473 include 'COMMON.CHAIN'
7474 include 'COMMON.NAMES'
7475 include 'COMMON.IOUNITS'
7476 include 'COMMON.FFIELD'
7477 include 'COMMON.TORCNSTR'
7479 C Set lprn=.true. for debugging
7483 c write(iout,*) "a tu??"
7484 do i=iphid_start,iphid_end
7485 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7486 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7487 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7488 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7489 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7490 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7491 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7492 & (itype(i+1).eq.ntyp1)) cycle
7493 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7494 itori=itortyp(itype(i-2))
7495 itori1=itortyp(itype(i-1))
7496 itori2=itortyp(itype(i))
7502 if (iabs(itype(i+1)).eq.20) iblock=2
7503 C Iblock=2 Proline type
7504 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7505 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7506 C if (itype(i+1).eq.ntyp1) iblock=3
7507 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7508 C IS or IS NOT need for this
7509 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7510 C is (itype(i-3).eq.ntyp1) ntblock=2
7511 C ntblock is N-terminal blocking group
7513 C Regular cosine and sine terms
7514 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7515 C Example of changes for NH3+ blocking group
7516 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7517 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7518 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7519 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7520 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7521 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7522 cosphi1=dcos(j*phii)
7523 sinphi1=dsin(j*phii)
7524 cosphi2=dcos(j*phii1)
7525 sinphi2=dsin(j*phii1)
7526 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7527 & v2cij*cosphi2+v2sij*sinphi2
7528 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7529 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7531 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7533 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7534 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7535 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7536 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7537 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7538 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7539 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7540 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7541 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7542 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7543 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7544 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7545 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7546 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7549 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7550 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7555 C----------------------------------------------------------------------------------
7556 C The rigorous attempt to derive energy function
7557 subroutine etor_kcc(etors,edihcnstr)
7558 implicit real*8 (a-h,o-z)
7559 include 'DIMENSIONS'
7560 include 'COMMON.VAR'
7561 include 'COMMON.GEO'
7562 include 'COMMON.LOCAL'
7563 include 'COMMON.TORSION'
7564 include 'COMMON.INTERACT'
7565 include 'COMMON.DERIV'
7566 include 'COMMON.CHAIN'
7567 include 'COMMON.NAMES'
7568 include 'COMMON.IOUNITS'
7569 include 'COMMON.FFIELD'
7570 include 'COMMON.TORCNSTR'
7571 include 'COMMON.CONTROL'
7573 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7574 C Set lprn=.true. for debugging
7577 C print *,"wchodze kcc"
7578 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7579 if (tor_mode.ne.2) then
7582 do i=iphi_start,iphi_end
7583 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7584 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7585 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7586 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7587 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7588 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7589 itori=itortyp_kcc(itype(i-2))
7590 itori1=itortyp_kcc(itype(i-1))
7595 sumnonchebyshev=0.0d0
7597 C to avoid multiple devision by 2
7598 c theti22=0.5d0*theta(i)
7599 C theta 12 is the theta_1 /2
7600 C theta 22 is theta_2 /2
7601 c theti12=0.5d0*theta(i-1)
7602 C and appropriate sinus function
7603 sinthet1=dsin(theta(i-1))
7604 sinthet2=dsin(theta(i))
7605 costhet1=dcos(theta(i-1))
7606 costhet2=dcos(theta(i))
7607 c Cosines of halves thetas
7608 costheti12=0.5d0*(1.0d0+costhet1)
7609 costheti22=0.5d0*(1.0d0+costhet2)
7610 C to speed up lets store its mutliplication
7611 sint1t2=sinthet2*sinthet1
7613 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7614 C +d_n*sin(n*gamma)) *
7615 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7616 C we have two sum 1) Non-Chebyshev which is with n and gamma
7618 do j=1,nterm_kcc(itori,itori1)
7620 nval=nterm_kcc_Tb(itori,itori1)
7621 v1ij=v1_kcc(j,itori,itori1)
7622 v2ij=v2_kcc(j,itori,itori1)
7623 c write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7624 C v1ij is c_n and d_n in euation above
7628 sint1t2n=sint1t2n*sint1t2
7629 sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7631 gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7632 & v11_chyb(1,j,itori,itori1),costheti12)
7633 c write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7634 c & " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7635 sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7637 gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7638 & v21_chyb(1,j,itori,itori1),costheti22)
7639 c write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7640 c & " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7641 sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7643 gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7644 & v12_chyb(1,j,itori,itori1),costheti12)
7645 c write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7646 c & " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7647 sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7649 gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7650 & v22_chyb(1,j,itori,itori1),costheti22)
7651 c write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7652 c & " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7653 C etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7654 C if (energy_dec) etors_ii=etors_ii+
7655 C & v1ij*cosphi+v2ij*sinphi
7656 C glocig is the gradient local i site in gamma
7657 actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7658 actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7659 etori=etori+sint1t2n*(actval1+actval2)
7661 & j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7662 & -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7663 C now gradient over theta_1
7665 & j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7666 & sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7668 & j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7669 & sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7671 C now the Czebyshev polinominal sum
7672 c do k=1,nterm_kcc_Tb(itori,itori1)
7673 c thybt1(k)=v1_chyb(k,j,itori,itori1)
7674 c thybt2(k)=v2_chyb(k,j,itori,itori1)
7678 C print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7680 C & (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7681 C & dcos(theti22)**2),
7684 C now overal sumation
7685 C print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7688 C derivative over gamma
7689 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7690 C derivative over theta1
7691 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7692 C now derivative over theta2
7693 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7695 & write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7696 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7698 C gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7699 ! 6/20/98 - dihedral angle constraints
7700 if (tor_mode.ne.2) then
7702 c do i=1,ndih_constr
7703 do i=idihconstr_start,idihconstr_end
7704 itori=idih_constr(i)
7706 difi=pinorm(phii-phi0(i))
7707 if (difi.gt.drange(i)) then
7709 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7710 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7711 else if (difi.lt.-drange(i)) then
7713 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7714 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7723 C The rigorous attempt to derive energy function
7724 subroutine ebend_kcc(etheta,ethetacnstr)
7726 implicit real*8 (a-h,o-z)
7727 include 'DIMENSIONS'
7728 include 'COMMON.VAR'
7729 include 'COMMON.GEO'
7730 include 'COMMON.LOCAL'
7731 include 'COMMON.TORSION'
7732 include 'COMMON.INTERACT'
7733 include 'COMMON.DERIV'
7734 include 'COMMON.CHAIN'
7735 include 'COMMON.NAMES'
7736 include 'COMMON.IOUNITS'
7737 include 'COMMON.FFIELD'
7738 include 'COMMON.TORCNSTR'
7739 include 'COMMON.CONTROL'
7741 double precision thybt1(maxtermkcc)
7742 C Set lprn=.true. for debugging
7745 C print *,"wchodze kcc"
7746 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7747 if (tor_mode.ne.2) etheta=0.0D0
7748 do i=ithet_start,ithet_end
7749 c print *,i,itype(i-1),itype(i),itype(i-2)
7750 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7751 & .or.itype(i).eq.ntyp1) cycle
7752 iti=itortyp_kcc(itype(i-1))
7753 sinthet=dsin(theta(i)/2.0d0)
7754 costhet=dcos(theta(i)/2.0d0)
7755 do j=1,nbend_kcc_Tb(iti)
7756 thybt1(j)=v1bend_chyb(j,iti)
7758 sumth1thyb=tschebyshev
7759 & (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7760 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7762 ihelp=nbend_kcc_Tb(iti)-1
7763 gradthybt1=gradtschebyshev
7764 & (0,ihelp,thybt1(1),costhet)
7765 etheta=etheta+sumth1thyb
7766 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7767 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
7768 & gradthybt1*sinthet*(-0.5d0)
7770 if (tor_mode.ne.2) then
7772 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
7773 do i=ithetaconstr_start,ithetaconstr_end
7774 itheta=itheta_constr(i)
7775 thetiii=theta(itheta)
7776 difi=pinorm(thetiii-theta_constr0(i))
7777 if (difi.gt.theta_drange(i)) then
7778 difi=difi-theta_drange(i)
7779 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7780 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7781 & +for_thet_constr(i)*difi**3
7782 else if (difi.lt.-drange(i)) then
7784 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7785 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7786 & +for_thet_constr(i)*difi**3
7790 if (energy_dec) then
7791 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7792 & i,itheta,rad2deg*thetiii,
7793 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
7794 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7795 & gloc(itheta+nphi-2,icg)
7801 c------------------------------------------------------------------------------
7802 subroutine eback_sc_corr(esccor)
7803 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7804 c conformational states; temporarily implemented as differences
7805 c between UNRES torsional potentials (dependent on three types of
7806 c residues) and the torsional potentials dependent on all 20 types
7807 c of residues computed from AM1 energy surfaces of terminally-blocked
7808 c amino-acid residues.
7809 implicit real*8 (a-h,o-z)
7810 include 'DIMENSIONS'
7811 include 'COMMON.VAR'
7812 include 'COMMON.GEO'
7813 include 'COMMON.LOCAL'
7814 include 'COMMON.TORSION'
7815 include 'COMMON.SCCOR'
7816 include 'COMMON.INTERACT'
7817 include 'COMMON.DERIV'
7818 include 'COMMON.CHAIN'
7819 include 'COMMON.NAMES'
7820 include 'COMMON.IOUNITS'
7821 include 'COMMON.FFIELD'
7822 include 'COMMON.CONTROL'
7824 C Set lprn=.true. for debugging
7827 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7829 do i=itau_start,itau_end
7830 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7832 isccori=isccortyp(itype(i-2))
7833 isccori1=isccortyp(itype(i-1))
7834 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7836 do intertyp=1,3 !intertyp
7837 cc Added 09 May 2012 (Adasko)
7838 cc Intertyp means interaction type of backbone mainchain correlation:
7839 c 1 = SC...Ca...Ca...Ca
7840 c 2 = Ca...Ca...Ca...SC
7841 c 3 = SC...Ca...Ca...SCi
7843 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7844 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7845 & (itype(i-1).eq.ntyp1)))
7846 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7847 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7848 & .or.(itype(i).eq.ntyp1)))
7849 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7850 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7851 & (itype(i-3).eq.ntyp1)))) cycle
7852 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7853 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7855 do j=1,nterm_sccor(isccori,isccori1)
7856 v1ij=v1sccor(j,intertyp,isccori,isccori1)
7857 v2ij=v2sccor(j,intertyp,isccori,isccori1)
7858 cosphi=dcos(j*tauangle(intertyp,i))
7859 sinphi=dsin(j*tauangle(intertyp,i))
7860 esccor=esccor+v1ij*cosphi+v2ij*sinphi
7861 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7863 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7864 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7866 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7867 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7868 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7869 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7870 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7876 c----------------------------------------------------------------------------
7877 subroutine multibody(ecorr)
7878 C This subroutine calculates multi-body contributions to energy following
7879 C the idea of Skolnick et al. If side chains I and J make a contact and
7880 C at the same time side chains I+1 and J+1 make a contact, an extra
7881 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7882 implicit real*8 (a-h,o-z)
7883 include 'DIMENSIONS'
7884 include 'COMMON.IOUNITS'
7885 include 'COMMON.DERIV'
7886 include 'COMMON.INTERACT'
7887 include 'COMMON.CONTACTS'
7888 double precision gx(3),gx1(3)
7891 C Set lprn=.true. for debugging
7895 write (iout,'(a)') 'Contact function values:'
7897 write (iout,'(i2,20(1x,i2,f10.5))')
7898 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7913 num_conti=num_cont(i)
7914 num_conti1=num_cont(i1)
7919 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7920 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7921 cd & ' ishift=',ishift
7922 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7923 C The system gains extra energy.
7924 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7925 endif ! j1==j+-ishift
7934 c------------------------------------------------------------------------------
7935 double precision function esccorr(i,j,k,l,jj,kk)
7936 implicit real*8 (a-h,o-z)
7937 include 'DIMENSIONS'
7938 include 'COMMON.IOUNITS'
7939 include 'COMMON.DERIV'
7940 include 'COMMON.INTERACT'
7941 include 'COMMON.CONTACTS'
7942 include 'COMMON.SHIELD'
7943 double precision gx(3),gx1(3)
7948 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7949 C Calculate the multi-body contribution to energy.
7950 C Calculate multi-body contributions to the gradient.
7951 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7952 cd & k,l,(gacont(m,kk,k),m=1,3)
7954 gx(m) =ekl*gacont(m,jj,i)
7955 gx1(m)=eij*gacont(m,kk,k)
7956 gradxorr(m,i)=gradxorr(m,i)-gx(m)
7957 gradxorr(m,j)=gradxorr(m,j)+gx(m)
7958 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7959 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7963 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7968 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7974 c------------------------------------------------------------------------------
7975 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7976 C This subroutine calculates multi-body contributions to hydrogen-bonding
7977 implicit real*8 (a-h,o-z)
7978 include 'DIMENSIONS'
7979 include 'COMMON.IOUNITS'
7982 parameter (max_cont=maxconts)
7983 parameter (max_dim=26)
7984 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7985 double precision zapas(max_dim,maxconts,max_fg_procs),
7986 & zapas_recv(max_dim,maxconts,max_fg_procs)
7987 common /przechowalnia/ zapas
7988 integer status(MPI_STATUS_SIZE),req(maxconts*2),
7989 & status_array(MPI_STATUS_SIZE,maxconts*2)
7991 include 'COMMON.SETUP'
7992 include 'COMMON.FFIELD'
7993 include 'COMMON.DERIV'
7994 include 'COMMON.INTERACT'
7995 include 'COMMON.CONTACTS'
7996 include 'COMMON.CONTROL'
7997 include 'COMMON.LOCAL'
7998 double precision gx(3),gx1(3),time00
8001 C Set lprn=.true. for debugging
8006 if (nfgtasks.le.1) goto 30
8008 write (iout,'(a)') 'Contact function values before RECEIVE:'
8010 write (iout,'(2i3,50(1x,i2,f5.2))')
8011 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8012 & j=1,num_cont_hb(i))
8016 do i=1,ntask_cont_from
8019 do i=1,ntask_cont_to
8022 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8024 C Make the list of contacts to send to send to other procesors
8025 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8027 do i=iturn3_start,iturn3_end
8028 c write (iout,*) "make contact list turn3",i," num_cont",
8030 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8032 do i=iturn4_start,iturn4_end
8033 c write (iout,*) "make contact list turn4",i," num_cont",
8035 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8039 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8041 do j=1,num_cont_hb(i)
8044 iproc=iint_sent_local(k,jjc,ii)
8045 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8046 if (iproc.gt.0) then
8047 ncont_sent(iproc)=ncont_sent(iproc)+1
8048 nn=ncont_sent(iproc)
8050 zapas(2,nn,iproc)=jjc
8051 zapas(3,nn,iproc)=facont_hb(j,i)
8052 zapas(4,nn,iproc)=ees0p(j,i)
8053 zapas(5,nn,iproc)=ees0m(j,i)
8054 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8055 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8056 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8057 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8058 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8059 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8060 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8061 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8062 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8063 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8064 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8065 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8066 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8067 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8068 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8069 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8070 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8071 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8072 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8073 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8074 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8081 & "Numbers of contacts to be sent to other processors",
8082 & (ncont_sent(i),i=1,ntask_cont_to)
8083 write (iout,*) "Contacts sent"
8084 do ii=1,ntask_cont_to
8086 iproc=itask_cont_to(ii)
8087 write (iout,*) nn," contacts to processor",iproc,
8088 & " of CONT_TO_COMM group"
8090 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8098 CorrelID1=nfgtasks+fg_rank+1
8100 C Receive the numbers of needed contacts from other processors
8101 do ii=1,ntask_cont_from
8102 iproc=itask_cont_from(ii)
8104 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8105 & FG_COMM,req(ireq),IERR)
8107 c write (iout,*) "IRECV ended"
8109 C Send the number of contacts needed by other processors
8110 do ii=1,ntask_cont_to
8111 iproc=itask_cont_to(ii)
8113 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8114 & FG_COMM,req(ireq),IERR)
8116 c write (iout,*) "ISEND ended"
8117 c write (iout,*) "number of requests (nn)",ireq
8120 & call MPI_Waitall(ireq,req,status_array,ierr)
8122 c & "Numbers of contacts to be received from other processors",
8123 c & (ncont_recv(i),i=1,ntask_cont_from)
8127 do ii=1,ntask_cont_from
8128 iproc=itask_cont_from(ii)
8130 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8131 c & " of CONT_TO_COMM group"
8135 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8136 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8137 c write (iout,*) "ireq,req",ireq,req(ireq)
8140 C Send the contacts to processors that need them
8141 do ii=1,ntask_cont_to
8142 iproc=itask_cont_to(ii)
8144 c write (iout,*) nn," contacts to processor",iproc,
8145 c & " of CONT_TO_COMM group"
8148 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8149 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8150 c write (iout,*) "ireq,req",ireq,req(ireq)
8152 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8156 c write (iout,*) "number of requests (contacts)",ireq
8157 c write (iout,*) "req",(req(i),i=1,4)
8160 & call MPI_Waitall(ireq,req,status_array,ierr)
8161 do iii=1,ntask_cont_from
8162 iproc=itask_cont_from(iii)
8165 write (iout,*) "Received",nn," contacts from processor",iproc,
8166 & " of CONT_FROM_COMM group"
8169 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8174 ii=zapas_recv(1,i,iii)
8175 c Flag the received contacts to prevent double-counting
8176 jj=-zapas_recv(2,i,iii)
8177 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8179 nnn=num_cont_hb(ii)+1
8182 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8183 ees0p(nnn,ii)=zapas_recv(4,i,iii)
8184 ees0m(nnn,ii)=zapas_recv(5,i,iii)
8185 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8186 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8187 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8188 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8189 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8190 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8191 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8192 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8193 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8194 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8195 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8196 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8197 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8198 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8199 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8200 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8201 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8202 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8203 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8204 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8205 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8210 write (iout,'(a)') 'Contact function values after receive:'
8212 write (iout,'(2i3,50(1x,i3,f5.2))')
8213 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8214 & j=1,num_cont_hb(i))
8221 write (iout,'(a)') 'Contact function values:'
8223 write (iout,'(2i3,50(1x,i3,f5.2))')
8224 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8225 & j=1,num_cont_hb(i))
8229 C Remove the loop below after debugging !!!
8236 C Calculate the local-electrostatic correlation terms
8237 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8239 num_conti=num_cont_hb(i)
8240 num_conti1=num_cont_hb(i+1)
8247 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8248 c & ' jj=',jj,' kk=',kk
8249 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8250 & .or. j.lt.0 .and. j1.gt.0) .and.
8251 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8252 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8253 C The system gains extra energy.
8254 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8255 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8256 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8258 else if (j1.eq.j) then
8259 C Contacts I-J and I-(J+1) occur simultaneously.
8260 C The system loses extra energy.
8261 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8266 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8267 c & ' jj=',jj,' kk=',kk
8269 C Contacts I-J and (I+1)-J occur simultaneously.
8270 C The system loses extra energy.
8271 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8278 c------------------------------------------------------------------------------
8279 subroutine add_hb_contact(ii,jj,itask)
8280 implicit real*8 (a-h,o-z)
8281 include "DIMENSIONS"
8282 include "COMMON.IOUNITS"
8285 parameter (max_cont=maxconts)
8286 parameter (max_dim=26)
8287 include "COMMON.CONTACTS"
8288 double precision zapas(max_dim,maxconts,max_fg_procs),
8289 & zapas_recv(max_dim,maxconts,max_fg_procs)
8290 common /przechowalnia/ zapas
8291 integer i,j,ii,jj,iproc,itask(4),nn
8292 c write (iout,*) "itask",itask
8295 if (iproc.gt.0) then
8296 do j=1,num_cont_hb(ii)
8298 c write (iout,*) "i",ii," j",jj," jjc",jjc
8300 ncont_sent(iproc)=ncont_sent(iproc)+1
8301 nn=ncont_sent(iproc)
8302 zapas(1,nn,iproc)=ii
8303 zapas(2,nn,iproc)=jjc
8304 zapas(3,nn,iproc)=facont_hb(j,ii)
8305 zapas(4,nn,iproc)=ees0p(j,ii)
8306 zapas(5,nn,iproc)=ees0m(j,ii)
8307 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8308 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8309 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8310 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8311 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8312 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8313 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8314 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8315 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8316 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8317 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8318 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8319 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8320 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8321 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8322 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8323 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8324 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8325 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8326 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8327 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8335 c------------------------------------------------------------------------------
8336 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8338 C This subroutine calculates multi-body contributions to hydrogen-bonding
8339 implicit real*8 (a-h,o-z)
8340 include 'DIMENSIONS'
8341 include 'COMMON.IOUNITS'
8344 parameter (max_cont=maxconts)
8345 parameter (max_dim=70)
8346 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8347 double precision zapas(max_dim,maxconts,max_fg_procs),
8348 & zapas_recv(max_dim,maxconts,max_fg_procs)
8349 common /przechowalnia/ zapas
8350 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8351 & status_array(MPI_STATUS_SIZE,maxconts*2)
8353 include 'COMMON.SETUP'
8354 include 'COMMON.FFIELD'
8355 include 'COMMON.DERIV'
8356 include 'COMMON.LOCAL'
8357 include 'COMMON.INTERACT'
8358 include 'COMMON.CONTACTS'
8359 include 'COMMON.CHAIN'
8360 include 'COMMON.CONTROL'
8361 include 'COMMON.SHIELD'
8362 double precision gx(3),gx1(3)
8363 integer num_cont_hb_old(maxres)
8365 double precision eello4,eello5,eelo6,eello_turn6
8366 external eello4,eello5,eello6,eello_turn6
8367 C Set lprn=.true. for debugging
8372 num_cont_hb_old(i)=num_cont_hb(i)
8376 if (nfgtasks.le.1) goto 30
8378 write (iout,'(a)') 'Contact function values before RECEIVE:'
8380 write (iout,'(2i3,50(1x,i2,f5.2))')
8381 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8382 & j=1,num_cont_hb(i))
8386 do i=1,ntask_cont_from
8389 do i=1,ntask_cont_to
8392 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8394 C Make the list of contacts to send to send to other procesors
8395 do i=iturn3_start,iturn3_end
8396 c write (iout,*) "make contact list turn3",i," num_cont",
8398 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8400 do i=iturn4_start,iturn4_end
8401 c write (iout,*) "make contact list turn4",i," num_cont",
8403 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8407 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8409 do j=1,num_cont_hb(i)
8412 iproc=iint_sent_local(k,jjc,ii)
8413 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8414 if (iproc.ne.0) then
8415 ncont_sent(iproc)=ncont_sent(iproc)+1
8416 nn=ncont_sent(iproc)
8418 zapas(2,nn,iproc)=jjc
8419 zapas(3,nn,iproc)=d_cont(j,i)
8423 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8428 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8436 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8447 & "Numbers of contacts to be sent to other processors",
8448 & (ncont_sent(i),i=1,ntask_cont_to)
8449 write (iout,*) "Contacts sent"
8450 do ii=1,ntask_cont_to
8452 iproc=itask_cont_to(ii)
8453 write (iout,*) nn," contacts to processor",iproc,
8454 & " of CONT_TO_COMM group"
8456 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8464 CorrelID1=nfgtasks+fg_rank+1
8466 C Receive the numbers of needed contacts from other processors
8467 do ii=1,ntask_cont_from
8468 iproc=itask_cont_from(ii)
8470 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8471 & FG_COMM,req(ireq),IERR)
8473 c write (iout,*) "IRECV ended"
8475 C Send the number of contacts needed by other processors
8476 do ii=1,ntask_cont_to
8477 iproc=itask_cont_to(ii)
8479 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8480 & FG_COMM,req(ireq),IERR)
8482 c write (iout,*) "ISEND ended"
8483 c write (iout,*) "number of requests (nn)",ireq
8486 & call MPI_Waitall(ireq,req,status_array,ierr)
8488 c & "Numbers of contacts to be received from other processors",
8489 c & (ncont_recv(i),i=1,ntask_cont_from)
8493 do ii=1,ntask_cont_from
8494 iproc=itask_cont_from(ii)
8496 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8497 c & " of CONT_TO_COMM group"
8501 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8502 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8503 c write (iout,*) "ireq,req",ireq,req(ireq)
8506 C Send the contacts to processors that need them
8507 do ii=1,ntask_cont_to
8508 iproc=itask_cont_to(ii)
8510 c write (iout,*) nn," contacts to processor",iproc,
8511 c & " of CONT_TO_COMM group"
8514 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8515 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8516 c write (iout,*) "ireq,req",ireq,req(ireq)
8518 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8522 c write (iout,*) "number of requests (contacts)",ireq
8523 c write (iout,*) "req",(req(i),i=1,4)
8526 & call MPI_Waitall(ireq,req,status_array,ierr)
8527 do iii=1,ntask_cont_from
8528 iproc=itask_cont_from(iii)
8531 write (iout,*) "Received",nn," contacts from processor",iproc,
8532 & " of CONT_FROM_COMM group"
8535 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8540 ii=zapas_recv(1,i,iii)
8541 c Flag the received contacts to prevent double-counting
8542 jj=-zapas_recv(2,i,iii)
8543 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8545 nnn=num_cont_hb(ii)+1
8548 d_cont(nnn,ii)=zapas_recv(3,i,iii)
8552 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8557 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8565 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8574 write (iout,'(a)') 'Contact function values after receive:'
8576 write (iout,'(2i3,50(1x,i3,5f6.3))')
8577 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8578 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8585 write (iout,'(a)') 'Contact function values:'
8587 write (iout,'(2i3,50(1x,i2,5f6.3))')
8588 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8589 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8595 C Remove the loop below after debugging !!!
8602 C Calculate the dipole-dipole interaction energies
8603 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8604 do i=iatel_s,iatel_e+1
8605 num_conti=num_cont_hb(i)
8614 C Calculate the local-electrostatic correlation terms
8615 c write (iout,*) "gradcorr5 in eello5 before loop"
8617 c write (iout,'(i5,3f10.5)')
8618 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8620 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8621 c write (iout,*) "corr loop i",i
8623 num_conti=num_cont_hb(i)
8624 num_conti1=num_cont_hb(i+1)
8631 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8632 c & ' jj=',jj,' kk=',kk
8633 c if (j1.eq.j+1 .or. j1.eq.j-1) then
8634 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8635 & .or. j.lt.0 .and. j1.gt.0) .and.
8636 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8637 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8638 C The system gains extra energy.
8640 sqd1=dsqrt(d_cont(jj,i))
8641 sqd2=dsqrt(d_cont(kk,i1))
8642 sred_geom = sqd1*sqd2
8643 IF (sred_geom.lt.cutoff_corr) THEN
8644 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8646 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8647 cd & ' jj=',jj,' kk=',kk
8648 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8649 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8651 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8652 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8655 cd write (iout,*) 'sred_geom=',sred_geom,
8656 cd & ' ekont=',ekont,' fprim=',fprimcont,
8657 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8658 cd write (iout,*) "g_contij",g_contij
8659 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8660 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8661 call calc_eello(i,jp,i+1,jp1,jj,kk)
8662 if (wcorr4.gt.0.0d0)
8663 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8664 CC & *fac_shield(i)**2*fac_shield(j)**2
8665 if (energy_dec.and.wcorr4.gt.0.0d0)
8666 1 write (iout,'(a6,4i5,0pf7.3)')
8667 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8668 c write (iout,*) "gradcorr5 before eello5"
8670 c write (iout,'(i5,3f10.5)')
8671 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8673 if (wcorr5.gt.0.0d0)
8674 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8675 c write (iout,*) "gradcorr5 after eello5"
8677 c write (iout,'(i5,3f10.5)')
8678 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8680 if (energy_dec.and.wcorr5.gt.0.0d0)
8681 1 write (iout,'(a6,4i5,0pf7.3)')
8682 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8683 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8684 cd write(2,*)'ijkl',i,jp,i+1,jp1
8685 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8686 & .or. wturn6.eq.0.0d0))then
8687 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8688 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8689 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8690 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8691 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8692 cd & 'ecorr6=',ecorr6
8693 cd write (iout,'(4e15.5)') sred_geom,
8694 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8695 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8696 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
8697 else if (wturn6.gt.0.0d0
8698 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8699 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8700 eturn6=eturn6+eello_turn6(i,jj,kk)
8701 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8702 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8703 cd write (2,*) 'multibody_eello:eturn6',eturn6
8712 num_cont_hb(i)=num_cont_hb_old(i)
8714 c write (iout,*) "gradcorr5 in eello5"
8716 c write (iout,'(i5,3f10.5)')
8717 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8721 c------------------------------------------------------------------------------
8722 subroutine add_hb_contact_eello(ii,jj,itask)
8723 implicit real*8 (a-h,o-z)
8724 include "DIMENSIONS"
8725 include "COMMON.IOUNITS"
8728 parameter (max_cont=maxconts)
8729 parameter (max_dim=70)
8730 include "COMMON.CONTACTS"
8731 double precision zapas(max_dim,maxconts,max_fg_procs),
8732 & zapas_recv(max_dim,maxconts,max_fg_procs)
8733 common /przechowalnia/ zapas
8734 integer i,j,ii,jj,iproc,itask(4),nn
8735 c write (iout,*) "itask",itask
8738 if (iproc.gt.0) then
8739 do j=1,num_cont_hb(ii)
8741 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8743 ncont_sent(iproc)=ncont_sent(iproc)+1
8744 nn=ncont_sent(iproc)
8745 zapas(1,nn,iproc)=ii
8746 zapas(2,nn,iproc)=jjc
8747 zapas(3,nn,iproc)=d_cont(j,ii)
8751 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8756 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8764 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8776 c------------------------------------------------------------------------------
8777 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8778 implicit real*8 (a-h,o-z)
8779 include 'DIMENSIONS'
8780 include 'COMMON.IOUNITS'
8781 include 'COMMON.DERIV'
8782 include 'COMMON.INTERACT'
8783 include 'COMMON.CONTACTS'
8784 include 'COMMON.SHIELD'
8785 include 'COMMON.CONTROL'
8786 double precision gx(3),gx1(3)
8789 C print *,"wchodze",fac_shield(i),shield_mode
8797 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8799 C & fac_shield(i)**2*fac_shield(j)**2
8800 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8801 C Following 4 lines for diagnostics.
8806 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8807 c & 'Contacts ',i,j,
8808 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8809 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8811 C Calculate the multi-body contribution to energy.
8812 C ecorr=ecorr+ekont*ees
8813 C Calculate multi-body contributions to the gradient.
8814 coeffpees0pij=coeffp*ees0pij
8815 coeffmees0mij=coeffm*ees0mij
8816 coeffpees0pkl=coeffp*ees0pkl
8817 coeffmees0mkl=coeffm*ees0mkl
8819 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8820 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8821 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8822 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
8823 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8824 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8825 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
8826 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8827 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8828 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8829 & coeffmees0mij*gacontm_hb1(ll,kk,k))
8830 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8831 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8832 & coeffmees0mij*gacontm_hb2(ll,kk,k))
8833 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8834 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8835 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
8836 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8837 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8838 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8839 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8840 & coeffmees0mij*gacontm_hb3(ll,kk,k))
8841 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8842 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8843 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8848 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
8849 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
8850 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8851 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8856 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
8857 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
8858 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8859 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8862 c write (iout,*) "ehbcorr",ekont*ees
8863 C print *,ekont,ees,i,k
8865 C now gradient over shielding
8867 if (shield_mode.gt.0) then
8870 C print *,i,j,fac_shield(i),fac_shield(j),
8871 C &fac_shield(k),fac_shield(l)
8872 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8873 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8874 do ilist=1,ishield_list(i)
8875 iresshield=shield_list(ilist,i)
8877 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8879 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8881 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8882 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8886 do ilist=1,ishield_list(j)
8887 iresshield=shield_list(ilist,j)
8889 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8891 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8893 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8894 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8899 do ilist=1,ishield_list(k)
8900 iresshield=shield_list(ilist,k)
8902 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8904 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8906 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8907 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8911 do ilist=1,ishield_list(l)
8912 iresshield=shield_list(ilist,l)
8914 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8916 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8918 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8919 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8923 C print *,gshieldx(m,iresshield)
8925 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8926 & grad_shield(m,i)*ehbcorr/fac_shield(i)
8927 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8928 & grad_shield(m,j)*ehbcorr/fac_shield(j)
8929 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8930 & grad_shield(m,i)*ehbcorr/fac_shield(i)
8931 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8932 & grad_shield(m,j)*ehbcorr/fac_shield(j)
8934 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8935 & grad_shield(m,k)*ehbcorr/fac_shield(k)
8936 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8937 & grad_shield(m,l)*ehbcorr/fac_shield(l)
8938 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8939 & grad_shield(m,k)*ehbcorr/fac_shield(k)
8940 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8941 & grad_shield(m,l)*ehbcorr/fac_shield(l)
8949 C---------------------------------------------------------------------------
8950 subroutine dipole(i,j,jj)
8951 implicit real*8 (a-h,o-z)
8952 include 'DIMENSIONS'
8953 include 'COMMON.IOUNITS'
8954 include 'COMMON.CHAIN'
8955 include 'COMMON.FFIELD'
8956 include 'COMMON.DERIV'
8957 include 'COMMON.INTERACT'
8958 include 'COMMON.CONTACTS'
8959 include 'COMMON.TORSION'
8960 include 'COMMON.VAR'
8961 include 'COMMON.GEO'
8962 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8964 iti1 = itortyp(itype(i+1))
8965 if (j.lt.nres-1) then
8966 itj1 = itype2loc(itype(j+1))
8971 dipi(iii,1)=Ub2(iii,i)
8972 dipderi(iii)=Ub2der(iii,i)
8973 dipi(iii,2)=b1(iii,i+1)
8974 dipj(iii,1)=Ub2(iii,j)
8975 dipderj(iii)=Ub2der(iii,j)
8976 dipj(iii,2)=b1(iii,j+1)
8980 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8983 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8990 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8994 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8999 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9000 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9002 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9004 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9006 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9011 C---------------------------------------------------------------------------
9012 subroutine calc_eello(i,j,k,l,jj,kk)
9014 C This subroutine computes matrices and vectors needed to calculate
9015 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9017 implicit real*8 (a-h,o-z)
9018 include 'DIMENSIONS'
9019 include 'COMMON.IOUNITS'
9020 include 'COMMON.CHAIN'
9021 include 'COMMON.DERIV'
9022 include 'COMMON.INTERACT'
9023 include 'COMMON.CONTACTS'
9024 include 'COMMON.TORSION'
9025 include 'COMMON.VAR'
9026 include 'COMMON.GEO'
9027 include 'COMMON.FFIELD'
9028 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9029 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9032 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9033 cd & ' jj=',jj,' kk=',kk
9034 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9035 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9036 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9039 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9040 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9043 call transpose2(aa1(1,1),aa1t(1,1))
9044 call transpose2(aa2(1,1),aa2t(1,1))
9047 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9048 & aa1tder(1,1,lll,kkk))
9049 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9050 & aa2tder(1,1,lll,kkk))
9054 C parallel orientation of the two CA-CA-CA frames.
9056 iti=itype2loc(itype(i))
9060 itk1=itype2loc(itype(k+1))
9061 itj=itype2loc(itype(j))
9062 if (l.lt.nres-1) then
9063 itl1=itype2loc(itype(l+1))
9067 C A1 kernel(j+1) A2T
9069 cd write (iout,'(3f10.5,5x,3f10.5)')
9070 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9072 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9073 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9074 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9075 C Following matrices are needed only for 6-th order cumulants
9076 IF (wcorr6.gt.0.0d0) THEN
9077 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9078 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9079 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9080 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9081 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9082 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9083 & ADtEAderx(1,1,1,1,1,1))
9085 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9086 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9087 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9088 & ADtEA1derx(1,1,1,1,1,1))
9090 C End 6-th order cumulants
9093 cd write (2,*) 'In calc_eello6'
9095 cd write (2,*) 'iii=',iii
9097 cd write (2,*) 'kkk=',kkk
9099 cd write (2,'(3(2f10.5),5x)')
9100 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9105 call transpose2(EUgder(1,1,k),auxmat(1,1))
9106 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9107 call transpose2(EUg(1,1,k),auxmat(1,1))
9108 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9109 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9113 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9114 & EAEAderx(1,1,lll,kkk,iii,1))
9118 C A1T kernel(i+1) A2
9119 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9120 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9121 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9122 C Following matrices are needed only for 6-th order cumulants
9123 IF (wcorr6.gt.0.0d0) THEN
9124 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9125 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9126 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9127 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9128 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9129 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9130 & ADtEAderx(1,1,1,1,1,2))
9131 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9132 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9133 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9134 & ADtEA1derx(1,1,1,1,1,2))
9136 C End 6-th order cumulants
9137 call transpose2(EUgder(1,1,l),auxmat(1,1))
9138 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9139 call transpose2(EUg(1,1,l),auxmat(1,1))
9140 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9141 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9145 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9146 & EAEAderx(1,1,lll,kkk,iii,2))
9151 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9152 C They are needed only when the fifth- or the sixth-order cumulants are
9154 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9155 call transpose2(AEA(1,1,1),auxmat(1,1))
9156 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9157 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9158 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9159 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9160 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9161 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9162 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9163 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9164 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9165 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9166 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9167 call transpose2(AEA(1,1,2),auxmat(1,1))
9168 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9169 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9170 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9171 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9172 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9173 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9174 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9175 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9176 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9177 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9178 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9179 C Calculate the Cartesian derivatives of the vectors.
9183 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9184 call matvec2(auxmat(1,1),b1(1,i),
9185 & AEAb1derx(1,lll,kkk,iii,1,1))
9186 call matvec2(auxmat(1,1),Ub2(1,i),
9187 & AEAb2derx(1,lll,kkk,iii,1,1))
9188 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9189 & AEAb1derx(1,lll,kkk,iii,2,1))
9190 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9191 & AEAb2derx(1,lll,kkk,iii,2,1))
9192 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9193 call matvec2(auxmat(1,1),b1(1,j),
9194 & AEAb1derx(1,lll,kkk,iii,1,2))
9195 call matvec2(auxmat(1,1),Ub2(1,j),
9196 & AEAb2derx(1,lll,kkk,iii,1,2))
9197 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9198 & AEAb1derx(1,lll,kkk,iii,2,2))
9199 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9200 & AEAb2derx(1,lll,kkk,iii,2,2))
9207 C Antiparallel orientation of the two CA-CA-CA frames.
9209 iti=itype2loc(itype(i))
9213 itk1=itype2loc(itype(k+1))
9214 itl=itype2loc(itype(l))
9215 itj=itype2loc(itype(j))
9216 if (j.lt.nres-1) then
9217 itj1=itype2loc(itype(j+1))
9221 C A2 kernel(j-1)T A1T
9222 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9223 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9224 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9225 C Following matrices are needed only for 6-th order cumulants
9226 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9227 & j.eq.i+4 .and. l.eq.i+3)) THEN
9228 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9229 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9230 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9231 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9232 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9233 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9234 & ADtEAderx(1,1,1,1,1,1))
9235 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9236 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9237 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9238 & ADtEA1derx(1,1,1,1,1,1))
9240 C End 6-th order cumulants
9241 call transpose2(EUgder(1,1,k),auxmat(1,1))
9242 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9243 call transpose2(EUg(1,1,k),auxmat(1,1))
9244 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9245 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9249 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9250 & EAEAderx(1,1,lll,kkk,iii,1))
9254 C A2T kernel(i+1)T A1
9255 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9256 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9257 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9258 C Following matrices are needed only for 6-th order cumulants
9259 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9260 & j.eq.i+4 .and. l.eq.i+3)) THEN
9261 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9262 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9263 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9264 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9265 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9266 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9267 & ADtEAderx(1,1,1,1,1,2))
9268 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9269 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9270 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9271 & ADtEA1derx(1,1,1,1,1,2))
9273 C End 6-th order cumulants
9274 call transpose2(EUgder(1,1,j),auxmat(1,1))
9275 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9276 call transpose2(EUg(1,1,j),auxmat(1,1))
9277 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9278 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9282 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9283 & EAEAderx(1,1,lll,kkk,iii,2))
9288 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9289 C They are needed only when the fifth- or the sixth-order cumulants are
9291 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9292 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9293 call transpose2(AEA(1,1,1),auxmat(1,1))
9294 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9295 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9296 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9297 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9298 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9299 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9300 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9301 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9302 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9303 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9304 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9305 call transpose2(AEA(1,1,2),auxmat(1,1))
9306 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9307 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9308 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9309 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9310 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9311 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9312 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9313 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9314 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9315 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9316 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9317 C Calculate the Cartesian derivatives of the vectors.
9321 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9322 call matvec2(auxmat(1,1),b1(1,i),
9323 & AEAb1derx(1,lll,kkk,iii,1,1))
9324 call matvec2(auxmat(1,1),Ub2(1,i),
9325 & AEAb2derx(1,lll,kkk,iii,1,1))
9326 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9327 & AEAb1derx(1,lll,kkk,iii,2,1))
9328 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9329 & AEAb2derx(1,lll,kkk,iii,2,1))
9330 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9331 call matvec2(auxmat(1,1),b1(1,l),
9332 & AEAb1derx(1,lll,kkk,iii,1,2))
9333 call matvec2(auxmat(1,1),Ub2(1,l),
9334 & AEAb2derx(1,lll,kkk,iii,1,2))
9335 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9336 & AEAb1derx(1,lll,kkk,iii,2,2))
9337 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9338 & AEAb2derx(1,lll,kkk,iii,2,2))
9347 C---------------------------------------------------------------------------
9348 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9349 & KK,KKderg,AKA,AKAderg,AKAderx)
9353 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9354 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9355 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9360 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9362 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9365 cd if (lprn) write (2,*) 'In kernel'
9367 cd if (lprn) write (2,*) 'kkk=',kkk
9369 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9370 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9372 cd write (2,*) 'lll=',lll
9373 cd write (2,*) 'iii=1'
9375 cd write (2,'(3(2f10.5),5x)')
9376 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9379 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9380 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9382 cd write (2,*) 'lll=',lll
9383 cd write (2,*) 'iii=2'
9385 cd write (2,'(3(2f10.5),5x)')
9386 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9393 C---------------------------------------------------------------------------
9394 double precision function eello4(i,j,k,l,jj,kk)
9395 implicit real*8 (a-h,o-z)
9396 include 'DIMENSIONS'
9397 include 'COMMON.IOUNITS'
9398 include 'COMMON.CHAIN'
9399 include 'COMMON.DERIV'
9400 include 'COMMON.INTERACT'
9401 include 'COMMON.CONTACTS'
9402 include 'COMMON.TORSION'
9403 include 'COMMON.VAR'
9404 include 'COMMON.GEO'
9405 double precision pizda(2,2),ggg1(3),ggg2(3)
9406 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9410 cd print *,'eello4:',i,j,k,l,jj,kk
9411 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
9412 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
9413 cold eij=facont_hb(jj,i)
9414 cold ekl=facont_hb(kk,k)
9416 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9417 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9418 gcorr_loc(k-1)=gcorr_loc(k-1)
9419 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9421 gcorr_loc(l-1)=gcorr_loc(l-1)
9422 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9424 gcorr_loc(j-1)=gcorr_loc(j-1)
9425 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9430 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9431 & -EAEAderx(2,2,lll,kkk,iii,1)
9432 cd derx(lll,kkk,iii)=0.0d0
9436 cd gcorr_loc(l-1)=0.0d0
9437 cd gcorr_loc(j-1)=0.0d0
9438 cd gcorr_loc(k-1)=0.0d0
9440 cd write (iout,*)'Contacts have occurred for peptide groups',
9441 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
9442 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9443 if (j.lt.nres-1) then
9450 if (l.lt.nres-1) then
9458 cgrad ggg1(ll)=eel4*g_contij(ll,1)
9459 cgrad ggg2(ll)=eel4*g_contij(ll,2)
9460 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9461 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9462 cgrad ghalf=0.5d0*ggg1(ll)
9463 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9464 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9465 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9466 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9467 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9468 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9469 cgrad ghalf=0.5d0*ggg2(ll)
9470 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9471 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9472 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9473 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9474 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9475 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9479 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9484 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9489 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9494 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9498 cd write (2,*) iii,gcorr_loc(iii)
9501 cd write (2,*) 'ekont',ekont
9502 cd write (iout,*) 'eello4',ekont*eel4
9505 C---------------------------------------------------------------------------
9506 double precision function eello5(i,j,k,l,jj,kk)
9507 implicit real*8 (a-h,o-z)
9508 include 'DIMENSIONS'
9509 include 'COMMON.IOUNITS'
9510 include 'COMMON.CHAIN'
9511 include 'COMMON.DERIV'
9512 include 'COMMON.INTERACT'
9513 include 'COMMON.CONTACTS'
9514 include 'COMMON.TORSION'
9515 include 'COMMON.VAR'
9516 include 'COMMON.GEO'
9517 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9518 double precision ggg1(3),ggg2(3)
9519 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9524 C /l\ / \ \ / \ / \ / C
9525 C / \ / \ \ / \ / \ / C
9526 C j| o |l1 | o | o| o | | o |o C
9527 C \ |/k\| |/ \| / |/ \| |/ \| C
9528 C \i/ \ / \ / / \ / \ C
9530 C (I) (II) (III) (IV) C
9532 C eello5_1 eello5_2 eello5_3 eello5_4 C
9534 C Antiparallel chains C
9537 C /j\ / \ \ / \ / \ / C
9538 C / \ / \ \ / \ / \ / C
9539 C j1| o |l | o | o| o | | o |o C
9540 C \ |/k\| |/ \| / |/ \| |/ \| C
9541 C \i/ \ / \ / / \ / \ C
9543 C (I) (II) (III) (IV) C
9545 C eello5_1 eello5_2 eello5_3 eello5_4 C
9547 C o denotes a local interaction, vertical lines an electrostatic interaction. C
9549 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9550 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9555 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
9557 itk=itype2loc(itype(k))
9558 itl=itype2loc(itype(l))
9559 itj=itype2loc(itype(j))
9564 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9565 cd & eel5_3_num,eel5_4_num)
9569 derx(lll,kkk,iii)=0.0d0
9573 cd eij=facont_hb(jj,i)
9574 cd ekl=facont_hb(kk,k)
9576 cd write (iout,*)'Contacts have occurred for peptide groups',
9577 cd & i,j,' fcont:',eij,' eij',' and ',k,l
9579 C Contribution from the graph I.
9580 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9581 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9582 call transpose2(EUg(1,1,k),auxmat(1,1))
9583 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9584 vv(1)=pizda(1,1)-pizda(2,2)
9585 vv(2)=pizda(1,2)+pizda(2,1)
9586 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9587 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9588 C Explicit gradient in virtual-dihedral angles.
9589 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9590 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9591 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9592 call transpose2(EUgder(1,1,k),auxmat1(1,1))
9593 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9594 vv(1)=pizda(1,1)-pizda(2,2)
9595 vv(2)=pizda(1,2)+pizda(2,1)
9596 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9597 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9598 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9599 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9600 vv(1)=pizda(1,1)-pizda(2,2)
9601 vv(2)=pizda(1,2)+pizda(2,1)
9603 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9604 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9605 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9607 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9608 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9609 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9611 C Cartesian gradient
9615 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9617 vv(1)=pizda(1,1)-pizda(2,2)
9618 vv(2)=pizda(1,2)+pizda(2,1)
9619 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9620 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9621 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9627 C Contribution from graph II
9628 call transpose2(EE(1,1,k),auxmat(1,1))
9629 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9630 vv(1)=pizda(1,1)+pizda(2,2)
9631 vv(2)=pizda(2,1)-pizda(1,2)
9632 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9633 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9634 C Explicit gradient in virtual-dihedral angles.
9635 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9636 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9637 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9638 vv(1)=pizda(1,1)+pizda(2,2)
9639 vv(2)=pizda(2,1)-pizda(1,2)
9641 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9642 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9643 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9645 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9646 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9647 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9649 C Cartesian gradient
9653 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9655 vv(1)=pizda(1,1)+pizda(2,2)
9656 vv(2)=pizda(2,1)-pizda(1,2)
9657 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9658 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9659 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9667 C Parallel orientation
9668 C Contribution from graph III
9669 call transpose2(EUg(1,1,l),auxmat(1,1))
9670 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9671 vv(1)=pizda(1,1)-pizda(2,2)
9672 vv(2)=pizda(1,2)+pizda(2,1)
9673 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9674 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9675 C Explicit gradient in virtual-dihedral angles.
9676 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9677 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9678 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9679 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9680 vv(1)=pizda(1,1)-pizda(2,2)
9681 vv(2)=pizda(1,2)+pizda(2,1)
9682 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9683 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9684 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9685 call transpose2(EUgder(1,1,l),auxmat1(1,1))
9686 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9687 vv(1)=pizda(1,1)-pizda(2,2)
9688 vv(2)=pizda(1,2)+pizda(2,1)
9689 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9690 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9691 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9692 C Cartesian gradient
9696 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9698 vv(1)=pizda(1,1)-pizda(2,2)
9699 vv(2)=pizda(1,2)+pizda(2,1)
9700 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9701 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9702 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9707 C Contribution from graph IV
9709 call transpose2(EE(1,1,l),auxmat(1,1))
9710 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9711 vv(1)=pizda(1,1)+pizda(2,2)
9712 vv(2)=pizda(2,1)-pizda(1,2)
9713 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9714 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
9715 C Explicit gradient in virtual-dihedral angles.
9716 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9717 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9718 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9719 vv(1)=pizda(1,1)+pizda(2,2)
9720 vv(2)=pizda(2,1)-pizda(1,2)
9721 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9722 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9723 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9724 C Cartesian gradient
9728 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9730 vv(1)=pizda(1,1)+pizda(2,2)
9731 vv(2)=pizda(2,1)-pizda(1,2)
9732 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9733 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9734 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
9739 C Antiparallel orientation
9740 C Contribution from graph III
9742 call transpose2(EUg(1,1,j),auxmat(1,1))
9743 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9744 vv(1)=pizda(1,1)-pizda(2,2)
9745 vv(2)=pizda(1,2)+pizda(2,1)
9746 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9747 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9748 C Explicit gradient in virtual-dihedral angles.
9749 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9750 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9751 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9752 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9753 vv(1)=pizda(1,1)-pizda(2,2)
9754 vv(2)=pizda(1,2)+pizda(2,1)
9755 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9756 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9757 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9758 call transpose2(EUgder(1,1,j),auxmat1(1,1))
9759 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9760 vv(1)=pizda(1,1)-pizda(2,2)
9761 vv(2)=pizda(1,2)+pizda(2,1)
9762 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9763 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9764 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9765 C Cartesian gradient
9769 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9771 vv(1)=pizda(1,1)-pizda(2,2)
9772 vv(2)=pizda(1,2)+pizda(2,1)
9773 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9774 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9775 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9780 C Contribution from graph IV
9782 call transpose2(EE(1,1,j),auxmat(1,1))
9783 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9784 vv(1)=pizda(1,1)+pizda(2,2)
9785 vv(2)=pizda(2,1)-pizda(1,2)
9786 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9787 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
9788 C Explicit gradient in virtual-dihedral angles.
9789 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9790 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9791 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9792 vv(1)=pizda(1,1)+pizda(2,2)
9793 vv(2)=pizda(2,1)-pizda(1,2)
9794 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9795 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9796 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9797 C Cartesian gradient
9801 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9803 vv(1)=pizda(1,1)+pizda(2,2)
9804 vv(2)=pizda(2,1)-pizda(1,2)
9805 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9806 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9807 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
9813 eel5=eello5_1+eello5_2+eello5_3+eello5_4
9814 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9815 cd write (2,*) 'ijkl',i,j,k,l
9816 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9817 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
9819 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9820 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9821 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9822 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9823 if (j.lt.nres-1) then
9830 if (l.lt.nres-1) then
9840 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9841 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9842 C summed up outside the subrouine as for the other subroutines
9843 C handling long-range interactions. The old code is commented out
9844 C with "cgrad" to keep track of changes.
9846 cgrad ggg1(ll)=eel5*g_contij(ll,1)
9847 cgrad ggg2(ll)=eel5*g_contij(ll,2)
9848 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9849 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9850 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9851 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9852 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9853 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9854 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9855 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9857 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9858 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9859 cgrad ghalf=0.5d0*ggg1(ll)
9861 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9862 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9863 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9864 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9865 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9866 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9867 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9868 cgrad ghalf=0.5d0*ggg2(ll)
9870 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9871 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9872 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9873 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9874 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9875 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9880 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9881 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9886 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9887 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9893 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9898 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9902 cd write (2,*) iii,g_corr5_loc(iii)
9905 cd write (2,*) 'ekont',ekont
9906 cd write (iout,*) 'eello5',ekont*eel5
9909 c--------------------------------------------------------------------------
9910 double precision function eello6(i,j,k,l,jj,kk)
9911 implicit real*8 (a-h,o-z)
9912 include 'DIMENSIONS'
9913 include 'COMMON.IOUNITS'
9914 include 'COMMON.CHAIN'
9915 include 'COMMON.DERIV'
9916 include 'COMMON.INTERACT'
9917 include 'COMMON.CONTACTS'
9918 include 'COMMON.TORSION'
9919 include 'COMMON.VAR'
9920 include 'COMMON.GEO'
9921 include 'COMMON.FFIELD'
9922 double precision ggg1(3),ggg2(3)
9923 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9928 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
9936 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9937 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9941 derx(lll,kkk,iii)=0.0d0
9945 cd eij=facont_hb(jj,i)
9946 cd ekl=facont_hb(kk,k)
9952 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9953 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9954 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9955 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9956 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9957 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9959 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9960 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9961 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9962 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9963 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9964 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9968 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9970 C If turn contributions are considered, they will be handled separately.
9971 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9972 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9973 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9974 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9975 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9976 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9977 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9979 if (j.lt.nres-1) then
9986 if (l.lt.nres-1) then
9994 cgrad ggg1(ll)=eel6*g_contij(ll,1)
9995 cgrad ggg2(ll)=eel6*g_contij(ll,2)
9996 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9997 cgrad ghalf=0.5d0*ggg1(ll)
9999 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10000 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10001 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10002 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10003 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10004 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10005 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10006 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10007 cgrad ghalf=0.5d0*ggg2(ll)
10008 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10010 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10011 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10012 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10013 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10014 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10015 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10020 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10021 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10026 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10027 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10033 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10038 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10042 cd write (2,*) iii,g_corr6_loc(iii)
10045 cd write (2,*) 'ekont',ekont
10046 cd write (iout,*) 'eello6',ekont*eel6
10049 c--------------------------------------------------------------------------
10050 double precision function eello6_graph1(i,j,k,l,imat,swap)
10051 implicit real*8 (a-h,o-z)
10052 include 'DIMENSIONS'
10053 include 'COMMON.IOUNITS'
10054 include 'COMMON.CHAIN'
10055 include 'COMMON.DERIV'
10056 include 'COMMON.INTERACT'
10057 include 'COMMON.CONTACTS'
10058 include 'COMMON.TORSION'
10059 include 'COMMON.VAR'
10060 include 'COMMON.GEO'
10061 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10064 common /kutas/ lprn
10065 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10067 C Parallel Antiparallel C
10073 C \ j|/k\| / \ |/k\|l / C
10074 C \ / \ / \ / \ / C
10078 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10079 itk=itype2loc(itype(k))
10080 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10081 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10082 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10083 call transpose2(EUgC(1,1,k),auxmat(1,1))
10084 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10085 vv1(1)=pizda1(1,1)-pizda1(2,2)
10086 vv1(2)=pizda1(1,2)+pizda1(2,1)
10087 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10088 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10089 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10090 s5=scalar2(vv(1),Dtobr2(1,i))
10091 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10092 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10093 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10094 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10095 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10096 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10097 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10098 & +scalar2(vv(1),Dtobr2der(1,i)))
10099 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10100 vv1(1)=pizda1(1,1)-pizda1(2,2)
10101 vv1(2)=pizda1(1,2)+pizda1(2,1)
10102 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10103 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10105 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10106 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10107 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10108 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10109 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10111 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10112 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10113 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10114 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10115 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10117 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10118 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10119 vv1(1)=pizda1(1,1)-pizda1(2,2)
10120 vv1(2)=pizda1(1,2)+pizda1(2,1)
10121 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10122 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10123 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10124 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10133 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10134 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10135 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10136 call transpose2(EUgC(1,1,k),auxmat(1,1))
10137 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10139 vv1(1)=pizda1(1,1)-pizda1(2,2)
10140 vv1(2)=pizda1(1,2)+pizda1(2,1)
10141 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10142 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10143 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10144 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10145 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10146 s5=scalar2(vv(1),Dtobr2(1,i))
10147 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10153 c----------------------------------------------------------------------------
10154 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10155 implicit real*8 (a-h,o-z)
10156 include 'DIMENSIONS'
10157 include 'COMMON.IOUNITS'
10158 include 'COMMON.CHAIN'
10159 include 'COMMON.DERIV'
10160 include 'COMMON.INTERACT'
10161 include 'COMMON.CONTACTS'
10162 include 'COMMON.TORSION'
10163 include 'COMMON.VAR'
10164 include 'COMMON.GEO'
10166 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10167 & auxvec1(2),auxvec2(2),auxmat1(2,2)
10169 common /kutas/ lprn
10170 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10172 C Parallel Antiparallel C
10178 C \ j|/k\| \ |/k\|l C
10183 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10184 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10185 C AL 7/4/01 s1 would occur in the sixth-order moment,
10186 C but not in a cluster cumulant
10188 s1=dip(1,jj,i)*dip(1,kk,k)
10190 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10191 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10192 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10193 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10194 call transpose2(EUg(1,1,k),auxmat(1,1))
10195 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10196 vv(1)=pizda(1,1)-pizda(2,2)
10197 vv(2)=pizda(1,2)+pizda(2,1)
10198 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10199 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10201 eello6_graph2=-(s1+s2+s3+s4)
10203 eello6_graph2=-(s2+s3+s4)
10205 c eello6_graph2=-s3
10206 C Derivatives in gamma(i-1)
10209 s1=dipderg(1,jj,i)*dip(1,kk,k)
10211 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10212 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10213 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10214 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10216 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10218 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10220 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10222 C Derivatives in gamma(k-1)
10224 s1=dip(1,jj,i)*dipderg(1,kk,k)
10226 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10227 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10228 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10229 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10230 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10231 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10232 vv(1)=pizda(1,1)-pizda(2,2)
10233 vv(2)=pizda(1,2)+pizda(2,1)
10234 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10236 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10238 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10240 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10241 C Derivatives in gamma(j-1) or gamma(l-1)
10244 s1=dipderg(3,jj,i)*dip(1,kk,k)
10246 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10247 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10248 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10249 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10250 vv(1)=pizda(1,1)-pizda(2,2)
10251 vv(2)=pizda(1,2)+pizda(2,1)
10252 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10255 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10257 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10260 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10261 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10263 C Derivatives in gamma(l-1) or gamma(j-1)
10266 s1=dip(1,jj,i)*dipderg(3,kk,k)
10268 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10269 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10270 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10271 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10272 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10273 vv(1)=pizda(1,1)-pizda(2,2)
10274 vv(2)=pizda(1,2)+pizda(2,1)
10275 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10278 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10280 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10283 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10284 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10286 C Cartesian derivatives.
10288 write (2,*) 'In eello6_graph2'
10290 write (2,*) 'iii=',iii
10292 write (2,*) 'kkk=',kkk
10294 write (2,'(3(2f10.5),5x)')
10295 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10305 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10307 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10310 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10312 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10313 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10315 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10316 call transpose2(EUg(1,1,k),auxmat(1,1))
10317 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10319 vv(1)=pizda(1,1)-pizda(2,2)
10320 vv(2)=pizda(1,2)+pizda(2,1)
10321 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10322 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10324 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10326 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10329 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10331 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10338 c----------------------------------------------------------------------------
10339 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10340 implicit real*8 (a-h,o-z)
10341 include 'DIMENSIONS'
10342 include 'COMMON.IOUNITS'
10343 include 'COMMON.CHAIN'
10344 include 'COMMON.DERIV'
10345 include 'COMMON.INTERACT'
10346 include 'COMMON.CONTACTS'
10347 include 'COMMON.TORSION'
10348 include 'COMMON.VAR'
10349 include 'COMMON.GEO'
10350 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10352 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10354 C Parallel Antiparallel C
10359 C /| o |o o| o |\ C
10360 C j|/k\| / |/k\|l / C
10365 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10367 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10368 C energy moment and not to the cluster cumulant.
10369 iti=itortyp(itype(i))
10370 if (j.lt.nres-1) then
10371 itj1=itype2loc(itype(j+1))
10375 itk=itype2loc(itype(k))
10376 itk1=itype2loc(itype(k+1))
10377 if (l.lt.nres-1) then
10378 itl1=itype2loc(itype(l+1))
10383 s1=dip(4,jj,i)*dip(4,kk,k)
10385 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10386 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10387 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10388 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10389 call transpose2(EE(1,1,k),auxmat(1,1))
10390 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10391 vv(1)=pizda(1,1)+pizda(2,2)
10392 vv(2)=pizda(2,1)-pizda(1,2)
10393 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10394 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10395 cd & "sum",-(s2+s3+s4)
10397 eello6_graph3=-(s1+s2+s3+s4)
10399 eello6_graph3=-(s2+s3+s4)
10401 c eello6_graph3=-s4
10402 C Derivatives in gamma(k-1)
10403 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10404 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10405 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10406 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10407 C Derivatives in gamma(l-1)
10408 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10409 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10410 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10411 vv(1)=pizda(1,1)+pizda(2,2)
10412 vv(2)=pizda(2,1)-pizda(1,2)
10413 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10414 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10415 C Cartesian derivatives.
10421 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10423 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10426 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10428 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10429 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10431 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10432 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10434 vv(1)=pizda(1,1)+pizda(2,2)
10435 vv(2)=pizda(2,1)-pizda(1,2)
10436 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10438 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10440 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10443 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10445 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10447 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10453 c----------------------------------------------------------------------------
10454 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10455 implicit real*8 (a-h,o-z)
10456 include 'DIMENSIONS'
10457 include 'COMMON.IOUNITS'
10458 include 'COMMON.CHAIN'
10459 include 'COMMON.DERIV'
10460 include 'COMMON.INTERACT'
10461 include 'COMMON.CONTACTS'
10462 include 'COMMON.TORSION'
10463 include 'COMMON.VAR'
10464 include 'COMMON.GEO'
10465 include 'COMMON.FFIELD'
10466 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10467 & auxvec1(2),auxmat1(2,2)
10469 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10471 C Parallel Antiparallel C
10476 C /| o |o o| o |\ C
10477 C \ j|/k\| \ |/k\|l C
10482 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10484 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10485 C energy moment and not to the cluster cumulant.
10486 cd write (2,*) 'eello_graph4: wturn6',wturn6
10487 iti=itype2loc(itype(i))
10488 itj=itype2loc(itype(j))
10489 if (j.lt.nres-1) then
10490 itj1=itype2loc(itype(j+1))
10494 itk=itype2loc(itype(k))
10495 if (k.lt.nres-1) then
10496 itk1=itype2loc(itype(k+1))
10500 itl=itype2loc(itype(l))
10501 if (l.lt.nres-1) then
10502 itl1=itype2loc(itype(l+1))
10506 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10507 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10508 cd & ' itl',itl,' itl1',itl1
10510 if (imat.eq.1) then
10511 s1=dip(3,jj,i)*dip(3,kk,k)
10513 s1=dip(2,jj,j)*dip(2,kk,l)
10516 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10517 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10519 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10520 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10522 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10523 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10525 call transpose2(EUg(1,1,k),auxmat(1,1))
10526 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10527 vv(1)=pizda(1,1)-pizda(2,2)
10528 vv(2)=pizda(2,1)+pizda(1,2)
10529 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10530 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10532 eello6_graph4=-(s1+s2+s3+s4)
10534 eello6_graph4=-(s2+s3+s4)
10536 C Derivatives in gamma(i-1)
10539 if (imat.eq.1) then
10540 s1=dipderg(2,jj,i)*dip(3,kk,k)
10542 s1=dipderg(4,jj,j)*dip(2,kk,l)
10545 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10547 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10548 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10550 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10551 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10553 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10554 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10555 cd write (2,*) 'turn6 derivatives'
10557 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10559 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10563 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10565 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10569 C Derivatives in gamma(k-1)
10571 if (imat.eq.1) then
10572 s1=dip(3,jj,i)*dipderg(2,kk,k)
10574 s1=dip(2,jj,j)*dipderg(4,kk,l)
10577 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10578 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10580 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10581 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10583 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10584 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10586 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10587 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10588 vv(1)=pizda(1,1)-pizda(2,2)
10589 vv(2)=pizda(2,1)+pizda(1,2)
10590 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10591 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10593 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10595 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10599 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10601 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10604 C Derivatives in gamma(j-1) or gamma(l-1)
10605 if (l.eq.j+1 .and. l.gt.1) then
10606 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10607 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10608 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10609 vv(1)=pizda(1,1)-pizda(2,2)
10610 vv(2)=pizda(2,1)+pizda(1,2)
10611 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10612 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10613 else if (j.gt.1) then
10614 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10615 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10616 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10617 vv(1)=pizda(1,1)-pizda(2,2)
10618 vv(2)=pizda(2,1)+pizda(1,2)
10619 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10620 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10621 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10623 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10626 C Cartesian derivatives.
10632 if (imat.eq.1) then
10633 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10635 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10638 if (imat.eq.1) then
10639 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10641 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10645 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10647 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10649 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10650 & b1(1,j+1),auxvec(1))
10651 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10653 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10654 & b1(1,l+1),auxvec(1))
10655 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10657 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10659 vv(1)=pizda(1,1)-pizda(2,2)
10660 vv(2)=pizda(2,1)+pizda(1,2)
10661 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10663 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10665 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10668 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10671 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10674 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10676 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10678 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10682 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10684 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10687 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10689 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10697 c----------------------------------------------------------------------------
10698 double precision function eello_turn6(i,jj,kk)
10699 implicit real*8 (a-h,o-z)
10700 include 'DIMENSIONS'
10701 include 'COMMON.IOUNITS'
10702 include 'COMMON.CHAIN'
10703 include 'COMMON.DERIV'
10704 include 'COMMON.INTERACT'
10705 include 'COMMON.CONTACTS'
10706 include 'COMMON.TORSION'
10707 include 'COMMON.VAR'
10708 include 'COMMON.GEO'
10709 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10710 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10712 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10713 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10714 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10715 C the respective energy moment and not to the cluster cumulant.
10724 iti=itype2loc(itype(i))
10725 itk=itype2loc(itype(k))
10726 itk1=itype2loc(itype(k+1))
10727 itl=itype2loc(itype(l))
10728 itj=itype2loc(itype(j))
10729 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10730 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
10731 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10736 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10738 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
10742 derx_turn(lll,kkk,iii)=0.0d0
10749 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10751 cd write (2,*) 'eello6_5',eello6_5
10753 call transpose2(AEA(1,1,1),auxmat(1,1))
10754 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10755 ss1=scalar2(Ub2(1,i+2),b1(1,l))
10756 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10758 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10759 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10760 s2 = scalar2(b1(1,k),vtemp1(1))
10762 call transpose2(AEA(1,1,2),atemp(1,1))
10763 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10764 call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10765 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10767 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10768 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10769 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10771 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10772 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10773 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10774 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10775 ss13 = scalar2(b1(1,k),vtemp4(1))
10776 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10778 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10784 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10785 C Derivatives in gamma(i+2)
10789 call transpose2(AEA(1,1,1),auxmatd(1,1))
10790 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10791 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10792 call transpose2(AEAderg(1,1,2),atempd(1,1))
10793 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10794 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10796 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10797 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10798 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10804 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10805 C Derivatives in gamma(i+3)
10807 call transpose2(AEA(1,1,1),auxmatd(1,1))
10808 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10809 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10810 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10812 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10813 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10814 s2d = scalar2(b1(1,k),vtemp1d(1))
10816 call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10817 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10819 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10821 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10822 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10823 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10831 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10832 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10834 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10835 & -0.5d0*ekont*(s2d+s12d)
10837 C Derivatives in gamma(i+4)
10838 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10839 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10840 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10842 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10843 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10844 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10852 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10854 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10856 C Derivatives in gamma(i+5)
10858 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10859 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10860 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10862 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10863 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10864 s2d = scalar2(b1(1,k),vtemp1d(1))
10866 call transpose2(AEA(1,1,2),atempd(1,1))
10867 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10868 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10870 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10871 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10873 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10874 ss13d = scalar2(b1(1,k),vtemp4d(1))
10875 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10883 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10884 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10886 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10887 & -0.5d0*ekont*(s2d+s12d)
10889 C Cartesian derivatives
10894 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10895 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10896 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10898 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10899 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10901 s2d = scalar2(b1(1,k),vtemp1d(1))
10903 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10904 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10905 s8d = -(atempd(1,1)+atempd(2,2))*
10906 & scalar2(cc(1,1,itl),vtemp2(1))
10908 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10910 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10911 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10918 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10919 & - 0.5d0*(s1d+s2d)
10921 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10925 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10926 & - 0.5d0*(s8d+s12d)
10928 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10937 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10938 & achuj_tempd(1,1))
10939 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10940 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10941 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10942 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10943 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10945 ss13d = scalar2(b1(1,k),vtemp4d(1))
10946 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10947 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10951 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10952 cd & 16*eel_turn6_num
10954 if (j.lt.nres-1) then
10961 if (l.lt.nres-1) then
10969 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
10970 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
10971 cgrad ghalf=0.5d0*ggg1(ll)
10973 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10974 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10975 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10976 & +ekont*derx_turn(ll,2,1)
10977 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10978 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10979 & +ekont*derx_turn(ll,4,1)
10980 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10981 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10982 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10983 cgrad ghalf=0.5d0*ggg2(ll)
10985 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10986 & +ekont*derx_turn(ll,2,2)
10987 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10988 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10989 & +ekont*derx_turn(ll,4,2)
10990 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10991 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10992 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10997 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11002 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11008 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11013 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11017 cd write (2,*) iii,g_corr6_loc(iii)
11019 eello_turn6=ekont*eel_turn6
11020 cd write (2,*) 'ekont',ekont
11021 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11025 C-----------------------------------------------------------------------------
11026 double precision function scalar(u,v)
11027 !DIR$ INLINEALWAYS scalar
11029 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11032 double precision u(3),v(3)
11033 cd double precision sc
11041 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11044 crc-------------------------------------------------
11045 SUBROUTINE MATVEC2(A1,V1,V2)
11046 !DIR$ INLINEALWAYS MATVEC2
11048 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11050 implicit real*8 (a-h,o-z)
11051 include 'DIMENSIONS'
11052 DIMENSION A1(2,2),V1(2),V2(2)
11056 c 3 VI=VI+A1(I,K)*V1(K)
11060 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11061 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11066 C---------------------------------------
11067 SUBROUTINE MATMAT2(A1,A2,A3)
11069 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11071 implicit real*8 (a-h,o-z)
11072 include 'DIMENSIONS'
11073 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11074 c DIMENSION AI3(2,2)
11078 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11084 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11085 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11086 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11087 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11095 c-------------------------------------------------------------------------
11096 double precision function scalar2(u,v)
11097 !DIR$ INLINEALWAYS scalar2
11099 double precision u(2),v(2)
11100 double precision sc
11102 scalar2=u(1)*v(1)+u(2)*v(2)
11106 C-----------------------------------------------------------------------------
11108 subroutine transpose2(a,at)
11109 !DIR$ INLINEALWAYS transpose2
11111 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11114 double precision a(2,2),at(2,2)
11121 c--------------------------------------------------------------------------
11122 subroutine transpose(n,a,at)
11125 double precision a(n,n),at(n,n)
11133 C---------------------------------------------------------------------------
11134 subroutine prodmat3(a1,a2,kk,transp,prod)
11135 !DIR$ INLINEALWAYS prodmat3
11137 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11141 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11143 crc double precision auxmat(2,2),prod_(2,2)
11146 crc call transpose2(kk(1,1),auxmat(1,1))
11147 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11148 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11150 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11151 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11152 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11153 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11154 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11155 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11156 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11157 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11160 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11161 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11163 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11164 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11165 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11166 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11167 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11168 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11169 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11170 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11173 c call transpose2(a2(1,1),a2t(1,1))
11176 crc print *,((prod_(i,j),i=1,2),j=1,2)
11177 crc print *,((prod(i,j),i=1,2),j=1,2)
11181 CCC----------------------------------------------
11182 subroutine Eliptransfer(eliptran)
11183 implicit real*8 (a-h,o-z)
11184 include 'DIMENSIONS'
11185 include 'COMMON.GEO'
11186 include 'COMMON.VAR'
11187 include 'COMMON.LOCAL'
11188 include 'COMMON.CHAIN'
11189 include 'COMMON.DERIV'
11190 include 'COMMON.NAMES'
11191 include 'COMMON.INTERACT'
11192 include 'COMMON.IOUNITS'
11193 include 'COMMON.CALC'
11194 include 'COMMON.CONTROL'
11195 include 'COMMON.SPLITELE'
11196 include 'COMMON.SBRIDGE'
11197 C this is done by Adasko
11198 C print *,"wchodze"
11199 C structure of box:
11201 C--bordliptop-- buffore starts
11202 C--bufliptop--- here true lipid starts
11204 C--buflipbot--- lipid ends buffore starts
11205 C--bordlipbot--buffore ends
11207 do i=ilip_start,ilip_end
11209 if (itype(i).eq.ntyp1) cycle
11211 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11212 if (positi.le.0.0) positi=positi+boxzsize
11214 C first for peptide groups
11215 c for each residue check if it is in lipid or lipid water border area
11216 if ((positi.gt.bordlipbot)
11217 &.and.(positi.lt.bordliptop)) then
11218 C the energy transfer exist
11219 if (positi.lt.buflipbot) then
11220 C what fraction I am in
11222 & ((positi-bordlipbot)/lipbufthick)
11223 C lipbufthick is thickenes of lipid buffore
11224 sslip=sscalelip(fracinbuf)
11225 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11226 eliptran=eliptran+sslip*pepliptran
11227 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11228 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11229 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11231 C print *,"doing sccale for lower part"
11232 C print *,i,sslip,fracinbuf,ssgradlip
11233 elseif (positi.gt.bufliptop) then
11234 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11235 sslip=sscalelip(fracinbuf)
11236 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11237 eliptran=eliptran+sslip*pepliptran
11238 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11239 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11240 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11241 C print *, "doing sscalefor top part"
11242 C print *,i,sslip,fracinbuf,ssgradlip
11244 eliptran=eliptran+pepliptran
11245 C print *,"I am in true lipid"
11248 C eliptran=elpitran+0.0 ! I am in water
11251 C print *, "nic nie bylo w lipidzie?"
11252 C now multiply all by the peptide group transfer factor
11253 C eliptran=eliptran*pepliptran
11254 C now the same for side chains
11256 do i=ilip_start,ilip_end
11257 if (itype(i).eq.ntyp1) cycle
11258 positi=(mod(c(3,i+nres),boxzsize))
11259 if (positi.le.0) positi=positi+boxzsize
11260 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11261 c for each residue check if it is in lipid or lipid water border area
11262 C respos=mod(c(3,i+nres),boxzsize)
11263 C print *,positi,bordlipbot,buflipbot
11264 if ((positi.gt.bordlipbot)
11265 & .and.(positi.lt.bordliptop)) then
11266 C the energy transfer exist
11267 if (positi.lt.buflipbot) then
11269 & ((positi-bordlipbot)/lipbufthick)
11270 C lipbufthick is thickenes of lipid buffore
11271 sslip=sscalelip(fracinbuf)
11272 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11273 eliptran=eliptran+sslip*liptranene(itype(i))
11274 gliptranx(3,i)=gliptranx(3,i)
11275 &+ssgradlip*liptranene(itype(i))
11276 gliptranc(3,i-1)= gliptranc(3,i-1)
11277 &+ssgradlip*liptranene(itype(i))
11278 C print *,"doing sccale for lower part"
11279 elseif (positi.gt.bufliptop) then
11281 &((bordliptop-positi)/lipbufthick)
11282 sslip=sscalelip(fracinbuf)
11283 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11284 eliptran=eliptran+sslip*liptranene(itype(i))
11285 gliptranx(3,i)=gliptranx(3,i)
11286 &+ssgradlip*liptranene(itype(i))
11287 gliptranc(3,i-1)= gliptranc(3,i-1)
11288 &+ssgradlip*liptranene(itype(i))
11289 C print *, "doing sscalefor top part",sslip,fracinbuf
11291 eliptran=eliptran+liptranene(itype(i))
11292 C print *,"I am in true lipid"
11294 endif ! if in lipid or buffor
11296 C eliptran=elpitran+0.0 ! I am in water
11300 C---------------------------------------------------------
11301 C AFM soubroutine for constant force
11302 subroutine AFMforce(Eafmforce)
11303 implicit real*8 (a-h,o-z)
11304 include 'DIMENSIONS'
11305 include 'COMMON.GEO'
11306 include 'COMMON.VAR'
11307 include 'COMMON.LOCAL'
11308 include 'COMMON.CHAIN'
11309 include 'COMMON.DERIV'
11310 include 'COMMON.NAMES'
11311 include 'COMMON.INTERACT'
11312 include 'COMMON.IOUNITS'
11313 include 'COMMON.CALC'
11314 include 'COMMON.CONTROL'
11315 include 'COMMON.SPLITELE'
11316 include 'COMMON.SBRIDGE'
11321 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11322 dist=dist+diffafm(i)**2
11325 Eafmforce=-forceAFMconst*(dist-distafminit)
11327 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11328 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11330 C print *,'AFM',Eafmforce
11333 C---------------------------------------------------------
11334 C AFM subroutine with pseudoconstant velocity
11335 subroutine AFMvel(Eafmforce)
11336 implicit real*8 (a-h,o-z)
11337 include 'DIMENSIONS'
11338 include 'COMMON.GEO'
11339 include 'COMMON.VAR'
11340 include 'COMMON.LOCAL'
11341 include 'COMMON.CHAIN'
11342 include 'COMMON.DERIV'
11343 include 'COMMON.NAMES'
11344 include 'COMMON.INTERACT'
11345 include 'COMMON.IOUNITS'
11346 include 'COMMON.CALC'
11347 include 'COMMON.CONTROL'
11348 include 'COMMON.SPLITELE'
11349 include 'COMMON.SBRIDGE'
11351 C Only for check grad COMMENT if not used for checkgrad
11353 C--------------------------------------------------------
11354 C print *,"wchodze"
11358 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11359 dist=dist+diffafm(i)**2
11362 Eafmforce=0.5d0*forceAFMconst
11363 & *(distafminit+totTafm*velAFMconst-dist)**2
11364 C Eafmforce=-forceAFMconst*(dist-distafminit)
11366 gradafm(i,afmend-1)=-forceAFMconst*
11367 &(distafminit+totTafm*velAFMconst-dist)
11369 gradafm(i,afmbeg-1)=forceAFMconst*
11370 &(distafminit+totTafm*velAFMconst-dist)
11373 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11376 C-----------------------------------------------------------
11377 C first for shielding is setting of function of side-chains
11378 subroutine set_shield_fac
11379 implicit real*8 (a-h,o-z)
11380 include 'DIMENSIONS'
11381 include 'COMMON.CHAIN'
11382 include 'COMMON.DERIV'
11383 include 'COMMON.IOUNITS'
11384 include 'COMMON.SHIELD'
11385 include 'COMMON.INTERACT'
11386 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11387 double precision div77_81/0.974996043d0/,
11388 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11390 C the vector between center of side_chain and peptide group
11391 double precision pep_side(3),long,side_calf(3),
11392 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11393 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11394 C the line belowe needs to be changed for FGPROC>1
11396 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11398 Cif there two consequtive dummy atoms there is no peptide group between them
11399 C the line below has to be changed for FGPROC>1
11402 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11406 C first lets set vector conecting the ithe side-chain with kth side-chain
11407 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11408 C pep_side(j)=2.0d0
11409 C and vector conecting the side-chain with its proper calfa
11410 side_calf(j)=c(j,k+nres)-c(j,k)
11411 C side_calf(j)=2.0d0
11412 pept_group(j)=c(j,i)-c(j,i+1)
11413 C lets have their lenght
11414 dist_pep_side=pep_side(j)**2+dist_pep_side
11415 dist_side_calf=dist_side_calf+side_calf(j)**2
11416 dist_pept_group=dist_pept_group+pept_group(j)**2
11418 dist_pep_side=dsqrt(dist_pep_side)
11419 dist_pept_group=dsqrt(dist_pept_group)
11420 dist_side_calf=dsqrt(dist_side_calf)
11422 pep_side_norm(j)=pep_side(j)/dist_pep_side
11423 side_calf_norm(j)=dist_side_calf
11425 C now sscale fraction
11426 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11427 C print *,buff_shield,"buff"
11429 if (sh_frac_dist.le.0.0) cycle
11430 C If we reach here it means that this side chain reaches the shielding sphere
11431 C Lets add him to the list for gradient
11432 ishield_list(i)=ishield_list(i)+1
11433 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11434 C this list is essential otherwise problem would be O3
11435 shield_list(ishield_list(i),i)=k
11436 C Lets have the sscale value
11437 if (sh_frac_dist.gt.1.0) then
11438 scale_fac_dist=1.0d0
11440 sh_frac_dist_grad(j)=0.0d0
11443 scale_fac_dist=-sh_frac_dist*sh_frac_dist
11444 & *(2.0*sh_frac_dist-3.0d0)
11445 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11446 & /dist_pep_side/buff_shield*0.5
11447 C remember for the final gradient multiply sh_frac_dist_grad(j)
11448 C for side_chain by factor -2 !
11450 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11451 C print *,"jestem",scale_fac_dist,fac_help_scale,
11452 C & sh_frac_dist_grad(j)
11455 C if ((i.eq.3).and.(k.eq.2)) then
11456 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11460 C this is what is now we have the distance scaling now volume...
11461 short=short_r_sidechain(itype(k))
11462 long=long_r_sidechain(itype(k))
11463 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11466 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11467 C costhet_fac=0.0d0
11469 costhet_grad(j)=costhet_fac*pep_side(j)
11471 C remember for the final gradient multiply costhet_grad(j)
11472 C for side_chain by factor -2 !
11473 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11474 C pep_side0pept_group is vector multiplication
11475 pep_side0pept_group=0.0
11477 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11479 cosalfa=(pep_side0pept_group/
11480 & (dist_pep_side*dist_side_calf))
11481 fac_alfa_sin=1.0-cosalfa**2
11482 fac_alfa_sin=dsqrt(fac_alfa_sin)
11483 rkprim=fac_alfa_sin*(long-short)+short
11485 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11486 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11489 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11490 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11491 &*(long-short)/fac_alfa_sin*cosalfa/
11492 &((dist_pep_side*dist_side_calf))*
11493 &((side_calf(j))-cosalfa*
11494 &((pep_side(j)/dist_pep_side)*dist_side_calf))
11496 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11497 &*(long-short)/fac_alfa_sin*cosalfa
11498 &/((dist_pep_side*dist_side_calf))*
11500 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11503 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11506 C now the gradient...
11507 C grad_shield is gradient of Calfa for peptide groups
11508 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11510 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11511 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11513 grad_shield(j,i)=grad_shield(j,i)
11514 C gradient po skalowaniu
11515 & +(sh_frac_dist_grad(j)
11516 C gradient po costhet
11517 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11518 &-scale_fac_dist*(cosphi_grad_long(j))
11519 &/(1.0-cosphi) )*div77_81
11521 C grad_shield_side is Cbeta sidechain gradient
11522 grad_shield_side(j,ishield_list(i),i)=
11523 & (sh_frac_dist_grad(j)*-2.0d0
11524 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11525 & +scale_fac_dist*(cosphi_grad_long(j))
11526 & *2.0d0/(1.0-cosphi))
11527 & *div77_81*VofOverlap
11529 grad_shield_loc(j,ishield_list(i),i)=
11530 & scale_fac_dist*cosphi_grad_loc(j)
11531 & *2.0d0/(1.0-cosphi)
11532 & *div77_81*VofOverlap
11534 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11536 fac_shield(i)=VolumeTotal*div77_81+div4_81
11537 C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11541 C--------------------------------------------------------------------------
11542 double precision function tschebyshev(m,n,x,y)
11544 include "DIMENSIONS"
11546 double precision x(n),y,yy(0:maxvar),aux
11547 c Tschebyshev polynomial. Note that the first term is omitted
11548 c m=0: the constant term is included
11549 c m=1: the constant term is not included
11553 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11562 C--------------------------------------------------------------------------
11563 double precision function gradtschebyshev(m,n,x,y)
11565 include "DIMENSIONS"
11567 double precision x(n+1),y,yy(0:maxvar),aux
11568 c Tschebyshev polynomial. Note that the first term is omitted
11569 c m=0: the constant term is included
11570 c m=1: the constant term is not included
11574 yy(i)=2*y*yy(i-1)-yy(i-2)
11578 aux=aux+x(i+1)*yy(i)*(i+1)
11579 C print *, x(i+1),yy(i),i
11581 gradtschebyshev=aux
11584 C------------------------------------------------------------------------
11585 C first for shielding is setting of function of side-chains
11586 subroutine set_shield_fac2
11587 implicit real*8 (a-h,o-z)
11588 include 'DIMENSIONS'
11589 include 'COMMON.CHAIN'
11590 include 'COMMON.DERIV'
11591 include 'COMMON.IOUNITS'
11592 include 'COMMON.SHIELD'
11593 include 'COMMON.INTERACT'
11594 include 'COMMON.LOCAL'
11596 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11597 double precision div77_81/0.974996043d0/,
11598 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11600 C the vector between center of side_chain and peptide group
11601 double precision pep_side(3),long,side_calf(3),
11602 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11603 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11604 C write(2,*) "ivec",ivec_start,ivec_end
11606 fac_shield(i)=0.0d0
11608 grad_shield(j,i)=0.0d0
11611 C the line belowe needs to be changed for FGPROC>1
11612 do i=ivec_start,ivec_end
11614 C if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11616 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11617 Cif there two consequtive dummy atoms there is no peptide group between them
11618 C the line below has to be changed for FGPROC>1
11621 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11625 C first lets set vector conecting the ithe side-chain with kth side-chain
11626 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11627 C pep_side(j)=2.0d0
11628 C and vector conecting the side-chain with its proper calfa
11629 side_calf(j)=c(j,k+nres)-c(j,k)
11630 C side_calf(j)=2.0d0
11631 pept_group(j)=c(j,i)-c(j,i+1)
11632 C lets have their lenght
11633 dist_pep_side=pep_side(j)**2+dist_pep_side
11634 dist_side_calf=dist_side_calf+side_calf(j)**2
11635 dist_pept_group=dist_pept_group+pept_group(j)**2
11637 dist_pep_side=dsqrt(dist_pep_side)
11638 dist_pept_group=dsqrt(dist_pept_group)
11639 dist_side_calf=dsqrt(dist_side_calf)
11641 pep_side_norm(j)=pep_side(j)/dist_pep_side
11642 side_calf_norm(j)=dist_side_calf
11644 C now sscale fraction
11645 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11646 C print *,buff_shield,"buff"
11648 if (sh_frac_dist.le.0.0) cycle
11649 C print *,ishield_list(i),i
11650 C If we reach here it means that this side chain reaches the shielding sphere
11651 C Lets add him to the list for gradient
11652 ishield_list(i)=ishield_list(i)+1
11653 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11654 C this list is essential otherwise problem would be O3
11655 shield_list(ishield_list(i),i)=k
11656 C Lets have the sscale value
11657 if (sh_frac_dist.gt.1.0) then
11658 scale_fac_dist=1.0d0
11660 sh_frac_dist_grad(j)=0.0d0
11663 scale_fac_dist=-sh_frac_dist*sh_frac_dist
11664 & *(2.0d0*sh_frac_dist-3.0d0)
11665 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11666 & /dist_pep_side/buff_shield*0.5d0
11667 C remember for the final gradient multiply sh_frac_dist_grad(j)
11668 C for side_chain by factor -2 !
11670 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11671 C sh_frac_dist_grad(j)=0.0d0
11672 C scale_fac_dist=1.0d0
11673 C print *,"jestem",scale_fac_dist,fac_help_scale,
11674 C & sh_frac_dist_grad(j)
11677 C this is what is now we have the distance scaling now volume...
11678 short=short_r_sidechain(itype(k))
11679 long=long_r_sidechain(itype(k))
11680 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11681 sinthet=short/dist_pep_side*costhet
11685 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11686 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11687 C & -short/dist_pep_side**2/costhet)
11688 C costhet_fac=0.0d0
11690 costhet_grad(j)=costhet_fac*pep_side(j)
11692 C remember for the final gradient multiply costhet_grad(j)
11693 C for side_chain by factor -2 !
11694 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11695 C pep_side0pept_group is vector multiplication
11696 pep_side0pept_group=0.0d0
11698 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11700 cosalfa=(pep_side0pept_group/
11701 & (dist_pep_side*dist_side_calf))
11702 fac_alfa_sin=1.0d0-cosalfa**2
11703 fac_alfa_sin=dsqrt(fac_alfa_sin)
11704 rkprim=fac_alfa_sin*(long-short)+short
11708 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11710 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11711 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11712 & dist_pep_side**2)
11715 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11716 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11717 &*(long-short)/fac_alfa_sin*cosalfa/
11718 &((dist_pep_side*dist_side_calf))*
11719 &((side_calf(j))-cosalfa*
11720 &((pep_side(j)/dist_pep_side)*dist_side_calf))
11721 C cosphi_grad_long(j)=0.0d0
11722 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11723 &*(long-short)/fac_alfa_sin*cosalfa
11724 &/((dist_pep_side*dist_side_calf))*
11726 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11727 C cosphi_grad_loc(j)=0.0d0
11729 C print *,sinphi,sinthet
11730 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11733 C now the gradient...
11735 grad_shield(j,i)=grad_shield(j,i)
11736 C gradient po skalowaniu
11737 & +(sh_frac_dist_grad(j)*VofOverlap
11738 C gradient po costhet
11739 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11740 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11741 & sinphi/sinthet*costhet*costhet_grad(j)
11742 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11744 C grad_shield_side is Cbeta sidechain gradient
11745 grad_shield_side(j,ishield_list(i),i)=
11746 & (sh_frac_dist_grad(j)*-2.0d0
11748 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11749 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11750 & sinphi/sinthet*costhet*costhet_grad(j)
11751 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11754 grad_shield_loc(j,ishield_list(i),i)=
11755 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11756 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11757 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11761 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11763 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11764 C write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
11768 C-----------------------------------------------------------------------
11769 C-----------------------------------------------------------
11770 C This subroutine is to mimic the histone like structure but as well can be
11771 C utilizet to nanostructures (infinit) small modification has to be used to
11772 C make it finite (z gradient at the ends has to be changes as well as the x,y
11773 C gradient has to be modified at the ends
11774 C The energy function is Kihara potential
11775 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11776 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11777 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11778 C simple Kihara potential
11779 subroutine calctube(Etube)
11780 implicit real*8 (a-h,o-z)
11781 include 'DIMENSIONS'
11782 include 'COMMON.GEO'
11783 include 'COMMON.VAR'
11784 include 'COMMON.LOCAL'
11785 include 'COMMON.CHAIN'
11786 include 'COMMON.DERIV'
11787 include 'COMMON.NAMES'
11788 include 'COMMON.INTERACT'
11789 include 'COMMON.IOUNITS'
11790 include 'COMMON.CALC'
11791 include 'COMMON.CONTROL'
11792 include 'COMMON.SPLITELE'
11793 include 'COMMON.SBRIDGE'
11794 double precision tub_r,vectube(3),enetube(maxres*2)
11799 C first we calculate the distance from tube center
11800 C first sugare-phosphate group for NARES this would be peptide group
11803 C lets ommit dummy atoms for now
11804 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11805 C now calculate distance from center of tube and direction vectors
11806 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
11807 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11808 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
11809 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
11810 vectube(1)=vectube(1)-tubecenter(1)
11811 vectube(2)=vectube(2)-tubecenter(2)
11813 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11814 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11816 C as the tube is infinity we do not calculate the Z-vector use of Z
11819 C now calculte the distance
11820 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11821 C now normalize vector
11822 vectube(1)=vectube(1)/tub_r
11823 vectube(2)=vectube(2)/tub_r
11824 C calculte rdiffrence between r and r0
11827 rdiff6=rdiff**6.0d0
11828 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11829 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11830 C write(iout,*) "TU13",i,rdiff6,enetube(i)
11831 C print *,rdiff,rdiff6,pep_aa_tube
11832 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11833 C now we calculate gradient
11834 fac=(-12.0d0*pep_aa_tube/rdiff6+
11835 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
11836 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
11839 C now direction of gg_tube vector
11841 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
11842 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
11845 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
11847 C Lets not jump over memory as we use many times iti
11849 C lets ommit dummy atoms for now
11851 C in UNRES uncomment the line below as GLY has no side-chain...
11854 vectube(1)=c(1,i+nres)
11855 vectube(1)=mod(vectube(1),boxxsize)
11856 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11857 vectube(2)=c(2,i+nres)
11858 vectube(2)=mod(vectube(2),boxysize)
11859 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
11861 vectube(1)=vectube(1)-tubecenter(1)
11862 vectube(2)=vectube(2)-tubecenter(2)
11864 C as the tube is infinity we do not calculate the Z-vector use of Z
11867 C now calculte the distance
11868 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11869 C now normalize vector
11870 vectube(1)=vectube(1)/tub_r
11871 vectube(2)=vectube(2)/tub_r
11872 C calculte rdiffrence between r and r0
11875 rdiff6=rdiff**6.0d0
11876 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11877 sc_aa_tube=sc_aa_tube_par(iti)
11878 sc_bb_tube=sc_bb_tube_par(iti)
11879 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
11880 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11881 C now we calculate gradient
11882 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
11883 & 6.0d0*sc_bb_tube/rdiff6/rdiff
11884 C now direction of gg_tube vector
11886 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
11887 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
11891 Etube=Etube+enetube(i)
11893 C print *,"ETUBE", etube
11896 C TO DO 1) add to total energy
11897 C 2) add to gradient summation
11898 C 3) add reading parameters (AND of course oppening of PARAM file)
11899 C 4) add reading the center of tube
11901 C 6) add to zerograd
11903 C-----------------------------------------------------------------------
11904 C-----------------------------------------------------------
11905 C This subroutine is to mimic the histone like structure but as well can be
11906 C utilizet to nanostructures (infinit) small modification has to be used to
11907 C make it finite (z gradient at the ends has to be changes as well as the x,y
11908 C gradient has to be modified at the ends
11909 C The energy function is Kihara potential
11910 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11911 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11912 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11913 C simple Kihara potential
11914 subroutine calctube2(Etube)
11915 implicit real*8 (a-h,o-z)
11916 include 'DIMENSIONS'
11917 include 'COMMON.GEO'
11918 include 'COMMON.VAR'
11919 include 'COMMON.LOCAL'
11920 include 'COMMON.CHAIN'
11921 include 'COMMON.DERIV'
11922 include 'COMMON.NAMES'
11923 include 'COMMON.INTERACT'
11924 include 'COMMON.IOUNITS'
11925 include 'COMMON.CALC'
11926 include 'COMMON.CONTROL'
11927 include 'COMMON.SPLITELE'
11928 include 'COMMON.SBRIDGE'
11929 double precision tub_r,vectube(3),enetube(maxres*2)
11934 C first we calculate the distance from tube center
11935 C first sugare-phosphate group for NARES this would be peptide group
11938 C lets ommit dummy atoms for now
11940 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11941 C now calculate distance from center of tube and direction vectors
11942 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
11943 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11944 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
11945 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
11946 vectube(1)=vectube(1)-tubecenter(1)
11947 vectube(2)=vectube(2)-tubecenter(2)
11949 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11950 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11952 C as the tube is infinity we do not calculate the Z-vector use of Z
11955 C now calculte the distance
11956 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11957 C now normalize vector
11958 vectube(1)=vectube(1)/tub_r
11959 vectube(2)=vectube(2)/tub_r
11960 C calculte rdiffrence between r and r0
11963 rdiff6=rdiff**6.0d0
11964 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11965 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11966 C write(iout,*) "TU13",i,rdiff6,enetube(i)
11967 C print *,rdiff,rdiff6,pep_aa_tube
11968 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11969 C now we calculate gradient
11970 fac=(-12.0d0*pep_aa_tube/rdiff6+
11971 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
11972 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
11975 C now direction of gg_tube vector
11977 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
11978 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
11981 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
11983 C Lets not jump over memory as we use many times iti
11985 C lets ommit dummy atoms for now
11987 C in UNRES uncomment the line below as GLY has no side-chain...
11990 vectube(1)=c(1,i+nres)
11991 vectube(1)=mod(vectube(1),boxxsize)
11992 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11993 vectube(2)=c(2,i+nres)
11994 vectube(2)=mod(vectube(2),boxysize)
11995 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
11997 vectube(1)=vectube(1)-tubecenter(1)
11998 vectube(2)=vectube(2)-tubecenter(2)
11999 C THIS FRAGMENT MAKES TUBE FINITE
12000 positi=(mod(c(3,i+nres),boxzsize))
12001 if (positi.le.0) positi=positi+boxzsize
12002 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12003 c for each residue check if it is in lipid or lipid water border area
12004 C respos=mod(c(3,i+nres),boxzsize)
12005 print *,positi,bordtubebot,buftubebot,bordtubetop
12006 if ((positi.gt.bordtubebot)
12007 & .and.(positi.lt.bordtubetop)) then
12008 C the energy transfer exist
12009 if (positi.lt.buftubebot) then
12011 & ((positi-bordtubebot)/tubebufthick)
12012 C lipbufthick is thickenes of lipid buffore
12013 sstube=sscalelip(fracinbuf)
12014 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12015 print *,ssgradtube, sstube,tubetranene(itype(i))
12016 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12017 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12018 C &+ssgradtube*tubetranene(itype(i))
12019 C gg_tube(3,i-1)= gg_tube(3,i-1)
12020 C &+ssgradtube*tubetranene(itype(i))
12021 C print *,"doing sccale for lower part"
12022 elseif (positi.gt.buftubetop) then
12024 &((bordtubetop-positi)/tubebufthick)
12025 sstube=sscalelip(fracinbuf)
12026 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12027 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12028 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12029 C &+ssgradtube*tubetranene(itype(i))
12030 C gg_tube(3,i-1)= gg_tube(3,i-1)
12031 C &+ssgradtube*tubetranene(itype(i))
12032 C print *, "doing sscalefor top part",sslip,fracinbuf
12036 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12037 C print *,"I am in true lipid"
12043 endif ! if in lipid or buffor
12044 CEND OF FINITE FRAGMENT
12045 C as the tube is infinity we do not calculate the Z-vector use of Z
12048 C now calculte the distance
12049 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12050 C now normalize vector
12051 vectube(1)=vectube(1)/tub_r
12052 vectube(2)=vectube(2)/tub_r
12053 C calculte rdiffrence between r and r0
12056 rdiff6=rdiff**6.0d0
12057 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12058 sc_aa_tube=sc_aa_tube_par(iti)
12059 sc_bb_tube=sc_bb_tube_par(iti)
12060 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12061 & *sstube+enetube(i+nres)
12062 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12063 C now we calculate gradient
12064 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12065 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12066 C now direction of gg_tube vector
12068 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12069 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12071 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12072 &+ssgradtube*enetube(i+nres)/sstube
12073 gg_tube(3,i-1)= gg_tube(3,i-1)
12074 &+ssgradtube*enetube(i+nres)/sstube
12078 Etube=Etube+enetube(i)
12080 C print *,"ETUBE", etube
12083 C TO DO 1) add to total energy
12084 C 2) add to gradient summation
12085 C 3) add reading parameters (AND of course oppening of PARAM file)
12086 C 4) add reading the center of tube
12088 C 6) add to zerograd