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 include 'COMMON.SHIELD'
3425 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3426 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3427 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3428 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3429 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3430 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3432 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3434 double precision scal_el /1.0d0/
3436 double precision scal_el /0.5d0/
3439 C 13-go grudnia roku pamietnego...
3440 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3441 & 0.0d0,1.0d0,0.0d0,
3442 & 0.0d0,0.0d0,1.0d0/
3443 cd write(iout,*) 'In EELEC'
3445 cd write(iout,*) 'Type',i
3446 cd write(iout,*) 'B1',B1(:,i)
3447 cd write(iout,*) 'B2',B2(:,i)
3448 cd write(iout,*) 'CC',CC(:,:,i)
3449 cd write(iout,*) 'DD',DD(:,:,i)
3450 cd write(iout,*) 'EE',EE(:,:,i)
3452 cd call check_vecgrad
3454 if (icheckgrad.eq.1) then
3456 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3458 dc_norm(k,i)=dc(k,i)*fac
3460 c write (iout,*) 'i',i,' fac',fac
3463 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3464 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3465 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3466 c call vec_and_deriv
3472 time_mat=time_mat+MPI_Wtime()-time01
3476 cd write (iout,*) 'i=',i
3478 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3481 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3482 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3495 cd print '(a)','Enter EELEC'
3496 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3498 gel_loc_loc(i)=0.0d0
3503 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3505 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3507 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3508 do i=iturn3_start,iturn3_end
3510 C write(iout,*) "tu jest i",i
3511 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3512 C changes suggested by Ana to avoid out of bounds
3513 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3514 c & .or.((i+4).gt.nres)
3515 c & .or.((i-1).le.0)
3516 C end of changes by Ana
3517 & .or. itype(i+2).eq.ntyp1
3518 & .or. itype(i+3).eq.ntyp1) cycle
3519 C Adam: Instructions below will switch off existing interactions
3521 c if(itype(i-1).eq.ntyp1)cycle
3523 c if(i.LT.nres-3)then
3524 c if (itype(i+4).eq.ntyp1) cycle
3529 dx_normi=dc_norm(1,i)
3530 dy_normi=dc_norm(2,i)
3531 dz_normi=dc_norm(3,i)
3532 xmedi=c(1,i)+0.5d0*dxi
3533 ymedi=c(2,i)+0.5d0*dyi
3534 zmedi=c(3,i)+0.5d0*dzi
3535 xmedi=mod(xmedi,boxxsize)
3536 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3537 ymedi=mod(ymedi,boxysize)
3538 if (ymedi.lt.0) ymedi=ymedi+boxysize
3539 zmedi=mod(zmedi,boxzsize)
3540 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3541 zmedi2=mod(zmedi,boxzsize)
3542 if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3543 if ((zmedi2.gt.bordlipbot)
3544 &.and.(zmedi2.lt.bordliptop)) then
3545 C the energy transfer exist
3546 if (zmedi2.lt.buflipbot) then
3547 C what fraction I am in
3549 & ((zmedi2-bordlipbot)/lipbufthick)
3550 C lipbufthick is thickenes of lipid buffore
3551 sslipi=sscalelip(fracinbuf)
3552 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3553 elseif (zmedi2.gt.bufliptop) then
3554 fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3555 sslipi=sscalelip(fracinbuf)
3556 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3566 call eelecij(i,i+2,ees,evdw1,eel_loc)
3567 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3568 num_cont_hb(i)=num_conti
3570 do i=iturn4_start,iturn4_end
3572 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3573 C changes suggested by Ana to avoid out of bounds
3574 c & .or.((i+5).gt.nres)
3575 c & .or.((i-1).le.0)
3576 C end of changes suggested by Ana
3577 & .or. itype(i+3).eq.ntyp1
3578 & .or. itype(i+4).eq.ntyp1
3579 c & .or. itype(i+5).eq.ntyp1
3580 c & .or. itype(i).eq.ntyp1
3581 c & .or. itype(i-1).eq.ntyp1
3586 dx_normi=dc_norm(1,i)
3587 dy_normi=dc_norm(2,i)
3588 dz_normi=dc_norm(3,i)
3589 xmedi=c(1,i)+0.5d0*dxi
3590 ymedi=c(2,i)+0.5d0*dyi
3591 zmedi=c(3,i)+0.5d0*dzi
3592 C Return atom into box, boxxsize is size of box in x dimension
3594 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3595 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3596 C Condition for being inside the proper box
3597 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3598 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3602 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3603 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3604 C Condition for being inside the proper box
3605 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3606 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3610 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3611 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3612 C Condition for being inside the proper box
3613 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3614 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3617 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3618 ymedi=mod(ymedi,boxysize)
3619 if (ymedi.lt.0) ymedi=ymedi+boxysize
3620 zmedi=mod(zmedi,boxzsize)
3621 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3622 zmedi2=mod(zmedi,boxzsize)
3623 if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3624 if ((zmedi2.gt.bordlipbot)
3625 &.and.(zmedi2.lt.bordliptop)) then
3626 C the energy transfer exist
3627 if (zmedi2.lt.buflipbot) then
3628 C what fraction I am in
3630 & ((zmedi2-bordlipbot)/lipbufthick)
3631 C lipbufthick is thickenes of lipid buffore
3632 sslipi=sscalelip(fracinbuf)
3633 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3634 elseif (zmedi2.gt.bufliptop) then
3635 fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3636 sslipi=sscalelip(fracinbuf)
3637 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3646 num_conti=num_cont_hb(i)
3647 c write(iout,*) "JESTEM W PETLI"
3648 call eelecij(i,i+3,ees,evdw1,eel_loc)
3649 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3650 & call eturn4(i,eello_turn4)
3651 num_cont_hb(i)=num_conti
3653 C Loop over all neighbouring boxes
3658 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3661 do i=iatel_s,iatel_e
3664 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3665 C changes suggested by Ana to avoid out of bounds
3666 c & .or.((i+2).gt.nres)
3667 c & .or.((i-1).le.0)
3668 C end of changes by Ana
3669 c & .or. itype(i+2).eq.ntyp1
3670 c & .or. itype(i-1).eq.ntyp1
3675 dx_normi=dc_norm(1,i)
3676 dy_normi=dc_norm(2,i)
3677 dz_normi=dc_norm(3,i)
3678 xmedi=c(1,i)+0.5d0*dxi
3679 ymedi=c(2,i)+0.5d0*dyi
3680 zmedi=c(3,i)+0.5d0*dzi
3681 xmedi=mod(xmedi,boxxsize)
3682 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3683 ymedi=mod(ymedi,boxysize)
3684 if (ymedi.lt.0) ymedi=ymedi+boxysize
3685 zmedi=mod(zmedi,boxzsize)
3686 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3687 if ((zmedi.gt.bordlipbot)
3688 &.and.(zmedi.lt.bordliptop)) then
3689 C the energy transfer exist
3690 if (zmedi.lt.buflipbot) then
3691 C what fraction I am in
3693 & ((zmedi-bordlipbot)/lipbufthick)
3694 C lipbufthick is thickenes of lipid buffore
3695 sslipi=sscalelip(fracinbuf)
3696 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3697 elseif (zmedi.gt.bufliptop) then
3698 fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3699 sslipi=sscalelip(fracinbuf)
3700 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3709 C print *,sslipi,"TU?!"
3710 C xmedi=xmedi+xshift*boxxsize
3711 C ymedi=ymedi+yshift*boxysize
3712 C zmedi=zmedi+zshift*boxzsize
3714 C Return tom into box, boxxsize is size of box in x dimension
3716 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3717 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3718 C Condition for being inside the proper box
3719 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3720 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3724 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3725 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3726 C Condition for being inside the proper box
3727 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3728 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3732 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3733 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3734 cC Condition for being inside the proper box
3735 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3736 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3740 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3741 num_conti=num_cont_hb(i)
3743 do j=ielstart(i),ielend(i)
3745 C write (iout,*) i,j
3747 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3748 C changes suggested by Ana to avoid out of bounds
3749 c & .or.((j+2).gt.nres)
3750 c & .or.((j-1).le.0)
3751 C end of changes by Ana
3752 c & .or.itype(j+2).eq.ntyp1
3753 c & .or.itype(j-1).eq.ntyp1
3755 call eelecij(i,j,ees,evdw1,eel_loc)
3757 num_cont_hb(i)=num_conti
3763 c write (iout,*) "Number of loop steps in EELEC:",ind
3765 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3766 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3768 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3769 ccc eel_loc=eel_loc+eello_turn3
3770 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3773 C-------------------------------------------------------------------------------
3774 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3775 implicit real*8 (a-h,o-z)
3776 include 'DIMENSIONS'
3780 include 'COMMON.CONTROL'
3781 include 'COMMON.IOUNITS'
3782 include 'COMMON.GEO'
3783 include 'COMMON.VAR'
3784 include 'COMMON.LOCAL'
3785 include 'COMMON.CHAIN'
3786 include 'COMMON.DERIV'
3787 include 'COMMON.INTERACT'
3788 include 'COMMON.CONTACTS'
3789 include 'COMMON.TORSION'
3790 include 'COMMON.VECTORS'
3791 include 'COMMON.FFIELD'
3792 include 'COMMON.TIME1'
3793 include 'COMMON.SPLITELE'
3794 include 'COMMON.SHIELD'
3795 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3796 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3797 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3798 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3799 & gmuij2(4),gmuji2(4)
3800 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3801 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3803 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3805 double precision scal_el /1.0d0/
3807 double precision scal_el /0.5d0/
3810 C 13-go grudnia roku pamietnego...
3811 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3812 & 0.0d0,1.0d0,0.0d0,
3813 & 0.0d0,0.0d0,1.0d0/
3814 integer xshift,yshift,zshift
3815 c time00=MPI_Wtime()
3816 cd write (iout,*) "eelecij",i,j
3820 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3821 aaa=app(iteli,itelj)
3822 bbb=bpp(iteli,itelj)
3823 ael6i=ael6(iteli,itelj)
3824 ael3i=ael3(iteli,itelj)
3828 dx_normj=dc_norm(1,j)
3829 dy_normj=dc_norm(2,j)
3830 dz_normj=dc_norm(3,j)
3831 C xj=c(1,j)+0.5D0*dxj-xmedi
3832 C yj=c(2,j)+0.5D0*dyj-ymedi
3833 C zj=c(3,j)+0.5D0*dzj-zmedi
3838 if (xj.lt.0) xj=xj+boxxsize
3840 if (yj.lt.0) yj=yj+boxysize
3842 if (zj.lt.0) zj=zj+boxzsize
3843 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3844 if ((zj.gt.bordlipbot)
3845 &.and.(zj.lt.bordliptop)) then
3846 C the energy transfer exist
3847 if (zj.lt.buflipbot) then
3848 C what fraction I am in
3850 & ((zj-bordlipbot)/lipbufthick)
3851 C lipbufthick is thickenes of lipid buffore
3852 sslipj=sscalelip(fracinbuf)
3853 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3854 elseif (zj.gt.bufliptop) then
3855 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3856 sslipj=sscalelip(fracinbuf)
3857 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3866 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3874 xj=xj_safe+xshift*boxxsize
3875 yj=yj_safe+yshift*boxysize
3876 zj=zj_safe+zshift*boxzsize
3877 dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3878 if(dist_temp.lt.dist_init) then
3888 if (isubchap.eq.1) then
3897 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3899 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3900 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3901 C Condition for being inside the proper box
3902 c if ((xj.gt.((0.5d0)*boxxsize)).or.
3903 c & (xj.lt.((-0.5d0)*boxxsize))) then
3907 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3908 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3909 C Condition for being inside the proper box
3910 c if ((yj.gt.((0.5d0)*boxysize)).or.
3911 c & (yj.lt.((-0.5d0)*boxysize))) then
3915 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3916 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3917 C Condition for being inside the proper box
3918 c if ((zj.gt.((0.5d0)*boxzsize)).or.
3919 c & (zj.lt.((-0.5d0)*boxzsize))) then
3922 C endif !endPBC condintion
3926 rij=xj*xj+yj*yj+zj*zj
3928 sss=sscale(sqrt(rij))
3929 sssgrad=sscagrad(sqrt(rij))
3930 c if (sss.gt.0.0d0) then
3936 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3937 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3938 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3939 fac=cosa-3.0D0*cosb*cosg
3941 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3942 if (j.eq.i+2) ev1=scal_el*ev1
3947 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3951 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3952 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3953 if (shield_mode.gt.0) then
3956 el1=el1*fac_shield(i)**2*fac_shield(j)**2
3957 el2=el2*fac_shield(i)**2*fac_shield(j)**2
3960 C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3961 C & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3967 &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3968 C print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3970 evdw1=evdw1+evdwij*sss
3971 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3972 C print *,sslipi,sslipj,lipscale**2,
3973 C & (sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3974 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3975 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3976 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
3977 cd & xmedi,ymedi,zmedi,xj,yj,zj
3979 if (energy_dec) then
3980 write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
3982 &,iteli,itelj,aaa,evdw1
3984 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3985 &fac_shield(i),fac_shield(j)
3989 C Calculate contributions to the Cartesian gradient.
3992 facvdw=-6*rrmij*(ev1+evdwij)*sss
3993 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3994 facel=-3*rrmij*(el1+eesij)
3995 &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4002 * Radial derivatives. First process both termini of the fragment (i,j)
4007 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4008 & (shield_mode.gt.0)) then
4010 do ilist=1,ishield_list(i)
4011 iresshield=shield_list(ilist,i)
4013 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4015 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4017 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4018 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4019 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4020 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4021 C if (iresshield.gt.i) then
4022 C do ishi=i+1,iresshield-1
4023 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4024 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4028 C do ishi=iresshield,i
4029 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4030 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4036 do ilist=1,ishield_list(j)
4037 iresshield=shield_list(ilist,j)
4039 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4041 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4043 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4044 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4046 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4047 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4048 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4049 C if (iresshield.gt.j) then
4050 C do ishi=j+1,iresshield-1
4051 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4052 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4056 C do ishi=iresshield,j
4057 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4058 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4065 gshieldc(k,i)=gshieldc(k,i)+
4066 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4067 gshieldc(k,j)=gshieldc(k,j)+
4068 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4069 gshieldc(k,i-1)=gshieldc(k,i-1)+
4070 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4071 gshieldc(k,j-1)=gshieldc(k,j-1)+
4072 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4077 c ghalf=0.5D0*ggg(k)
4078 c gelc(k,i)=gelc(k,i)+ghalf
4079 c gelc(k,j)=gelc(k,j)+ghalf
4081 c 9/28/08 AL Gradient compotents will be summed only at the end
4082 C print *,"before", gelc_long(1,i), gelc_long(1,j)
4084 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4085 C & +grad_shield(k,j)*eesij/fac_shield(j)
4086 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4087 C & +grad_shield(k,i)*eesij/fac_shield(i)
4088 C gelc_long(k,i-1)=gelc_long(k,i-1)
4089 C & +grad_shield(k,i)*eesij/fac_shield(i)
4090 C gelc_long(k,j-1)=gelc_long(k,j-1)
4091 C & +grad_shield(k,j)*eesij/fac_shield(j)
4093 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4094 C Lipidic part for lipscale
4095 gelc_long(3,j)=gelc_long(3,j)+
4096 & ssgradlipj*eesij/2.0d0*lipscale**2
4098 gelc_long(3,i)=gelc_long(3,i)+
4099 & ssgradlipi*eesij/2.0d0*lipscale**2
4102 * Loop over residues i+1 thru j-1.
4106 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4109 if (sss.gt.0.0) then
4110 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4111 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4113 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4114 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4116 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4117 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4124 c ghalf=0.5D0*ggg(k)
4125 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4126 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4128 c 9/28/08 AL Gradient compotents will be summed only at the end
4130 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4131 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4133 C Lipidic part for scaling weight
4134 gvdwpp(3,j)=gvdwpp(3,j)+
4135 & sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4136 gvdwpp(3,i)=gvdwpp(3,i)+
4137 & sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4140 * Loop over residues i+1 thru j-1.
4144 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4149 facvdw=(ev1+evdwij)*sss
4150 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4153 fac=-3*rrmij*(facvdw+facvdw+facel)
4158 * Radial derivatives. First process both termini of the fragment (i,j)
4161 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4163 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4165 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4167 c ghalf=0.5D0*ggg(k)
4168 c gelc(k,i)=gelc(k,i)+ghalf
4169 c gelc(k,j)=gelc(k,j)+ghalf
4171 c 9/28/08 AL Gradient compotents will be summed only at the end
4173 gelc_long(k,j)=gelc(k,j)+ggg(k)
4174 gelc_long(k,i)=gelc(k,i)-ggg(k)
4177 * Loop over residues i+1 thru j-1.
4181 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4184 c 9/28/08 AL Gradient compotents will be summed only at the end
4185 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4186 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4188 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4189 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4191 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4192 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4194 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4195 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4197 gvdwpp(3,j)=gvdwpp(3,j)+
4198 & sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4199 gvdwpp(3,i)=gvdwpp(3,i)+
4200 & sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4206 ecosa=2.0D0*fac3*fac1+fac4
4209 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4210 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4212 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4213 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4215 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4216 cd & (dcosg(k),k=1,3)
4218 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4219 & fac_shield(i)**2*fac_shield(j)**2
4220 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4223 c ghalf=0.5D0*ggg(k)
4224 c gelc(k,i)=gelc(k,i)+ghalf
4225 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4226 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4227 c gelc(k,j)=gelc(k,j)+ghalf
4228 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4229 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4233 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4236 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4239 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4240 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4241 & *fac_shield(i)**2*fac_shield(j)**2
4242 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4244 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4245 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4246 & *fac_shield(i)**2*fac_shield(j)**2
4247 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4248 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4249 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4251 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4255 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4256 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4257 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4259 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4260 C energy of a peptide unit is assumed in the form of a second-order
4261 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4262 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4263 C are computed for EVERY pair of non-contiguous peptide groups.
4266 if (j.lt.nres-1) then
4278 muij(kkk)=mu(k,i)*mu(l,j)
4279 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4281 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4282 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4283 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4284 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4285 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4286 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4290 cd write (iout,*) 'EELEC: i',i,' j',j
4291 cd write (iout,*) 'j',j,' j1',j1,' j2',j2
4292 cd write(iout,*) 'muij',muij
4293 ury=scalar(uy(1,i),erij)
4294 urz=scalar(uz(1,i),erij)
4295 vry=scalar(uy(1,j),erij)
4296 vrz=scalar(uz(1,j),erij)
4297 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4298 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4299 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4300 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4301 fac=dsqrt(-ael6i)*r3ij
4306 cd write (iout,'(4i5,4f10.5)')
4307 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4308 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4309 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4310 cd & uy(:,j),uz(:,j)
4311 cd write (iout,'(4f10.5)')
4312 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4313 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4314 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4315 cd write (iout,'(9f10.5/)')
4316 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4317 C Derivatives of the elements of A in virtual-bond vectors
4318 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4320 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4321 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4322 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4323 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4324 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4325 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4326 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4327 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4328 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4329 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4330 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4331 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4333 C Compute radial contributions to the gradient
4351 C Add the contributions coming from er
4354 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4355 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4356 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4357 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4360 C Derivatives in DC(i)
4361 cgrad ghalf1=0.5d0*agg(k,1)
4362 cgrad ghalf2=0.5d0*agg(k,2)
4363 cgrad ghalf3=0.5d0*agg(k,3)
4364 cgrad ghalf4=0.5d0*agg(k,4)
4365 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4366 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4367 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4368 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4369 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4370 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4371 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4372 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4373 C Derivatives in DC(i+1)
4374 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4375 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4376 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4377 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4378 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4379 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4380 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4381 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4382 C Derivatives in DC(j)
4383 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4384 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4385 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4386 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4387 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4388 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4389 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4390 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4391 C Derivatives in DC(j+1) or DC(nres-1)
4392 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4393 & -3.0d0*vryg(k,3)*ury)
4394 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4395 & -3.0d0*vrzg(k,3)*ury)
4396 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4397 & -3.0d0*vryg(k,3)*urz)
4398 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4399 & -3.0d0*vrzg(k,3)*urz)
4400 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4402 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4415 aggi(k,l)=-aggi(k,l)
4416 aggi1(k,l)=-aggi1(k,l)
4417 aggj(k,l)=-aggj(k,l)
4418 aggj1(k,l)=-aggj1(k,l)
4421 if (j.lt.nres-1) then
4427 aggi(k,l)=-aggi(k,l)
4428 aggi1(k,l)=-aggi1(k,l)
4429 aggj(k,l)=-aggj(k,l)
4430 aggj1(k,l)=-aggj1(k,l)
4441 aggi(k,l)=-aggi(k,l)
4442 aggi1(k,l)=-aggi1(k,l)
4443 aggj(k,l)=-aggj(k,l)
4444 aggj1(k,l)=-aggj1(k,l)
4449 IF (wel_loc.gt.0.0d0) THEN
4450 C Contribution to the local-electrostatic energy coming from the i-j pair
4451 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4453 if (shield_mode.eq.0) then
4460 eel_loc_ij=eel_loc_ij
4461 & *fac_shield(i)*fac_shield(j)
4462 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4464 C Now derivative over eel_loc
4465 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4466 & (shield_mode.gt.0)) then
4469 do ilist=1,ishield_list(i)
4470 iresshield=shield_list(ilist,i)
4472 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4475 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4477 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4478 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4482 do ilist=1,ishield_list(j)
4483 iresshield=shield_list(ilist,j)
4485 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4488 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4490 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4491 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4498 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4499 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4500 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4501 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4502 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4503 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4504 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4505 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4510 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4511 c & ' eel_loc_ij',eel_loc_ij
4512 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4513 C Calculate patrial derivative for theta angle
4515 geel_loc_ij=(a22*gmuij1(1)
4519 & *fac_shield(i)*fac_shield(j)
4520 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4522 c write(iout,*) "derivative over thatai"
4523 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4525 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4526 & geel_loc_ij*wel_loc
4527 c write(iout,*) "derivative over thatai-1"
4528 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4535 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4536 & geel_loc_ij*wel_loc
4537 & *fac_shield(i)*fac_shield(j)
4538 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4541 c Derivative over j residue
4542 geel_loc_ji=a22*gmuji1(1)
4546 c write(iout,*) "derivative over thataj"
4547 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4550 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4551 & geel_loc_ji*wel_loc
4552 & *fac_shield(i)*fac_shield(j)
4553 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4560 c write(iout,*) "derivative over thataj-1"
4561 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4563 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4564 & geel_loc_ji*wel_loc
4565 & *fac_shield(i)*fac_shield(j)
4566 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4569 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4571 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4572 & 'eelloc',i,j,eel_loc_ij
4573 c if (eel_loc_ij.ne.0)
4574 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4575 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4577 eel_loc=eel_loc+eel_loc_ij
4578 C Partial derivatives in virtual-bond dihedral angles gamma
4580 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4581 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4582 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4583 & *fac_shield(i)*fac_shield(j)
4584 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4586 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4587 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4588 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4589 & *fac_shield(i)*fac_shield(j)
4590 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4592 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4594 ggg(l)=(agg(l,1)*muij(1)+
4595 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4596 & *fac_shield(i)*fac_shield(j)
4597 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4599 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4600 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4601 cgrad ghalf=0.5d0*ggg(l)
4602 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4603 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4605 gel_loc_long(3,j)=gel_loc_long(3,j)+
4606 & ssgradlipj*eel_loc_ij/2.0d0*lipscale/
4607 & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4609 gel_loc_long(3,i)=gel_loc_long(3,i)+
4610 & ssgradlipi*eel_loc_ij/2.0d0*lipscale/
4611 & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4615 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4618 C Remaining derivatives of eello
4620 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4621 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4622 & *fac_shield(i)*fac_shield(j)
4623 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4625 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4626 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4627 & *fac_shield(i)*fac_shield(j)
4628 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4630 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4631 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4632 & *fac_shield(i)*fac_shield(j)
4633 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4635 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4636 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4637 & *fac_shield(i)*fac_shield(j)
4638 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4642 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4643 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4644 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4645 & .and. num_conti.le.maxconts) then
4646 c write (iout,*) i,j," entered corr"
4648 C Calculate the contact function. The ith column of the array JCONT will
4649 C contain the numbers of atoms that make contacts with the atom I (of numbers
4650 C greater than I). The arrays FACONT and GACONT will contain the values of
4651 C the contact function and its derivative.
4652 c r0ij=1.02D0*rpp(iteli,itelj)
4653 c r0ij=1.11D0*rpp(iteli,itelj)
4654 r0ij=2.20D0*rpp(iteli,itelj)
4655 c r0ij=1.55D0*rpp(iteli,itelj)
4656 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4657 if (fcont.gt.0.0D0) then
4658 num_conti=num_conti+1
4659 if (num_conti.gt.maxconts) then
4660 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4661 & ' will skip next contacts for this conf.'
4663 jcont_hb(num_conti,i)=j
4664 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4665 cd & " jcont_hb",jcont_hb(num_conti,i)
4666 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4667 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4668 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4670 d_cont(num_conti,i)=rij
4671 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4672 C --- Electrostatic-interaction matrix ---
4673 a_chuj(1,1,num_conti,i)=a22
4674 a_chuj(1,2,num_conti,i)=a23
4675 a_chuj(2,1,num_conti,i)=a32
4676 a_chuj(2,2,num_conti,i)=a33
4677 C --- Gradient of rij
4679 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4686 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4687 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4688 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4689 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4690 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4695 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4696 C Calculate contact energies
4698 wij=cosa-3.0D0*cosb*cosg
4701 c fac3=dsqrt(-ael6i)/r0ij**3
4702 fac3=dsqrt(-ael6i)*r3ij
4703 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4704 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4705 if (ees0tmp.gt.0) then
4706 ees0pij=dsqrt(ees0tmp)
4710 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4711 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4712 if (ees0tmp.gt.0) then
4713 ees0mij=dsqrt(ees0tmp)
4718 if (shield_mode.eq.0) then
4722 ees0plist(num_conti,i)=j
4723 C fac_shield(i)=0.4d0
4724 C fac_shield(j)=0.6d0
4726 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4727 & *fac_shield(i)*fac_shield(j)
4728 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4729 & *fac_shield(i)*fac_shield(j)
4730 C Diagnostics. Comment out or remove after debugging!
4731 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4732 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4733 c ees0m(num_conti,i)=0.0D0
4735 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4736 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4737 C Angular derivatives of the contact function
4738 ees0pij1=fac3/ees0pij
4739 ees0mij1=fac3/ees0mij
4740 fac3p=-3.0D0*fac3*rrmij
4741 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4742 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4744 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4745 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4746 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4747 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4748 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4749 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4750 ecosap=ecosa1+ecosa2
4751 ecosbp=ecosb1+ecosb2
4752 ecosgp=ecosg1+ecosg2
4753 ecosam=ecosa1-ecosa2
4754 ecosbm=ecosb1-ecosb2
4755 ecosgm=ecosg1-ecosg2
4764 facont_hb(num_conti,i)=fcont
4765 fprimcont=fprimcont/rij
4766 cd facont_hb(num_conti,i)=1.0D0
4767 C Following line is for diagnostics.
4770 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4771 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4774 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4775 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4777 gggp(1)=gggp(1)+ees0pijp*xj
4778 gggp(2)=gggp(2)+ees0pijp*yj
4779 gggp(3)=gggp(3)+ees0pijp*zj
4780 gggm(1)=gggm(1)+ees0mijp*xj
4781 gggm(2)=gggm(2)+ees0mijp*yj
4782 gggm(3)=gggm(3)+ees0mijp*zj
4783 C Derivatives due to the contact function
4784 gacont_hbr(1,num_conti,i)=fprimcont*xj
4785 gacont_hbr(2,num_conti,i)=fprimcont*yj
4786 gacont_hbr(3,num_conti,i)=fprimcont*zj
4789 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4790 c following the change of gradient-summation algorithm.
4792 cgrad ghalfp=0.5D0*gggp(k)
4793 cgrad ghalfm=0.5D0*gggm(k)
4794 gacontp_hb1(k,num_conti,i)=!ghalfp
4795 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4796 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4797 & *fac_shield(i)*fac_shield(j)
4799 gacontp_hb2(k,num_conti,i)=!ghalfp
4800 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4801 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4802 & *fac_shield(i)*fac_shield(j)
4804 gacontp_hb3(k,num_conti,i)=gggp(k)
4805 & *fac_shield(i)*fac_shield(j)
4807 gacontm_hb1(k,num_conti,i)=!ghalfm
4808 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4809 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4810 & *fac_shield(i)*fac_shield(j)
4812 gacontm_hb2(k,num_conti,i)=!ghalfm
4813 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4814 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4815 & *fac_shield(i)*fac_shield(j)
4817 gacontm_hb3(k,num_conti,i)=gggm(k)
4818 & *fac_shield(i)*fac_shield(j)
4821 C Diagnostics. Comment out or remove after debugging!
4823 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4824 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4825 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4826 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4827 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4828 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4831 endif ! num_conti.le.maxconts
4834 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4837 ghalf=0.5d0*agg(l,k)
4838 aggi(l,k)=aggi(l,k)+ghalf
4839 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4840 aggj(l,k)=aggj(l,k)+ghalf
4843 if (j.eq.nres-1 .and. i.lt.j-2) then
4846 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4851 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4854 C-----------------------------------------------------------------------------
4855 subroutine eturn3(i,eello_turn3)
4856 C Third- and fourth-order contributions from turns
4857 implicit real*8 (a-h,o-z)
4858 include 'DIMENSIONS'
4859 include 'COMMON.IOUNITS'
4860 include 'COMMON.GEO'
4861 include 'COMMON.VAR'
4862 include 'COMMON.LOCAL'
4863 include 'COMMON.CHAIN'
4864 include 'COMMON.DERIV'
4865 include 'COMMON.INTERACT'
4866 include 'COMMON.CONTACTS'
4867 include 'COMMON.TORSION'
4868 include 'COMMON.VECTORS'
4869 include 'COMMON.FFIELD'
4870 include 'COMMON.CONTROL'
4871 include 'COMMON.SHIELD'
4873 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4874 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4875 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4876 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4877 & auxgmat2(2,2),auxgmatt2(2,2)
4878 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4879 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4880 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4881 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4884 C xj=(c(1,j)+c(1,j+1))/2.0d0
4885 C yj=(c(2,j)+c(2,j+1))/2.0d0
4886 zj=(c(3,j)+c(3,j+1))/2.0d0
4887 C xj=mod(xj,boxxsize)
4888 C if (xj.lt.0) xj=xj+boxxsize
4889 C yj=mod(yj,boxysize)
4890 C if (yj.lt.0) yj=yj+boxysize
4892 if (zj.lt.0) zj=zj+boxzsize
4893 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4894 if ((zj.gt.bordlipbot)
4895 &.and.(zj.lt.bordliptop)) then
4896 C the energy transfer exist
4897 if (zj.lt.buflipbot) then
4898 C what fraction I am in
4900 & ((zj-bordlipbot)/lipbufthick)
4901 C lipbufthick is thickenes of lipid buffore
4902 sslipj=sscalelip(fracinbuf)
4903 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4904 elseif (zj.gt.bufliptop) then
4905 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4906 sslipj=sscalelip(fracinbuf)
4907 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4919 C write (iout,*) "eturn3",i,j,j1,j2
4924 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4926 C Third-order contributions
4933 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4934 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4935 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4936 c auxalary matices for theta gradient
4937 c auxalary matrix for i+1 and constant i+2
4938 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4939 c auxalary matrix for i+2 and constant i+1
4940 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4941 call transpose2(auxmat(1,1),auxmat1(1,1))
4942 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4943 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4944 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4945 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4946 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4947 if (shield_mode.eq.0) then
4955 C & write(iout,*) i,j,fac_shield(i),fac_shield(j)
4956 eello_turn3=eello_turn3+
4957 C & 1.0*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4958 &0.5d0*(pizda(1,1)+pizda(2,2))
4959 & *fac_shield(i)*fac_shield(j)
4960 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4962 &0.5d0*(pizda(1,1)+pizda(2,2))
4963 & *fac_shield(i)*fac_shield(j)
4965 C Derivatives in theta
4966 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4967 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4968 & *fac_shield(i)*fac_shield(j)
4969 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4971 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4972 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4973 & *fac_shield(i)*fac_shield(j)
4974 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4978 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4979 C Derivatives in shield mode
4980 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4981 & (shield_mode.gt.0)) then
4984 do ilist=1,ishield_list(i)
4985 iresshield=shield_list(ilist,i)
4987 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4989 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4991 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4992 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4996 do ilist=1,ishield_list(j)
4997 iresshield=shield_list(ilist,j)
4999 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5001 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5003 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5004 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5011 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5012 & grad_shield(k,i)*eello_t3/fac_shield(i)
5013 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5014 & grad_shield(k,j)*eello_t3/fac_shield(j)
5015 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5016 & grad_shield(k,i)*eello_t3/fac_shield(i)
5017 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5018 & grad_shield(k,j)*eello_t3/fac_shield(j)
5022 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5023 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
5024 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
5025 cd & ' eello_turn3_num',4*eello_turn3_num
5026 C Derivatives in gamma(i)
5027 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5028 call transpose2(auxmat2(1,1),auxmat3(1,1))
5029 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5030 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5031 & *fac_shield(i)*fac_shield(j)
5032 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5034 C Derivatives in gamma(i+1)
5035 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5036 call transpose2(auxmat2(1,1),auxmat3(1,1))
5037 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5038 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5039 & +0.5d0*(pizda(1,1)+pizda(2,2))
5040 & *fac_shield(i)*fac_shield(j)
5041 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5043 C Cartesian derivatives
5045 c ghalf1=0.5d0*agg(l,1)
5046 c ghalf2=0.5d0*agg(l,2)
5047 c ghalf3=0.5d0*agg(l,3)
5048 c ghalf4=0.5d0*agg(l,4)
5049 a_temp(1,1)=aggi(l,1)!+ghalf1
5050 a_temp(1,2)=aggi(l,2)!+ghalf2
5051 a_temp(2,1)=aggi(l,3)!+ghalf3
5052 a_temp(2,2)=aggi(l,4)!+ghalf4
5053 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5054 gcorr3_turn(l,i)=gcorr3_turn(l,i)
5055 & +0.5d0*(pizda(1,1)+pizda(2,2))
5056 & *fac_shield(i)*fac_shield(j)
5057 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5059 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5060 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5061 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5062 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5063 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5064 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5065 & +0.5d0*(pizda(1,1)+pizda(2,2))
5066 & *fac_shield(i)*fac_shield(j)
5067 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5068 a_temp(1,1)=aggj(l,1)!+ghalf1
5069 a_temp(1,2)=aggj(l,2)!+ghalf2
5070 a_temp(2,1)=aggj(l,3)!+ghalf3
5071 a_temp(2,2)=aggj(l,4)!+ghalf4
5072 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5073 gcorr3_turn(l,j)=gcorr3_turn(l,j)
5074 & +0.5d0*(pizda(1,1)+pizda(2,2))
5075 & *fac_shield(i)*fac_shield(j)
5076 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5078 a_temp(1,1)=aggj1(l,1)
5079 a_temp(1,2)=aggj1(l,2)
5080 a_temp(2,1)=aggj1(l,3)
5081 a_temp(2,2)=aggj1(l,4)
5082 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5083 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5084 & +0.5d0*(pizda(1,1)+pizda(2,2))
5085 & *fac_shield(i)*fac_shield(j)
5086 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5088 gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5089 & ssgradlipi*eello_t3/4.0d0*lipscale
5090 gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5091 & ssgradlipj*eello_t3/4.0d0*lipscale
5092 gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5093 & ssgradlipi*eello_t3/4.0d0*lipscale
5094 gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5095 & ssgradlipj*eello_t3/4.0d0*lipscale
5097 C print *,ssgradlipi,ssgradlipj,eello_t3,sslipi,sslipj
5100 C-------------------------------------------------------------------------------
5101 subroutine eturn4(i,eello_turn4)
5102 C Third- and fourth-order contributions from turns
5103 implicit real*8 (a-h,o-z)
5104 include 'DIMENSIONS'
5105 include 'COMMON.IOUNITS'
5106 include 'COMMON.GEO'
5107 include 'COMMON.VAR'
5108 include 'COMMON.LOCAL'
5109 include 'COMMON.CHAIN'
5110 include 'COMMON.DERIV'
5111 include 'COMMON.INTERACT'
5112 include 'COMMON.CONTACTS'
5113 include 'COMMON.TORSION'
5114 include 'COMMON.VECTORS'
5115 include 'COMMON.FFIELD'
5116 include 'COMMON.CONTROL'
5117 include 'COMMON.SHIELD'
5119 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5120 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5121 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5122 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5123 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
5124 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5125 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5126 double precision agg(3,4),aggi(3,4),aggi1(3,4),
5127 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5128 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5129 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5132 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5134 C Fourth-order contributions
5142 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5143 cd call checkint_turn4(i,a_temp,eello_turn4_num)
5144 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5145 c write(iout,*)"WCHODZE W PROGRAM"
5146 zj=(c(3,j)+c(3,j+1))/2.0d0
5147 C xj=mod(xj,boxxsize)
5148 C if (xj.lt.0) xj=xj+boxxsize
5149 C yj=mod(yj,boxysize)
5150 C if (yj.lt.0) yj=yj+boxysize
5152 if (zj.lt.0) zj=zj+boxzsize
5153 C if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
5154 if ((zj.gt.bordlipbot)
5155 &.and.(zj.lt.bordliptop)) then
5156 C the energy transfer exist
5157 if (zj.lt.buflipbot) then
5158 C what fraction I am in
5160 & ((zj-bordlipbot)/lipbufthick)
5161 C lipbufthick is thickenes of lipid buffore
5162 sslipj=sscalelip(fracinbuf)
5163 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5164 elseif (zj.gt.bufliptop) then
5165 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5166 sslipj=sscalelip(fracinbuf)
5167 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5181 iti1=itype2loc(itype(i+1))
5182 iti2=itype2loc(itype(i+2))
5183 iti3=itype2loc(itype(i+3))
5184 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5185 call transpose2(EUg(1,1,i+1),e1t(1,1))
5186 call transpose2(Eug(1,1,i+2),e2t(1,1))
5187 call transpose2(Eug(1,1,i+3),e3t(1,1))
5188 C Ematrix derivative in theta
5189 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5190 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5191 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5192 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5193 c eta1 in derivative theta
5194 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5195 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5196 c auxgvec is derivative of Ub2 so i+3 theta
5197 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5198 c auxalary matrix of E i+1
5199 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5202 s1=scalar2(b1(1,i+2),auxvec(1))
5203 c derivative of theta i+2 with constant i+3
5204 gs23=scalar2(gtb1(1,i+2),auxvec(1))
5205 c derivative of theta i+2 with constant i+2
5206 gs32=scalar2(b1(1,i+2),auxgvec(1))
5207 c derivative of E matix in theta of i+1
5208 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5210 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5211 c ea31 in derivative theta
5212 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5213 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5214 c auxilary matrix auxgvec of Ub2 with constant E matirx
5215 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5216 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5217 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5221 s2=scalar2(b1(1,i+1),auxvec(1))
5222 c derivative of theta i+1 with constant i+3
5223 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5224 c derivative of theta i+2 with constant i+1
5225 gs21=scalar2(b1(1,i+1),auxgvec(1))
5226 c derivative of theta i+3 with constant i+1
5227 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5228 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5230 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5231 c two derivatives over diffetent matrices
5232 c gtae3e2 is derivative over i+3
5233 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5234 c ae3gte2 is derivative over i+2
5235 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5236 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5237 c three possible derivative over theta E matices
5239 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5241 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5243 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5244 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5246 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5247 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5248 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5249 if (shield_mode.eq.0) then
5256 eello_turn4=eello_turn4-(s1+s2+s3)
5257 & *fac_shield(i)*fac_shield(j)
5258 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5260 eello_t4=-(s1+s2+s3)
5261 & *fac_shield(i)*fac_shield(j)
5262 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5263 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5264 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5265 C Now derivative over shield:
5266 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5267 & (shield_mode.gt.0)) then
5270 do ilist=1,ishield_list(i)
5271 iresshield=shield_list(ilist,i)
5273 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5275 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5277 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5278 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5282 do ilist=1,ishield_list(j)
5283 iresshield=shield_list(ilist,j)
5285 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5287 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5289 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5290 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5297 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5298 & grad_shield(k,i)*eello_t4/fac_shield(i)
5299 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5300 & grad_shield(k,j)*eello_t4/fac_shield(j)
5301 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5302 & grad_shield(k,i)*eello_t4/fac_shield(i)
5303 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5304 & grad_shield(k,j)*eello_t4/fac_shield(j)
5313 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5314 cd & ' eello_turn4_num',8*eello_turn4_num
5316 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5317 & -(gs13+gsE13+gsEE1)*wturn4
5318 & *fac_shield(i)*fac_shield(j)
5319 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5321 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5322 & -(gs23+gs21+gsEE2)*wturn4
5323 & *fac_shield(i)*fac_shield(j)
5324 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5326 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5327 & -(gs32+gsE31+gsEE3)*wturn4
5328 & *fac_shield(i)*fac_shield(j)
5329 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5331 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5334 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5335 & 'eturn4',i,j,-(s1+s2+s3)
5336 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5337 c & ' eello_turn4_num',8*eello_turn4_num
5338 C Derivatives in gamma(i)
5339 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5340 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5341 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5342 s1=scalar2(b1(1,i+2),auxvec(1))
5343 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5344 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5345 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5346 & *fac_shield(i)*fac_shield(j)
5347 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5349 C Derivatives in gamma(i+1)
5350 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5351 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5352 s2=scalar2(b1(1,i+1),auxvec(1))
5353 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5354 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5355 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5356 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5357 & *fac_shield(i)*fac_shield(j)
5358 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5360 C Derivatives in gamma(i+2)
5361 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5362 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5363 s1=scalar2(b1(1,i+2),auxvec(1))
5364 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5365 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5366 s2=scalar2(b1(1,i+1),auxvec(1))
5367 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5368 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5369 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5370 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5371 & *fac_shield(i)*fac_shield(j)
5372 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5374 C Cartesian derivatives
5375 C Derivatives of this turn contributions in DC(i+2)
5376 if (j.lt.nres-1) then
5378 a_temp(1,1)=agg(l,1)
5379 a_temp(1,2)=agg(l,2)
5380 a_temp(2,1)=agg(l,3)
5381 a_temp(2,2)=agg(l,4)
5382 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5383 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5384 s1=scalar2(b1(1,i+2),auxvec(1))
5385 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5386 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5387 s2=scalar2(b1(1,i+1),auxvec(1))
5388 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5389 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5390 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5392 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5393 & *fac_shield(i)*fac_shield(j)
5394 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5398 C Remaining derivatives of this turn contribution
5400 a_temp(1,1)=aggi(l,1)
5401 a_temp(1,2)=aggi(l,2)
5402 a_temp(2,1)=aggi(l,3)
5403 a_temp(2,2)=aggi(l,4)
5404 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5405 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5406 s1=scalar2(b1(1,i+2),auxvec(1))
5407 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5408 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5409 s2=scalar2(b1(1,i+1),auxvec(1))
5410 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5411 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5412 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5413 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5414 & *fac_shield(i)*fac_shield(j)
5415 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5417 a_temp(1,1)=aggi1(l,1)
5418 a_temp(1,2)=aggi1(l,2)
5419 a_temp(2,1)=aggi1(l,3)
5420 a_temp(2,2)=aggi1(l,4)
5421 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5422 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5423 s1=scalar2(b1(1,i+2),auxvec(1))
5424 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5425 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5426 s2=scalar2(b1(1,i+1),auxvec(1))
5427 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5428 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5429 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5430 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5431 & *fac_shield(i)*fac_shield(j)
5432 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5434 a_temp(1,1)=aggj(l,1)
5435 a_temp(1,2)=aggj(l,2)
5436 a_temp(2,1)=aggj(l,3)
5437 a_temp(2,2)=aggj(l,4)
5438 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5439 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5440 s1=scalar2(b1(1,i+2),auxvec(1))
5441 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5442 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5443 s2=scalar2(b1(1,i+1),auxvec(1))
5444 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5445 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5446 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5447 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5448 & *fac_shield(i)*fac_shield(j)
5449 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5451 a_temp(1,1)=aggj1(l,1)
5452 a_temp(1,2)=aggj1(l,2)
5453 a_temp(2,1)=aggj1(l,3)
5454 a_temp(2,2)=aggj1(l,4)
5455 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5456 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5457 s1=scalar2(b1(1,i+2),auxvec(1))
5458 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5459 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5460 s2=scalar2(b1(1,i+1),auxvec(1))
5461 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5462 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5463 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5464 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5465 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5466 & *fac_shield(i)*fac_shield(j)
5467 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5469 gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5470 & ssgradlipi*eello_t4/4.0d0*lipscale
5471 gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5472 & ssgradlipj*eello_t4/4.0d0*lipscale
5473 gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5474 & ssgradlipi*eello_t4/4.0d0*lipscale
5475 gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5476 & ssgradlipj*eello_t4/4.0d0*lipscale
5479 C-----------------------------------------------------------------------------
5480 subroutine vecpr(u,v,w)
5481 implicit real*8(a-h,o-z)
5482 dimension u(3),v(3),w(3)
5483 w(1)=u(2)*v(3)-u(3)*v(2)
5484 w(2)=-u(1)*v(3)+u(3)*v(1)
5485 w(3)=u(1)*v(2)-u(2)*v(1)
5488 C-----------------------------------------------------------------------------
5489 subroutine unormderiv(u,ugrad,unorm,ungrad)
5490 C This subroutine computes the derivatives of a normalized vector u, given
5491 C the derivatives computed without normalization conditions, ugrad. Returns
5494 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5495 double precision vec(3)
5496 double precision scalar
5498 c write (2,*) 'ugrad',ugrad
5501 vec(i)=scalar(ugrad(1,i),u(1))
5503 c write (2,*) 'vec',vec
5506 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5509 c write (2,*) 'ungrad',ungrad
5512 C-----------------------------------------------------------------------------
5513 subroutine escp_soft_sphere(evdw2,evdw2_14)
5515 C This subroutine calculates the excluded-volume interaction energy between
5516 C peptide-group centers and side chains and its gradient in virtual-bond and
5517 C side-chain vectors.
5519 implicit real*8 (a-h,o-z)
5520 include 'DIMENSIONS'
5521 include 'COMMON.GEO'
5522 include 'COMMON.VAR'
5523 include 'COMMON.LOCAL'
5524 include 'COMMON.CHAIN'
5525 include 'COMMON.DERIV'
5526 include 'COMMON.INTERACT'
5527 include 'COMMON.FFIELD'
5528 include 'COMMON.IOUNITS'
5529 include 'COMMON.CONTROL'
5534 cd print '(a)','Enter ESCP'
5535 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5539 do i=iatscp_s,iatscp_e
5540 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5542 xi=0.5D0*(c(1,i)+c(1,i+1))
5543 yi=0.5D0*(c(2,i)+c(2,i+1))
5544 zi=0.5D0*(c(3,i)+c(3,i+1))
5545 C Return atom into box, boxxsize is size of box in x dimension
5547 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5548 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5549 C Condition for being inside the proper box
5550 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5551 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5555 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5556 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5557 C Condition for being inside the proper box
5558 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5559 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5563 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5564 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5565 cC Condition for being inside the proper box
5566 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5567 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5571 if (xi.lt.0) xi=xi+boxxsize
5573 if (yi.lt.0) yi=yi+boxysize
5575 if (zi.lt.0) zi=zi+boxzsize
5576 C xi=xi+xshift*boxxsize
5577 C yi=yi+yshift*boxysize
5578 C zi=zi+zshift*boxzsize
5579 do iint=1,nscp_gr(i)
5581 do j=iscpstart(i,iint),iscpend(i,iint)
5582 if (itype(j).eq.ntyp1) cycle
5583 itypj=iabs(itype(j))
5584 C Uncomment following three lines for SC-p interactions
5588 C Uncomment following three lines for Ca-p interactions
5593 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5594 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5595 C Condition for being inside the proper box
5596 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5597 c & (xj.lt.((-0.5d0)*boxxsize))) then
5601 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5602 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5603 cC Condition for being inside the proper box
5604 c if ((yj.gt.((0.5d0)*boxysize)).or.
5605 c & (yj.lt.((-0.5d0)*boxysize))) then
5609 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5610 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5611 C Condition for being inside the proper box
5612 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5613 c & (zj.lt.((-0.5d0)*boxzsize))) then
5616 if (xj.lt.0) xj=xj+boxxsize
5618 if (yj.lt.0) yj=yj+boxysize
5620 if (zj.lt.0) zj=zj+boxzsize
5621 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5629 xj=xj_safe+xshift*boxxsize
5630 yj=yj_safe+yshift*boxysize
5631 zj=zj_safe+zshift*boxzsize
5632 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5633 if(dist_temp.lt.dist_init) then
5643 if (subchap.eq.1) then
5656 rij=xj*xj+yj*yj+zj*zj
5660 if (rij.lt.r0ijsq) then
5661 evdwij=0.25d0*(rij-r0ijsq)**2
5669 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5674 cgrad if (j.lt.i) then
5675 cd write (iout,*) 'j<i'
5676 C Uncomment following three lines for SC-p interactions
5678 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5681 cd write (iout,*) 'j>i'
5683 cgrad ggg(k)=-ggg(k)
5684 C Uncomment following line for SC-p interactions
5685 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5689 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5691 cgrad kstart=min0(i+1,j)
5692 cgrad kend=max0(i-1,j-1)
5693 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5694 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5695 cgrad do k=kstart,kend
5697 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5701 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5702 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5713 C-----------------------------------------------------------------------------
5714 subroutine escp(evdw2,evdw2_14)
5716 C This subroutine calculates the excluded-volume interaction energy between
5717 C peptide-group centers and side chains and its gradient in virtual-bond and
5718 C side-chain vectors.
5720 implicit real*8 (a-h,o-z)
5721 include 'DIMENSIONS'
5722 include 'COMMON.GEO'
5723 include 'COMMON.VAR'
5724 include 'COMMON.LOCAL'
5725 include 'COMMON.CHAIN'
5726 include 'COMMON.DERIV'
5727 include 'COMMON.INTERACT'
5728 include 'COMMON.FFIELD'
5729 include 'COMMON.IOUNITS'
5730 include 'COMMON.CONTROL'
5731 include 'COMMON.SPLITELE'
5735 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5736 cd print '(a)','Enter ESCP'
5737 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5741 do i=iatscp_s,iatscp_e
5742 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5744 xi=0.5D0*(c(1,i)+c(1,i+1))
5745 yi=0.5D0*(c(2,i)+c(2,i+1))
5746 zi=0.5D0*(c(3,i)+c(3,i+1))
5748 if (xi.lt.0) xi=xi+boxxsize
5750 if (yi.lt.0) yi=yi+boxysize
5752 if (zi.lt.0) zi=zi+boxzsize
5753 c xi=xi+xshift*boxxsize
5754 c yi=yi+yshift*boxysize
5755 c zi=zi+zshift*boxzsize
5756 c print *,xi,yi,zi,'polozenie i'
5757 C Return atom into box, boxxsize is size of box in x dimension
5759 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5760 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5761 C Condition for being inside the proper box
5762 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5763 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5767 c print *,xi,boxxsize,"pierwszy"
5769 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5770 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5771 C Condition for being inside the proper box
5772 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5773 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5777 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5778 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5779 C Condition for being inside the proper box
5780 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5781 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5784 do iint=1,nscp_gr(i)
5786 do j=iscpstart(i,iint),iscpend(i,iint)
5787 itypj=iabs(itype(j))
5788 if (itypj.eq.ntyp1) cycle
5789 C Uncomment following three lines for SC-p interactions
5793 C Uncomment following three lines for Ca-p interactions
5798 if (xj.lt.0) xj=xj+boxxsize
5800 if (yj.lt.0) yj=yj+boxysize
5802 if (zj.lt.0) zj=zj+boxzsize
5804 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5805 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5806 C Condition for being inside the proper box
5807 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5808 c & (xj.lt.((-0.5d0)*boxxsize))) then
5812 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5813 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5814 cC Condition for being inside the proper box
5815 c if ((yj.gt.((0.5d0)*boxysize)).or.
5816 c & (yj.lt.((-0.5d0)*boxysize))) then
5820 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5821 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5822 C Condition for being inside the proper box
5823 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5824 c & (zj.lt.((-0.5d0)*boxzsize))) then
5827 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5828 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5836 xj=xj_safe+xshift*boxxsize
5837 yj=yj_safe+yshift*boxysize
5838 zj=zj_safe+zshift*boxzsize
5839 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5840 if(dist_temp.lt.dist_init) then
5850 if (subchap.eq.1) then
5859 c print *,xj,yj,zj,'polozenie j'
5860 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5862 sss=sscale(1.0d0/(dsqrt(rrij)))
5863 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5864 c if (sss.eq.0) print *,'czasem jest OK'
5865 if (sss.le.0.0d0) cycle
5866 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5868 e1=fac*fac*aad(itypj,iteli)
5869 e2=fac*bad(itypj,iteli)
5870 if (iabs(j-i) .le. 2) then
5873 evdw2_14=evdw2_14+(e1+e2)*sss
5876 evdw2=evdw2+evdwij*sss
5877 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5878 & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5881 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5883 fac=-(evdwij+e1)*rrij*sss
5884 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5888 cgrad if (j.lt.i) then
5889 cd write (iout,*) 'j<i'
5890 C Uncomment following three lines for SC-p interactions
5892 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5895 cd write (iout,*) 'j>i'
5897 cgrad ggg(k)=-ggg(k)
5898 C Uncomment following line for SC-p interactions
5899 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5900 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5904 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5906 cgrad kstart=min0(i+1,j)
5907 cgrad kend=max0(i-1,j-1)
5908 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5909 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5910 cgrad do k=kstart,kend
5912 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5916 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5917 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5919 c endif !endif for sscale cutoff
5929 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5930 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5931 gradx_scp(j,i)=expon*gradx_scp(j,i)
5934 C******************************************************************************
5938 C To save time the factor EXPON has been extracted from ALL components
5939 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5942 C******************************************************************************
5945 C--------------------------------------------------------------------------
5946 subroutine edis(ehpb)
5948 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5950 implicit real*8 (a-h,o-z)
5951 include 'DIMENSIONS'
5952 include 'COMMON.SBRIDGE'
5953 include 'COMMON.CHAIN'
5954 include 'COMMON.DERIV'
5955 include 'COMMON.VAR'
5956 include 'COMMON.INTERACT'
5957 include 'COMMON.IOUNITS'
5958 include 'COMMON.CONTROL'
5964 C write (iout,*) ,"link_end",link_end,constr_dist
5965 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5966 cd write(iout,*)'link_start=',link_start,' link_end=',link_end
5967 if (link_end.eq.0) return
5968 do i=link_start,link_end
5969 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5970 C CA-CA distance used in regularization of structure.
5973 C iii and jjj point to the residues for which the distance is assigned.
5974 if (ii.gt.nres) then
5981 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5982 c & dhpb(i),dhpb1(i),forcon(i)
5983 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5984 C distance and angle dependent SS bond potential.
5985 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5986 C & iabs(itype(jjj)).eq.1) then
5987 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5988 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5989 if (.not.dyn_ss .and. i.le.nss) then
5990 C 15/02/13 CC dynamic SSbond - additional check
5991 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5992 & iabs(itype(jjj)).eq.1) then
5993 call ssbond_ene(iii,jjj,eij)
5996 cd write (iout,*) "eij",eij
5997 cd & ' waga=',waga,' fac=',fac
5998 else if (ii.gt.nres .and. jj.gt.nres) then
5999 c Restraints from contact prediction
6001 if (constr_dist.eq.11) then
6002 ehpb=ehpb+fordepth(i)**4.0d0
6003 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6004 fac=fordepth(i)**4.0d0
6005 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6006 if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6007 & ehpb,fordepth(i),dd
6009 if (dhpb1(i).gt.0.0d0) then
6010 ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6011 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6012 c write (iout,*) "beta nmr",
6013 c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6017 C Get the force constant corresponding to this distance.
6019 C Calculate the contribution to energy.
6020 ehpb=ehpb+waga*rdis*rdis
6021 c write (iout,*) "beta reg",dd,waga*rdis*rdis
6023 C Evaluate gradient.
6029 ggg(j)=fac*(c(j,jj)-c(j,ii))
6032 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6033 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6036 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6037 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6040 C Calculate the distance between the two points and its difference from the
6043 if (constr_dist.eq.11) then
6044 ehpb=ehpb+fordepth(i)**4.0d0
6045 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6046 fac=fordepth(i)**4.0d0
6047 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6048 if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6049 & ehpb,fordepth(i),dd
6051 if (dhpb1(i).gt.0.0d0) then
6052 ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6053 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6054 c write (iout,*) "alph nmr",
6055 c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6058 C Get the force constant corresponding to this distance.
6060 C Calculate the contribution to energy.
6061 ehpb=ehpb+waga*rdis*rdis
6062 c write (iout,*) "alpha reg",dd,waga*rdis*rdis
6064 C Evaluate gradient.
6070 ggg(j)=fac*(c(j,jj)-c(j,ii))
6072 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6073 C If this is a SC-SC distance, we need to calculate the contributions to the
6074 C Cartesian gradient in the SC vectors (ghpbx).
6077 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6078 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6081 cgrad do j=iii,jjj-1
6083 cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k)
6087 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6088 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6092 if (constr_dist.ne.11) ehpb=0.5D0*ehpb
6095 C--------------------------------------------------------------------------
6096 subroutine ssbond_ene(i,j,eij)
6098 C Calculate the distance and angle dependent SS-bond potential energy
6099 C using a free-energy function derived based on RHF/6-31G** ab initio
6100 C calculations of diethyl disulfide.
6102 C A. Liwo and U. Kozlowska, 11/24/03
6104 implicit real*8 (a-h,o-z)
6105 include 'DIMENSIONS'
6106 include 'COMMON.SBRIDGE'
6107 include 'COMMON.CHAIN'
6108 include 'COMMON.DERIV'
6109 include 'COMMON.LOCAL'
6110 include 'COMMON.INTERACT'
6111 include 'COMMON.VAR'
6112 include 'COMMON.IOUNITS'
6113 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6114 itypi=iabs(itype(i))
6118 dxi=dc_norm(1,nres+i)
6119 dyi=dc_norm(2,nres+i)
6120 dzi=dc_norm(3,nres+i)
6121 c dsci_inv=dsc_inv(itypi)
6122 dsci_inv=vbld_inv(nres+i)
6123 itypj=iabs(itype(j))
6124 c dscj_inv=dsc_inv(itypj)
6125 dscj_inv=vbld_inv(nres+j)
6129 dxj=dc_norm(1,nres+j)
6130 dyj=dc_norm(2,nres+j)
6131 dzj=dc_norm(3,nres+j)
6132 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6137 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6138 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6139 om12=dxi*dxj+dyi*dyj+dzi*dzj
6141 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6142 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6148 deltat12=om2-om1+2.0d0
6150 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6151 & +akct*deltad*deltat12
6152 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6153 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6154 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6155 c & " deltat12",deltat12," eij",eij
6156 ed=2*akcm*deltad+akct*deltat12
6158 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6159 eom1=-2*akth*deltat1-pom1-om2*pom2
6160 eom2= 2*akth*deltat2+pom1-om1*pom2
6163 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6164 ghpbx(k,i)=ghpbx(k,i)-ggk
6165 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6166 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6167 ghpbx(k,j)=ghpbx(k,j)+ggk
6168 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6169 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6170 ghpbc(k,i)=ghpbc(k,i)-ggk
6171 ghpbc(k,j)=ghpbc(k,j)+ggk
6174 C Calculate the components of the gradient in DC and X
6178 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
6183 C--------------------------------------------------------------------------
6184 subroutine ebond(estr)
6186 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6188 implicit real*8 (a-h,o-z)
6189 include 'DIMENSIONS'
6190 include 'COMMON.LOCAL'
6191 include 'COMMON.GEO'
6192 include 'COMMON.INTERACT'
6193 include 'COMMON.DERIV'
6194 include 'COMMON.VAR'
6195 include 'COMMON.CHAIN'
6196 include 'COMMON.IOUNITS'
6197 include 'COMMON.NAMES'
6198 include 'COMMON.FFIELD'
6199 include 'COMMON.CONTROL'
6200 include 'COMMON.SETUP'
6201 double precision u(3),ud(3)
6204 do i=ibondp_start,ibondp_end
6205 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6206 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6208 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6209 c & *dc(j,i-1)/vbld(i)
6211 c if (energy_dec) write(iout,*)
6212 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6214 C Checking if it involves dummy (NH3+ or COO-) group
6215 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6216 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
6217 diff = vbld(i)-vbldpDUM
6218 if (energy_dec) write(iout,*) "dum_bond",i,diff
6220 C NO vbldp0 is the equlibrium lenght of spring for peptide group
6221 diff = vbld(i)-vbldp0
6223 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6224 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6227 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6229 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6233 estr=0.5d0*AKP*estr+estr1
6235 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6237 do i=ibond_start,ibond_end
6239 if (iti.ne.10 .and. iti.ne.ntyp1) then
6242 diff=vbld(i+nres)-vbldsc0(1,iti)
6243 if (energy_dec) write (iout,*)
6244 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6245 & AKSC(1,iti),AKSC(1,iti)*diff*diff
6246 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6248 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6252 diff=vbld(i+nres)-vbldsc0(j,iti)
6253 ud(j)=aksc(j,iti)*diff
6254 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6268 uprod2=uprod2*u(k)*u(k)
6272 usumsqder=usumsqder+ud(j)*uprod2
6274 estr=estr+uprod/usum
6276 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6284 C--------------------------------------------------------------------------
6285 subroutine ebend(etheta,ethetacnstr)
6287 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6288 C angles gamma and its derivatives in consecutive thetas and gammas.
6290 implicit real*8 (a-h,o-z)
6291 include 'DIMENSIONS'
6292 include 'COMMON.LOCAL'
6293 include 'COMMON.GEO'
6294 include 'COMMON.INTERACT'
6295 include 'COMMON.DERIV'
6296 include 'COMMON.VAR'
6297 include 'COMMON.CHAIN'
6298 include 'COMMON.IOUNITS'
6299 include 'COMMON.NAMES'
6300 include 'COMMON.FFIELD'
6301 include 'COMMON.CONTROL'
6302 include 'COMMON.TORCNSTR'
6303 common /calcthet/ term1,term2,termm,diffak,ratak,
6304 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6305 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6306 double precision y(2),z(2)
6308 c time11=dexp(-2*time)
6311 c write (*,'(a,i2)') 'EBEND ICG=',icg
6312 do i=ithet_start,ithet_end
6313 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6314 & .or.itype(i).eq.ntyp1) cycle
6315 C Zero the energy function and its derivative at 0 or pi.
6316 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6318 ichir1=isign(1,itype(i-2))
6319 ichir2=isign(1,itype(i))
6320 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6321 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6322 if (itype(i-1).eq.10) then
6323 itype1=isign(10,itype(i-2))
6324 ichir11=isign(1,itype(i-2))
6325 ichir12=isign(1,itype(i-2))
6326 itype2=isign(10,itype(i))
6327 ichir21=isign(1,itype(i))
6328 ichir22=isign(1,itype(i))
6331 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6334 if (phii.ne.phii) phii=150.0
6344 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6347 if (phii1.ne.phii1) phii1=150.0
6359 C Calculate the "mean" value of theta from the part of the distribution
6360 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6361 C In following comments this theta will be referred to as t_c.
6362 thet_pred_mean=0.0d0
6364 athetk=athet(k,it,ichir1,ichir2)
6365 bthetk=bthet(k,it,ichir1,ichir2)
6367 athetk=athet(k,itype1,ichir11,ichir12)
6368 bthetk=bthet(k,itype2,ichir21,ichir22)
6370 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6371 c write(iout,*) 'chuj tu', y(k),z(k)
6373 dthett=thet_pred_mean*ssd
6374 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6375 C Derivatives of the "mean" values in gamma1 and gamma2.
6376 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6377 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6378 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6379 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6381 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6382 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6383 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6384 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6386 if (theta(i).gt.pi-delta) then
6387 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6389 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6390 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6391 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6393 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6395 else if (theta(i).lt.delta) then
6396 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6397 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6398 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6400 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6401 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6404 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6407 etheta=etheta+ethetai
6408 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6409 & 'ebend',i,ethetai,theta(i),itype(i)
6410 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6411 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6412 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6415 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
6416 do i=ithetaconstr_start,ithetaconstr_end
6417 itheta=itheta_constr(i)
6418 thetiii=theta(itheta)
6419 difi=pinorm(thetiii-theta_constr0(i))
6420 if (difi.gt.theta_drange(i)) then
6421 difi=difi-theta_drange(i)
6422 ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6423 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6424 & +for_thet_constr(i)*difi**3
6425 else if (difi.lt.-drange(i)) then
6427 ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6428 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6429 & +for_thet_constr(i)*difi**3
6433 if (energy_dec) then
6434 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6435 & i,itheta,rad2deg*thetiii,
6436 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
6437 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6438 & gloc(itheta+nphi-2,icg)
6442 C Ufff.... We've done all this!!!
6445 C---------------------------------------------------------------------------
6446 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6448 implicit real*8 (a-h,o-z)
6449 include 'DIMENSIONS'
6450 include 'COMMON.LOCAL'
6451 include 'COMMON.IOUNITS'
6452 common /calcthet/ term1,term2,termm,diffak,ratak,
6453 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6454 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6455 C Calculate the contributions to both Gaussian lobes.
6456 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6457 C The "polynomial part" of the "standard deviation" of this part of
6458 C the distributioni.
6459 ccc write (iout,*) thetai,thet_pred_mean
6462 sig=sig*thet_pred_mean+polthet(j,it)
6464 C Derivative of the "interior part" of the "standard deviation of the"
6465 C gamma-dependent Gaussian lobe in t_c.
6466 sigtc=3*polthet(3,it)
6468 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6471 C Set the parameters of both Gaussian lobes of the distribution.
6472 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6473 fac=sig*sig+sigc0(it)
6476 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6477 sigsqtc=-4.0D0*sigcsq*sigtc
6478 c print *,i,sig,sigtc,sigsqtc
6479 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6480 sigtc=-sigtc/(fac*fac)
6481 C Following variable is sigma(t_c)**(-2)
6482 sigcsq=sigcsq*sigcsq
6484 sig0inv=1.0D0/sig0i**2
6485 delthec=thetai-thet_pred_mean
6486 delthe0=thetai-theta0i
6487 term1=-0.5D0*sigcsq*delthec*delthec
6488 term2=-0.5D0*sig0inv*delthe0*delthe0
6489 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6490 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6491 C NaNs in taking the logarithm. We extract the largest exponent which is added
6492 C to the energy (this being the log of the distribution) at the end of energy
6493 C term evaluation for this virtual-bond angle.
6494 if (term1.gt.term2) then
6496 term2=dexp(term2-termm)
6500 term1=dexp(term1-termm)
6503 C The ratio between the gamma-independent and gamma-dependent lobes of
6504 C the distribution is a Gaussian function of thet_pred_mean too.
6505 diffak=gthet(2,it)-thet_pred_mean
6506 ratak=diffak/gthet(3,it)**2
6507 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6508 C Let's differentiate it in thet_pred_mean NOW.
6510 C Now put together the distribution terms to make complete distribution.
6511 termexp=term1+ak*term2
6512 termpre=sigc+ak*sig0i
6513 C Contribution of the bending energy from this theta is just the -log of
6514 C the sum of the contributions from the two lobes and the pre-exponential
6515 C factor. Simple enough, isn't it?
6516 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6517 C write (iout,*) 'termexp',termexp,termm,termpre,i
6518 C NOW the derivatives!!!
6519 C 6/6/97 Take into account the deformation.
6520 E_theta=(delthec*sigcsq*term1
6521 & +ak*delthe0*sig0inv*term2)/termexp
6522 E_tc=((sigtc+aktc*sig0i)/termpre
6523 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6524 & aktc*term2)/termexp)
6527 c-----------------------------------------------------------------------------
6528 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6529 implicit real*8 (a-h,o-z)
6530 include 'DIMENSIONS'
6531 include 'COMMON.LOCAL'
6532 include 'COMMON.IOUNITS'
6533 common /calcthet/ term1,term2,termm,diffak,ratak,
6534 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6535 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6536 delthec=thetai-thet_pred_mean
6537 delthe0=thetai-theta0i
6538 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6539 t3 = thetai-thet_pred_mean
6543 t14 = t12+t6*sigsqtc
6545 t21 = thetai-theta0i
6551 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6552 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6553 & *(-t12*t9-ak*sig0inv*t27)
6557 C--------------------------------------------------------------------------
6558 subroutine ebend(etheta,ethetacnstr)
6560 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6561 C angles gamma and its derivatives in consecutive thetas and gammas.
6562 C ab initio-derived potentials from
6563 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6565 implicit real*8 (a-h,o-z)
6566 include 'DIMENSIONS'
6567 include 'COMMON.LOCAL'
6568 include 'COMMON.GEO'
6569 include 'COMMON.INTERACT'
6570 include 'COMMON.DERIV'
6571 include 'COMMON.VAR'
6572 include 'COMMON.CHAIN'
6573 include 'COMMON.IOUNITS'
6574 include 'COMMON.NAMES'
6575 include 'COMMON.FFIELD'
6576 include 'COMMON.CONTROL'
6577 include 'COMMON.TORCNSTR'
6578 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6579 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6580 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6581 & sinph1ph2(maxdouble,maxdouble)
6582 logical lprn /.false./, lprn1 /.false./
6584 do i=ithet_start,ithet_end
6585 c print *,i,itype(i-1),itype(i),itype(i-2)
6586 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6587 & .or.itype(i).eq.ntyp1) cycle
6588 C print *,i,theta(i)
6589 if (iabs(itype(i+1)).eq.20) iblock=2
6590 if (iabs(itype(i+1)).ne.20) iblock=1
6594 theti2=0.5d0*theta(i)
6595 ityp2=ithetyp((itype(i-1)))
6597 coskt(k)=dcos(k*theti2)
6598 sinkt(k)=dsin(k*theti2)
6601 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6604 if (phii.ne.phii) phii=150.0
6608 ityp1=ithetyp((itype(i-2)))
6609 C propagation of chirality for glycine type
6611 cosph1(k)=dcos(k*phii)
6612 sinph1(k)=dsin(k*phii)
6617 ityp1=ithetyp((itype(i-2)))
6622 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6625 if (phii1.ne.phii1) phii1=150.0
6630 ityp3=ithetyp((itype(i)))
6632 cosph2(k)=dcos(k*phii1)
6633 sinph2(k)=dsin(k*phii1)
6637 ityp3=ithetyp((itype(i)))
6643 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6646 ccl=cosph1(l)*cosph2(k-l)
6647 ssl=sinph1(l)*sinph2(k-l)
6648 scl=sinph1(l)*cosph2(k-l)
6649 csl=cosph1(l)*sinph2(k-l)
6650 cosph1ph2(l,k)=ccl-ssl
6651 cosph1ph2(k,l)=ccl+ssl
6652 sinph1ph2(l,k)=scl+csl
6653 sinph1ph2(k,l)=scl-csl
6657 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6658 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6659 write (iout,*) "coskt and sinkt"
6661 write (iout,*) k,coskt(k),sinkt(k)
6665 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6666 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6669 & write (iout,*) "k",k,"
6670 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6671 & " ethetai",ethetai
6674 write (iout,*) "cosph and sinph"
6676 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6678 write (iout,*) "cosph1ph2 and sinph2ph2"
6681 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6682 & sinph1ph2(l,k),sinph1ph2(k,l)
6685 write(iout,*) "ethetai",ethetai
6690 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6691 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6692 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6693 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6694 ethetai=ethetai+sinkt(m)*aux
6695 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6696 dephii=dephii+k*sinkt(m)*(
6697 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6698 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6699 dephii1=dephii1+k*sinkt(m)*(
6700 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6701 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6703 & write (iout,*) "m",m," k",k," bbthet",
6704 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6705 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6706 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6707 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6708 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6711 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6712 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6713 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6714 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6716 & write(iout,*) "ethetai",ethetai
6717 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6721 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6722 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6723 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6724 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6725 ethetai=ethetai+sinkt(m)*aux
6726 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6727 dephii=dephii+l*sinkt(m)*(
6728 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6729 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6730 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6731 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6732 dephii1=dephii1+(k-l)*sinkt(m)*(
6733 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6734 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6735 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6736 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6738 write (iout,*) "m",m," k",k," l",l," ffthet",
6739 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6740 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6741 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6742 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6743 & " ethetai",ethetai
6744 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6745 & cosph1ph2(k,l)*sinkt(m),
6746 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6755 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6756 & i,theta(i)*rad2deg,phii*rad2deg,
6757 & phii1*rad2deg,ethetai
6759 etheta=etheta+ethetai
6760 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6761 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6762 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6766 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
6767 do i=ithetaconstr_start,ithetaconstr_end
6768 itheta=itheta_constr(i)
6769 thetiii=theta(itheta)
6770 difi=pinorm(thetiii-theta_constr0(i))
6771 if (difi.gt.theta_drange(i)) then
6772 difi=difi-theta_drange(i)
6773 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6774 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6775 & +for_thet_constr(i)*difi**3
6776 else if (difi.lt.-drange(i)) then
6778 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6779 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6780 & +for_thet_constr(i)*difi**3
6784 if (energy_dec) then
6785 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6786 & i,itheta,rad2deg*thetiii,
6787 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
6788 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6789 & gloc(itheta+nphi-2,icg)
6797 c-----------------------------------------------------------------------------
6798 subroutine esc(escloc)
6799 C Calculate the local energy of a side chain and its derivatives in the
6800 C corresponding virtual-bond valence angles THETA and the spherical angles
6802 implicit real*8 (a-h,o-z)
6803 include 'DIMENSIONS'
6804 include 'COMMON.GEO'
6805 include 'COMMON.LOCAL'
6806 include 'COMMON.VAR'
6807 include 'COMMON.INTERACT'
6808 include 'COMMON.DERIV'
6809 include 'COMMON.CHAIN'
6810 include 'COMMON.IOUNITS'
6811 include 'COMMON.NAMES'
6812 include 'COMMON.FFIELD'
6813 include 'COMMON.CONTROL'
6814 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6815 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6816 common /sccalc/ time11,time12,time112,theti,it,nlobit
6819 c write (iout,'(a)') 'ESC'
6820 do i=loc_start,loc_end
6822 if (it.eq.ntyp1) cycle
6823 if (it.eq.10) goto 1
6824 nlobit=nlob(iabs(it))
6825 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6826 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6827 theti=theta(i+1)-pipol
6832 if (x(2).gt.pi-delta) then
6836 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6838 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6839 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6841 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6842 & ddersc0(1),dersc(1))
6843 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6844 & ddersc0(3),dersc(3))
6846 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6848 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6849 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6850 & dersc0(2),esclocbi,dersc02)
6851 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6853 call splinthet(x(2),0.5d0*delta,ss,ssd)
6858 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6860 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6861 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6863 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6865 c write (iout,*) escloci
6866 else if (x(2).lt.delta) then
6870 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6872 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6873 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6875 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6876 & ddersc0(1),dersc(1))
6877 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6878 & ddersc0(3),dersc(3))
6880 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6882 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6883 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6884 & dersc0(2),esclocbi,dersc02)
6885 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6890 call splinthet(x(2),0.5d0*delta,ss,ssd)
6892 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6894 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6895 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6897 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6898 c write (iout,*) escloci
6900 call enesc(x,escloci,dersc,ddummy,.false.)
6903 escloc=escloc+escloci
6904 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6905 & 'escloc',i,escloci
6906 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6908 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6910 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6911 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6916 C---------------------------------------------------------------------------
6917 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6918 implicit real*8 (a-h,o-z)
6919 include 'DIMENSIONS'
6920 include 'COMMON.GEO'
6921 include 'COMMON.LOCAL'
6922 include 'COMMON.IOUNITS'
6923 common /sccalc/ time11,time12,time112,theti,it,nlobit
6924 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6925 double precision contr(maxlob,-1:1)
6927 c write (iout,*) 'it=',it,' nlobit=',nlobit
6931 if (mixed) ddersc(j)=0.0d0
6935 C Because of periodicity of the dependence of the SC energy in omega we have
6936 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6937 C To avoid underflows, first compute & store the exponents.
6945 z(k)=x(k)-censc(k,j,it)
6950 Axk=Axk+gaussc(l,k,j,it)*z(l)
6956 expfac=expfac+Ax(k,j,iii)*z(k)
6964 C As in the case of ebend, we want to avoid underflows in exponentiation and
6965 C subsequent NaNs and INFs in energy calculation.
6966 C Find the largest exponent
6970 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6974 cd print *,'it=',it,' emin=',emin
6976 C Compute the contribution to SC energy and derivatives
6981 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6982 if(adexp.ne.adexp) adexp=1.0
6985 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6987 cd print *,'j=',j,' expfac=',expfac
6988 escloc_i=escloc_i+expfac
6990 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6994 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6995 & +gaussc(k,2,j,it))*expfac
7002 dersc(1)=dersc(1)/cos(theti)**2
7003 ddersc(1)=ddersc(1)/cos(theti)**2
7006 escloci=-(dlog(escloc_i)-emin)
7008 dersc(j)=dersc(j)/escloc_i
7012 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7017 C------------------------------------------------------------------------------
7018 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7019 implicit real*8 (a-h,o-z)
7020 include 'DIMENSIONS'
7021 include 'COMMON.GEO'
7022 include 'COMMON.LOCAL'
7023 include 'COMMON.IOUNITS'
7024 common /sccalc/ time11,time12,time112,theti,it,nlobit
7025 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7026 double precision contr(maxlob)
7037 z(k)=x(k)-censc(k,j,it)
7043 Axk=Axk+gaussc(l,k,j,it)*z(l)
7049 expfac=expfac+Ax(k,j)*z(k)
7054 C As in the case of ebend, we want to avoid underflows in exponentiation and
7055 C subsequent NaNs and INFs in energy calculation.
7056 C Find the largest exponent
7059 if (emin.gt.contr(j)) emin=contr(j)
7063 C Compute the contribution to SC energy and derivatives
7067 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7068 escloc_i=escloc_i+expfac
7070 dersc(k)=dersc(k)+Ax(k,j)*expfac
7072 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7073 & +gaussc(1,2,j,it))*expfac
7077 dersc(1)=dersc(1)/cos(theti)**2
7078 dersc12=dersc12/cos(theti)**2
7079 escloci=-(dlog(escloc_i)-emin)
7081 dersc(j)=dersc(j)/escloc_i
7083 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7087 c----------------------------------------------------------------------------------
7088 subroutine esc(escloc)
7089 C Calculate the local energy of a side chain and its derivatives in the
7090 C corresponding virtual-bond valence angles THETA and the spherical angles
7091 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7092 C added by Urszula Kozlowska. 07/11/2007
7094 implicit real*8 (a-h,o-z)
7095 include 'DIMENSIONS'
7096 include 'COMMON.GEO'
7097 include 'COMMON.LOCAL'
7098 include 'COMMON.VAR'
7099 include 'COMMON.SCROT'
7100 include 'COMMON.INTERACT'
7101 include 'COMMON.DERIV'
7102 include 'COMMON.CHAIN'
7103 include 'COMMON.IOUNITS'
7104 include 'COMMON.NAMES'
7105 include 'COMMON.FFIELD'
7106 include 'COMMON.CONTROL'
7107 include 'COMMON.VECTORS'
7108 double precision x_prime(3),y_prime(3),z_prime(3)
7109 & , sumene,dsc_i,dp2_i,x(65),
7110 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7111 & de_dxx,de_dyy,de_dzz,de_dt
7112 double precision s1_t,s1_6_t,s2_t,s2_6_t
7114 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7115 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7116 & dt_dCi(3),dt_dCi1(3)
7117 common /sccalc/ time11,time12,time112,theti,it,nlobit
7120 do i=loc_start,loc_end
7121 if (itype(i).eq.ntyp1) cycle
7122 costtab(i+1) =dcos(theta(i+1))
7123 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7124 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7125 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7126 cosfac2=0.5d0/(1.0d0+costtab(i+1))
7127 cosfac=dsqrt(cosfac2)
7128 sinfac2=0.5d0/(1.0d0-costtab(i+1))
7129 sinfac=dsqrt(sinfac2)
7131 if (it.eq.10) goto 1
7133 C Compute the axes of tghe local cartesian coordinates system; store in
7134 c x_prime, y_prime and z_prime
7141 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7142 C & dc_norm(3,i+nres)
7144 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7145 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7148 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7151 c write (2,*) "x_prime",(x_prime(j),j=1,3)
7152 c write (2,*) "y_prime",(y_prime(j),j=1,3)
7153 c write (2,*) "z_prime",(z_prime(j),j=1,3)
7154 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7155 c & " xy",scalar(x_prime(1),y_prime(1)),
7156 c & " xz",scalar(x_prime(1),z_prime(1)),
7157 c & " yy",scalar(y_prime(1),y_prime(1)),
7158 c & " yz",scalar(y_prime(1),z_prime(1)),
7159 c & " zz",scalar(z_prime(1),z_prime(1))
7161 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7162 C to local coordinate system. Store in xx, yy, zz.
7168 xx = xx + x_prime(j)*dc_norm(j,i+nres)
7169 yy = yy + y_prime(j)*dc_norm(j,i+nres)
7170 zz = zz + z_prime(j)*dc_norm(j,i+nres)
7177 C Compute the energy of the ith side cbain
7179 c write (2,*) "xx",xx," yy",yy," zz",zz
7182 x(j) = sc_parmin(j,it)
7185 Cc diagnostics - remove later
7187 yy1 = dsin(alph(2))*dcos(omeg(2))
7188 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7189 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7190 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7192 C," --- ", xx_w,yy_w,zz_w
7195 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7196 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7198 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7199 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7201 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7202 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7203 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7204 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7205 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7207 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7208 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7209 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7210 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7211 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7213 dsc_i = 0.743d0+x(61)
7215 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7216 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7217 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7218 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7219 s1=(1+x(63))/(0.1d0 + dscp1)
7220 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7221 s2=(1+x(65))/(0.1d0 + dscp2)
7222 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7223 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7224 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7225 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7227 c & dscp1,dscp2,sumene
7228 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7229 escloc = escloc + sumene
7230 c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7235 C This section to check the numerical derivatives of the energy of ith side
7236 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7237 C #define DEBUG in the code to turn it on.
7239 write (2,*) "sumene =",sumene
7243 write (2,*) xx,yy,zz
7244 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7245 de_dxx_num=(sumenep-sumene)/aincr
7247 write (2,*) "xx+ sumene from enesc=",sumenep
7250 write (2,*) xx,yy,zz
7251 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7252 de_dyy_num=(sumenep-sumene)/aincr
7254 write (2,*) "yy+ sumene from enesc=",sumenep
7257 write (2,*) xx,yy,zz
7258 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7259 de_dzz_num=(sumenep-sumene)/aincr
7261 write (2,*) "zz+ sumene from enesc=",sumenep
7262 costsave=cost2tab(i+1)
7263 sintsave=sint2tab(i+1)
7264 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7265 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7266 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7267 de_dt_num=(sumenep-sumene)/aincr
7268 write (2,*) " t+ sumene from enesc=",sumenep
7269 cost2tab(i+1)=costsave
7270 sint2tab(i+1)=sintsave
7271 C End of diagnostics section.
7274 C Compute the gradient of esc
7276 c zz=zz*dsign(1.0,dfloat(itype(i)))
7277 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7278 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7279 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7280 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7281 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7282 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7283 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7284 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7285 pom1=(sumene3*sint2tab(i+1)+sumene1)
7286 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7287 pom2=(sumene4*cost2tab(i+1)+sumene2)
7288 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7289 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7290 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7291 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7293 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7294 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7295 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7297 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7298 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7299 & +(pom1+pom2)*pom_dx
7301 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7304 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7305 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7306 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7308 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7309 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7310 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7311 & +x(59)*zz**2 +x(60)*xx*zz
7312 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7313 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7314 & +(pom1-pom2)*pom_dy
7316 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7319 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7320 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7321 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7322 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7323 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7324 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7325 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7326 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7328 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7331 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7332 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7333 & +pom1*pom_dt1+pom2*pom_dt2
7335 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7340 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7341 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7342 cosfac2xx=cosfac2*xx
7343 sinfac2yy=sinfac2*yy
7345 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7347 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7349 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7350 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7351 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7352 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7353 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7354 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7355 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7356 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7357 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7358 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7362 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7363 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7364 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7365 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7368 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7369 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7370 dZZ_XYZ(k)=vbld_inv(i+nres)*
7371 & (z_prime(k)-zz*dC_norm(k,i+nres))
7373 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7374 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7378 dXX_Ctab(k,i)=dXX_Ci(k)
7379 dXX_C1tab(k,i)=dXX_Ci1(k)
7380 dYY_Ctab(k,i)=dYY_Ci(k)
7381 dYY_C1tab(k,i)=dYY_Ci1(k)
7382 dZZ_Ctab(k,i)=dZZ_Ci(k)
7383 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7384 dXX_XYZtab(k,i)=dXX_XYZ(k)
7385 dYY_XYZtab(k,i)=dYY_XYZ(k)
7386 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7390 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7391 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7392 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7393 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7394 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7396 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7397 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7398 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7399 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7400 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7401 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7402 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7403 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7405 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7406 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7408 C to check gradient call subroutine check_grad
7414 c------------------------------------------------------------------------------
7415 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7417 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7418 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7419 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7420 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7422 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7423 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7425 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7426 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7427 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7428 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7429 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7431 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7432 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7433 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7434 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7435 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7437 dsc_i = 0.743d0+x(61)
7439 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7440 & *(xx*cost2+yy*sint2))
7441 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7442 & *(xx*cost2-yy*sint2))
7443 s1=(1+x(63))/(0.1d0 + dscp1)
7444 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7445 s2=(1+x(65))/(0.1d0 + dscp2)
7446 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7447 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7448 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7453 c------------------------------------------------------------------------------
7454 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7456 C This procedure calculates two-body contact function g(rij) and its derivative:
7459 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7462 C where x=(rij-r0ij)/delta
7464 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7467 double precision rij,r0ij,eps0ij,fcont,fprimcont
7468 double precision x,x2,x4,delta
7472 if (x.lt.-1.0D0) then
7475 else if (x.le.1.0D0) then
7478 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7479 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7486 c------------------------------------------------------------------------------
7487 subroutine splinthet(theti,delta,ss,ssder)
7488 implicit real*8 (a-h,o-z)
7489 include 'DIMENSIONS'
7490 include 'COMMON.VAR'
7491 include 'COMMON.GEO'
7494 if (theti.gt.pipol) then
7495 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7497 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7502 c------------------------------------------------------------------------------
7503 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7505 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7506 double precision ksi,ksi2,ksi3,a1,a2,a3
7507 a1=fprim0*delta/(f1-f0)
7513 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7514 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7517 c------------------------------------------------------------------------------
7518 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7520 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7521 double precision ksi,ksi2,ksi3,a1,a2,a3
7526 a2=3*(f1x-f0x)-2*fprim0x*delta
7527 a3=fprim0x*delta-2*(f1x-f0x)
7528 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7531 C-----------------------------------------------------------------------------
7533 C-----------------------------------------------------------------------------
7534 subroutine etor(etors,edihcnstr)
7535 implicit real*8 (a-h,o-z)
7536 include 'DIMENSIONS'
7537 include 'COMMON.VAR'
7538 include 'COMMON.GEO'
7539 include 'COMMON.LOCAL'
7540 include 'COMMON.TORSION'
7541 include 'COMMON.INTERACT'
7542 include 'COMMON.DERIV'
7543 include 'COMMON.CHAIN'
7544 include 'COMMON.NAMES'
7545 include 'COMMON.IOUNITS'
7546 include 'COMMON.FFIELD'
7547 include 'COMMON.TORCNSTR'
7548 include 'COMMON.CONTROL'
7550 C Set lprn=.true. for debugging
7554 do i=iphi_start,iphi_end
7556 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7557 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7558 itori=itortyp(itype(i-2))
7559 itori1=itortyp(itype(i-1))
7562 C Proline-Proline pair is a special case...
7563 if (itori.eq.3 .and. itori1.eq.3) then
7564 if (phii.gt.-dwapi3) then
7566 fac=1.0D0/(1.0D0-cosphi)
7567 etorsi=v1(1,3,3)*fac
7568 etorsi=etorsi+etorsi
7569 etors=etors+etorsi-v1(1,3,3)
7570 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7571 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7574 v1ij=v1(j+1,itori,itori1)
7575 v2ij=v2(j+1,itori,itori1)
7578 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7579 if (energy_dec) etors_ii=etors_ii+
7580 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7581 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7585 v1ij=v1(j,itori,itori1)
7586 v2ij=v2(j,itori,itori1)
7589 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7590 if (energy_dec) etors_ii=etors_ii+
7591 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7592 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7595 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7598 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7599 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7600 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7601 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7602 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7604 ! 6/20/98 - dihedral angle constraints
7607 itori=idih_constr(i)
7610 if (difi.gt.drange(i)) then
7612 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7613 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7614 else if (difi.lt.-drange(i)) then
7616 edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7617 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7619 ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7620 ! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7622 ! write (iout,*) 'edihcnstr',edihcnstr
7625 c------------------------------------------------------------------------------
7626 subroutine etor_d(etors_d)
7630 c----------------------------------------------------------------------------
7632 subroutine etor(etors,edihcnstr)
7633 implicit real*8 (a-h,o-z)
7634 include 'DIMENSIONS'
7635 include 'COMMON.VAR'
7636 include 'COMMON.GEO'
7637 include 'COMMON.LOCAL'
7638 include 'COMMON.TORSION'
7639 include 'COMMON.INTERACT'
7640 include 'COMMON.DERIV'
7641 include 'COMMON.CHAIN'
7642 include 'COMMON.NAMES'
7643 include 'COMMON.IOUNITS'
7644 include 'COMMON.FFIELD'
7645 include 'COMMON.TORCNSTR'
7646 include 'COMMON.CONTROL'
7648 C Set lprn=.true. for debugging
7652 do i=iphi_start,iphi_end
7653 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7654 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7655 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7656 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7657 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7658 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7659 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7660 C For introducing the NH3+ and COO- group please check the etor_d for reference
7663 if (iabs(itype(i)).eq.20) then
7668 itori=itortyp(itype(i-2))
7669 itori1=itortyp(itype(i-1))
7672 C Regular cosine and sine terms
7673 do j=1,nterm(itori,itori1,iblock)
7674 v1ij=v1(j,itori,itori1,iblock)
7675 v2ij=v2(j,itori,itori1,iblock)
7678 etors=etors+v1ij*cosphi+v2ij*sinphi
7679 if (energy_dec) etors_ii=etors_ii+
7680 & v1ij*cosphi+v2ij*sinphi
7681 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7685 C E = SUM ----------------------------------- - v1
7686 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7688 cosphi=dcos(0.5d0*phii)
7689 sinphi=dsin(0.5d0*phii)
7690 do j=1,nlor(itori,itori1,iblock)
7691 vl1ij=vlor1(j,itori,itori1)
7692 vl2ij=vlor2(j,itori,itori1)
7693 vl3ij=vlor3(j,itori,itori1)
7694 pom=vl2ij*cosphi+vl3ij*sinphi
7695 pom1=1.0d0/(pom*pom+1.0d0)
7696 etors=etors+vl1ij*pom1
7697 if (energy_dec) etors_ii=etors_ii+
7700 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7702 C Subtract the constant term
7703 etors=etors-v0(itori,itori1,iblock)
7704 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7705 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7707 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7708 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7709 & (v1(j,itori,itori1,iblock),j=1,6),
7710 & (v2(j,itori,itori1,iblock),j=1,6)
7711 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7712 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7714 ! 6/20/98 - dihedral angle constraints
7716 c do i=1,ndih_constr
7717 do i=idihconstr_start,idihconstr_end
7718 itori=idih_constr(i)
7720 difi=pinorm(phii-phi0(i))
7721 if (difi.gt.drange(i)) then
7723 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7724 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7725 else if (difi.lt.-drange(i)) then
7727 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7728 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7732 if (energy_dec) then
7733 write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7734 & i,itori,rad2deg*phii,
7735 & rad2deg*phi0(i), rad2deg*drange(i),
7736 & rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7739 cd write (iout,*) 'edihcnstr',edihcnstr
7742 c----------------------------------------------------------------------------
7743 subroutine etor_d(etors_d)
7744 C 6/23/01 Compute double torsional energy
7745 implicit real*8 (a-h,o-z)
7746 include 'DIMENSIONS'
7747 include 'COMMON.VAR'
7748 include 'COMMON.GEO'
7749 include 'COMMON.LOCAL'
7750 include 'COMMON.TORSION'
7751 include 'COMMON.INTERACT'
7752 include 'COMMON.DERIV'
7753 include 'COMMON.CHAIN'
7754 include 'COMMON.NAMES'
7755 include 'COMMON.IOUNITS'
7756 include 'COMMON.FFIELD'
7757 include 'COMMON.TORCNSTR'
7759 C Set lprn=.true. for debugging
7763 c write(iout,*) "a tu??"
7764 do i=iphid_start,iphid_end
7765 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7766 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7767 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7768 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7769 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7770 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7771 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7772 & (itype(i+1).eq.ntyp1)) cycle
7773 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7774 itori=itortyp(itype(i-2))
7775 itori1=itortyp(itype(i-1))
7776 itori2=itortyp(itype(i))
7782 if (iabs(itype(i+1)).eq.20) iblock=2
7783 C Iblock=2 Proline type
7784 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7785 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7786 C if (itype(i+1).eq.ntyp1) iblock=3
7787 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7788 C IS or IS NOT need for this
7789 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7790 C is (itype(i-3).eq.ntyp1) ntblock=2
7791 C ntblock is N-terminal blocking group
7793 C Regular cosine and sine terms
7794 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7795 C Example of changes for NH3+ blocking group
7796 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7797 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7798 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7799 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7800 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7801 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7802 cosphi1=dcos(j*phii)
7803 sinphi1=dsin(j*phii)
7804 cosphi2=dcos(j*phii1)
7805 sinphi2=dsin(j*phii1)
7806 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7807 & v2cij*cosphi2+v2sij*sinphi2
7808 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7809 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7811 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7813 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7814 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7815 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7816 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7817 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7818 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7819 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7820 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7821 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7822 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7823 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7824 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7825 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7826 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7829 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7830 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7835 C----------------------------------------------------------------------------------
7836 C The rigorous attempt to derive energy function
7837 subroutine etor_kcc(etors,edihcnstr)
7838 implicit real*8 (a-h,o-z)
7839 include 'DIMENSIONS'
7840 include 'COMMON.VAR'
7841 include 'COMMON.GEO'
7842 include 'COMMON.LOCAL'
7843 include 'COMMON.TORSION'
7844 include 'COMMON.INTERACT'
7845 include 'COMMON.DERIV'
7846 include 'COMMON.CHAIN'
7847 include 'COMMON.NAMES'
7848 include 'COMMON.IOUNITS'
7849 include 'COMMON.FFIELD'
7850 include 'COMMON.TORCNSTR'
7851 include 'COMMON.CONTROL'
7853 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7854 C Set lprn=.true. for debugging
7857 C print *,"wchodze kcc"
7858 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7859 if (tor_mode.ne.2) then
7862 do i=iphi_start,iphi_end
7863 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7864 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7865 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7866 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7867 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7868 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7869 itori=itortyp_kcc(itype(i-2))
7870 itori1=itortyp_kcc(itype(i-1))
7875 sumnonchebyshev=0.0d0
7877 C to avoid multiple devision by 2
7878 c theti22=0.5d0*theta(i)
7879 C theta 12 is the theta_1 /2
7880 C theta 22 is theta_2 /2
7881 c theti12=0.5d0*theta(i-1)
7882 C and appropriate sinus function
7883 sinthet1=dsin(theta(i-1))
7884 sinthet2=dsin(theta(i))
7885 costhet1=dcos(theta(i-1))
7886 costhet2=dcos(theta(i))
7887 c Cosines of halves thetas
7888 costheti12=0.5d0*(1.0d0+costhet1)
7889 costheti22=0.5d0*(1.0d0+costhet2)
7890 C to speed up lets store its mutliplication
7891 sint1t2=sinthet2*sinthet1
7893 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7894 C +d_n*sin(n*gamma)) *
7895 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7896 C we have two sum 1) Non-Chebyshev which is with n and gamma
7898 do j=1,nterm_kcc(itori,itori1)
7900 nval=nterm_kcc_Tb(itori,itori1)
7901 v1ij=v1_kcc(j,itori,itori1)
7902 v2ij=v2_kcc(j,itori,itori1)
7903 c write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7904 C v1ij is c_n and d_n in euation above
7908 sint1t2n=sint1t2n*sint1t2
7909 sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7911 gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7912 & v11_chyb(1,j,itori,itori1),costheti12)
7913 c write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7914 c & " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7915 sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7917 gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7918 & v21_chyb(1,j,itori,itori1),costheti22)
7919 c write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7920 c & " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7921 sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7923 gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7924 & v12_chyb(1,j,itori,itori1),costheti12)
7925 c write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7926 c & " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7927 sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7929 gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7930 & v22_chyb(1,j,itori,itori1),costheti22)
7931 c write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7932 c & " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7933 C etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7934 C if (energy_dec) etors_ii=etors_ii+
7935 C & v1ij*cosphi+v2ij*sinphi
7936 C glocig is the gradient local i site in gamma
7937 actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7938 actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7939 etori=etori+sint1t2n*(actval1+actval2)
7941 & j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7942 & -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7943 C now gradient over theta_1
7945 & j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7946 & sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7948 & j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7949 & sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7951 C now the Czebyshev polinominal sum
7952 c do k=1,nterm_kcc_Tb(itori,itori1)
7953 c thybt1(k)=v1_chyb(k,j,itori,itori1)
7954 c thybt2(k)=v2_chyb(k,j,itori,itori1)
7958 C print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7960 C & (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7961 C & dcos(theti22)**2),
7964 C now overal sumation
7965 C print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7968 C derivative over gamma
7969 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7970 C derivative over theta1
7971 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7972 C now derivative over theta2
7973 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7975 & write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7976 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7978 C gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7979 ! 6/20/98 - dihedral angle constraints
7980 if (tor_mode.ne.2) then
7982 c do i=1,ndih_constr
7983 do i=idihconstr_start,idihconstr_end
7984 itori=idih_constr(i)
7986 difi=pinorm(phii-phi0(i))
7987 if (difi.gt.drange(i)) then
7989 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7990 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7991 else if (difi.lt.-drange(i)) then
7993 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7994 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8003 C The rigorous attempt to derive energy function
8004 subroutine ebend_kcc(etheta,ethetacnstr)
8006 implicit real*8 (a-h,o-z)
8007 include 'DIMENSIONS'
8008 include 'COMMON.VAR'
8009 include 'COMMON.GEO'
8010 include 'COMMON.LOCAL'
8011 include 'COMMON.TORSION'
8012 include 'COMMON.INTERACT'
8013 include 'COMMON.DERIV'
8014 include 'COMMON.CHAIN'
8015 include 'COMMON.NAMES'
8016 include 'COMMON.IOUNITS'
8017 include 'COMMON.FFIELD'
8018 include 'COMMON.TORCNSTR'
8019 include 'COMMON.CONTROL'
8021 double precision thybt1(maxtermkcc)
8022 C Set lprn=.true. for debugging
8025 C print *,"wchodze kcc"
8026 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8027 if (tor_mode.ne.2) etheta=0.0D0
8028 do i=ithet_start,ithet_end
8029 c print *,i,itype(i-1),itype(i),itype(i-2)
8030 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8031 & .or.itype(i).eq.ntyp1) cycle
8032 iti=itortyp_kcc(itype(i-1))
8033 sinthet=dsin(theta(i)/2.0d0)
8034 costhet=dcos(theta(i)/2.0d0)
8035 do j=1,nbend_kcc_Tb(iti)
8036 thybt1(j)=v1bend_chyb(j,iti)
8038 sumth1thyb=tschebyshev
8039 & (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8040 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8042 ihelp=nbend_kcc_Tb(iti)-1
8043 gradthybt1=gradtschebyshev
8044 & (0,ihelp,thybt1(1),costhet)
8045 etheta=etheta+sumth1thyb
8046 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8047 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
8048 & gradthybt1*sinthet*(-0.5d0)
8050 if (tor_mode.ne.2) then
8052 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8053 do i=ithetaconstr_start,ithetaconstr_end
8054 itheta=itheta_constr(i)
8055 thetiii=theta(itheta)
8056 difi=pinorm(thetiii-theta_constr0(i))
8057 if (difi.gt.theta_drange(i)) then
8058 difi=difi-theta_drange(i)
8059 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8060 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8061 & +for_thet_constr(i)*difi**3
8062 else if (difi.lt.-drange(i)) then
8064 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8065 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8066 & +for_thet_constr(i)*difi**3
8070 if (energy_dec) then
8071 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8072 & i,itheta,rad2deg*thetiii,
8073 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8074 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8075 & gloc(itheta+nphi-2,icg)
8081 c------------------------------------------------------------------------------
8082 subroutine eback_sc_corr(esccor)
8083 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8084 c conformational states; temporarily implemented as differences
8085 c between UNRES torsional potentials (dependent on three types of
8086 c residues) and the torsional potentials dependent on all 20 types
8087 c of residues computed from AM1 energy surfaces of terminally-blocked
8088 c amino-acid residues.
8089 implicit real*8 (a-h,o-z)
8090 include 'DIMENSIONS'
8091 include 'COMMON.VAR'
8092 include 'COMMON.GEO'
8093 include 'COMMON.LOCAL'
8094 include 'COMMON.TORSION'
8095 include 'COMMON.SCCOR'
8096 include 'COMMON.INTERACT'
8097 include 'COMMON.DERIV'
8098 include 'COMMON.CHAIN'
8099 include 'COMMON.NAMES'
8100 include 'COMMON.IOUNITS'
8101 include 'COMMON.FFIELD'
8102 include 'COMMON.CONTROL'
8104 C Set lprn=.true. for debugging
8107 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8109 do i=itau_start,itau_end
8110 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8112 isccori=isccortyp(itype(i-2))
8113 isccori1=isccortyp(itype(i-1))
8114 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8116 do intertyp=1,3 !intertyp
8117 cc Added 09 May 2012 (Adasko)
8118 cc Intertyp means interaction type of backbone mainchain correlation:
8119 c 1 = SC...Ca...Ca...Ca
8120 c 2 = Ca...Ca...Ca...SC
8121 c 3 = SC...Ca...Ca...SCi
8123 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8124 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8125 & (itype(i-1).eq.ntyp1)))
8126 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8127 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8128 & .or.(itype(i).eq.ntyp1)))
8129 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8130 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8131 & (itype(i-3).eq.ntyp1)))) cycle
8132 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8133 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8135 do j=1,nterm_sccor(isccori,isccori1)
8136 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8137 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8138 cosphi=dcos(j*tauangle(intertyp,i))
8139 sinphi=dsin(j*tauangle(intertyp,i))
8140 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8141 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8143 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8144 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8146 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8147 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8148 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8149 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8150 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8156 c----------------------------------------------------------------------------
8157 subroutine multibody(ecorr)
8158 C This subroutine calculates multi-body contributions to energy following
8159 C the idea of Skolnick et al. If side chains I and J make a contact and
8160 C at the same time side chains I+1 and J+1 make a contact, an extra
8161 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8162 implicit real*8 (a-h,o-z)
8163 include 'DIMENSIONS'
8164 include 'COMMON.IOUNITS'
8165 include 'COMMON.DERIV'
8166 include 'COMMON.INTERACT'
8167 include 'COMMON.CONTACTS'
8168 double precision gx(3),gx1(3)
8171 C Set lprn=.true. for debugging
8175 write (iout,'(a)') 'Contact function values:'
8177 write (iout,'(i2,20(1x,i2,f10.5))')
8178 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8193 num_conti=num_cont(i)
8194 num_conti1=num_cont(i1)
8199 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8200 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8201 cd & ' ishift=',ishift
8202 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8203 C The system gains extra energy.
8204 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8205 endif ! j1==j+-ishift
8214 c------------------------------------------------------------------------------
8215 double precision function esccorr(i,j,k,l,jj,kk)
8216 implicit real*8 (a-h,o-z)
8217 include 'DIMENSIONS'
8218 include 'COMMON.IOUNITS'
8219 include 'COMMON.DERIV'
8220 include 'COMMON.INTERACT'
8221 include 'COMMON.CONTACTS'
8222 include 'COMMON.SHIELD'
8223 double precision gx(3),gx1(3)
8228 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8229 C Calculate the multi-body contribution to energy.
8230 C Calculate multi-body contributions to the gradient.
8231 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8232 cd & k,l,(gacont(m,kk,k),m=1,3)
8234 gx(m) =ekl*gacont(m,jj,i)
8235 gx1(m)=eij*gacont(m,kk,k)
8236 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8237 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8238 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8239 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8243 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8248 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8254 c------------------------------------------------------------------------------
8255 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8256 C This subroutine calculates multi-body contributions to hydrogen-bonding
8257 implicit real*8 (a-h,o-z)
8258 include 'DIMENSIONS'
8259 include 'COMMON.IOUNITS'
8262 parameter (max_cont=maxconts)
8263 parameter (max_dim=26)
8264 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8265 double precision zapas(max_dim,maxconts,max_fg_procs),
8266 & zapas_recv(max_dim,maxconts,max_fg_procs)
8267 common /przechowalnia/ zapas
8268 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8269 & status_array(MPI_STATUS_SIZE,maxconts*2)
8271 include 'COMMON.SETUP'
8272 include 'COMMON.FFIELD'
8273 include 'COMMON.DERIV'
8274 include 'COMMON.INTERACT'
8275 include 'COMMON.CONTACTS'
8276 include 'COMMON.CONTROL'
8277 include 'COMMON.LOCAL'
8278 double precision gx(3),gx1(3),time00
8281 C Set lprn=.true. for debugging
8286 if (nfgtasks.le.1) goto 30
8288 write (iout,'(a)') 'Contact function values before RECEIVE:'
8290 write (iout,'(2i3,50(1x,i2,f5.2))')
8291 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8292 & j=1,num_cont_hb(i))
8296 do i=1,ntask_cont_from
8299 do i=1,ntask_cont_to
8302 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8304 C Make the list of contacts to send to send to other procesors
8305 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8307 do i=iturn3_start,iturn3_end
8308 c write (iout,*) "make contact list turn3",i," num_cont",
8310 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8312 do i=iturn4_start,iturn4_end
8313 c write (iout,*) "make contact list turn4",i," num_cont",
8315 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8319 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8321 do j=1,num_cont_hb(i)
8324 iproc=iint_sent_local(k,jjc,ii)
8325 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8326 if (iproc.gt.0) then
8327 ncont_sent(iproc)=ncont_sent(iproc)+1
8328 nn=ncont_sent(iproc)
8330 zapas(2,nn,iproc)=jjc
8331 zapas(3,nn,iproc)=facont_hb(j,i)
8332 zapas(4,nn,iproc)=ees0p(j,i)
8333 zapas(5,nn,iproc)=ees0m(j,i)
8334 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8335 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8336 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8337 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8338 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8339 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8340 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8341 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8342 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8343 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8344 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8345 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8346 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8347 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8348 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8349 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8350 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8351 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8352 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8353 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8354 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8361 & "Numbers of contacts to be sent to other processors",
8362 & (ncont_sent(i),i=1,ntask_cont_to)
8363 write (iout,*) "Contacts sent"
8364 do ii=1,ntask_cont_to
8366 iproc=itask_cont_to(ii)
8367 write (iout,*) nn," contacts to processor",iproc,
8368 & " of CONT_TO_COMM group"
8370 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8378 CorrelID1=nfgtasks+fg_rank+1
8380 C Receive the numbers of needed contacts from other processors
8381 do ii=1,ntask_cont_from
8382 iproc=itask_cont_from(ii)
8384 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8385 & FG_COMM,req(ireq),IERR)
8387 c write (iout,*) "IRECV ended"
8389 C Send the number of contacts needed by other processors
8390 do ii=1,ntask_cont_to
8391 iproc=itask_cont_to(ii)
8393 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8394 & FG_COMM,req(ireq),IERR)
8396 c write (iout,*) "ISEND ended"
8397 c write (iout,*) "number of requests (nn)",ireq
8400 & call MPI_Waitall(ireq,req,status_array,ierr)
8402 c & "Numbers of contacts to be received from other processors",
8403 c & (ncont_recv(i),i=1,ntask_cont_from)
8407 do ii=1,ntask_cont_from
8408 iproc=itask_cont_from(ii)
8410 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8411 c & " of CONT_TO_COMM group"
8415 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8416 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8417 c write (iout,*) "ireq,req",ireq,req(ireq)
8420 C Send the contacts to processors that need them
8421 do ii=1,ntask_cont_to
8422 iproc=itask_cont_to(ii)
8424 c write (iout,*) nn," contacts to processor",iproc,
8425 c & " of CONT_TO_COMM group"
8428 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8429 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8430 c write (iout,*) "ireq,req",ireq,req(ireq)
8432 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8436 c write (iout,*) "number of requests (contacts)",ireq
8437 c write (iout,*) "req",(req(i),i=1,4)
8440 & call MPI_Waitall(ireq,req,status_array,ierr)
8441 do iii=1,ntask_cont_from
8442 iproc=itask_cont_from(iii)
8445 write (iout,*) "Received",nn," contacts from processor",iproc,
8446 & " of CONT_FROM_COMM group"
8449 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8454 ii=zapas_recv(1,i,iii)
8455 c Flag the received contacts to prevent double-counting
8456 jj=-zapas_recv(2,i,iii)
8457 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8459 nnn=num_cont_hb(ii)+1
8462 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8463 ees0p(nnn,ii)=zapas_recv(4,i,iii)
8464 ees0m(nnn,ii)=zapas_recv(5,i,iii)
8465 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8466 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8467 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8468 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8469 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8470 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8471 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8472 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8473 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8474 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8475 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8476 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8477 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8478 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8479 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8480 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8481 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8482 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8483 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8484 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8485 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8490 write (iout,'(a)') 'Contact function values after receive:'
8492 write (iout,'(2i3,50(1x,i3,f5.2))')
8493 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8494 & j=1,num_cont_hb(i))
8501 write (iout,'(a)') 'Contact function values:'
8503 write (iout,'(2i3,50(1x,i3,f5.2))')
8504 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8505 & j=1,num_cont_hb(i))
8509 C Remove the loop below after debugging !!!
8516 C Calculate the local-electrostatic correlation terms
8517 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8519 num_conti=num_cont_hb(i)
8520 num_conti1=num_cont_hb(i+1)
8527 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8528 c & ' jj=',jj,' kk=',kk
8529 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8530 & .or. j.lt.0 .and. j1.gt.0) .and.
8531 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8532 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8533 C The system gains extra energy.
8534 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8535 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8536 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8538 else if (j1.eq.j) then
8539 C Contacts I-J and I-(J+1) occur simultaneously.
8540 C The system loses extra energy.
8541 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8546 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8547 c & ' jj=',jj,' kk=',kk
8549 C Contacts I-J and (I+1)-J occur simultaneously.
8550 C The system loses extra energy.
8551 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8558 c------------------------------------------------------------------------------
8559 subroutine add_hb_contact(ii,jj,itask)
8560 implicit real*8 (a-h,o-z)
8561 include "DIMENSIONS"
8562 include "COMMON.IOUNITS"
8565 parameter (max_cont=maxconts)
8566 parameter (max_dim=26)
8567 include "COMMON.CONTACTS"
8568 double precision zapas(max_dim,maxconts,max_fg_procs),
8569 & zapas_recv(max_dim,maxconts,max_fg_procs)
8570 common /przechowalnia/ zapas
8571 integer i,j,ii,jj,iproc,itask(4),nn
8572 c write (iout,*) "itask",itask
8575 if (iproc.gt.0) then
8576 do j=1,num_cont_hb(ii)
8578 c write (iout,*) "i",ii," j",jj," jjc",jjc
8580 ncont_sent(iproc)=ncont_sent(iproc)+1
8581 nn=ncont_sent(iproc)
8582 zapas(1,nn,iproc)=ii
8583 zapas(2,nn,iproc)=jjc
8584 zapas(3,nn,iproc)=facont_hb(j,ii)
8585 zapas(4,nn,iproc)=ees0p(j,ii)
8586 zapas(5,nn,iproc)=ees0m(j,ii)
8587 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8588 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8589 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8590 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8591 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8592 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8593 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8594 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8595 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8596 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8597 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8598 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8599 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8600 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8601 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8602 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8603 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8604 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8605 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8606 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8607 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8615 c------------------------------------------------------------------------------
8616 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8618 C This subroutine calculates multi-body contributions to hydrogen-bonding
8619 implicit real*8 (a-h,o-z)
8620 include 'DIMENSIONS'
8621 include 'COMMON.IOUNITS'
8624 parameter (max_cont=maxconts)
8625 parameter (max_dim=70)
8626 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8627 double precision zapas(max_dim,maxconts,max_fg_procs),
8628 & zapas_recv(max_dim,maxconts,max_fg_procs)
8629 common /przechowalnia/ zapas
8630 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8631 & status_array(MPI_STATUS_SIZE,maxconts*2)
8633 include 'COMMON.SETUP'
8634 include 'COMMON.FFIELD'
8635 include 'COMMON.DERIV'
8636 include 'COMMON.LOCAL'
8637 include 'COMMON.INTERACT'
8638 include 'COMMON.CONTACTS'
8639 include 'COMMON.CHAIN'
8640 include 'COMMON.CONTROL'
8641 include 'COMMON.SHIELD'
8642 double precision gx(3),gx1(3)
8643 integer num_cont_hb_old(maxres)
8645 double precision eello4,eello5,eelo6,eello_turn6
8646 external eello4,eello5,eello6,eello_turn6
8647 C Set lprn=.true. for debugging
8652 num_cont_hb_old(i)=num_cont_hb(i)
8656 if (nfgtasks.le.1) goto 30
8658 write (iout,'(a)') 'Contact function values before RECEIVE:'
8660 write (iout,'(2i3,50(1x,i2,f5.2))')
8661 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8662 & j=1,num_cont_hb(i))
8666 do i=1,ntask_cont_from
8669 do i=1,ntask_cont_to
8672 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8674 C Make the list of contacts to send to send to other procesors
8675 do i=iturn3_start,iturn3_end
8676 c write (iout,*) "make contact list turn3",i," num_cont",
8678 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8680 do i=iturn4_start,iturn4_end
8681 c write (iout,*) "make contact list turn4",i," num_cont",
8683 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8687 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8689 do j=1,num_cont_hb(i)
8692 iproc=iint_sent_local(k,jjc,ii)
8693 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8694 if (iproc.ne.0) then
8695 ncont_sent(iproc)=ncont_sent(iproc)+1
8696 nn=ncont_sent(iproc)
8698 zapas(2,nn,iproc)=jjc
8699 zapas(3,nn,iproc)=d_cont(j,i)
8703 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8708 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8716 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8727 & "Numbers of contacts to be sent to other processors",
8728 & (ncont_sent(i),i=1,ntask_cont_to)
8729 write (iout,*) "Contacts sent"
8730 do ii=1,ntask_cont_to
8732 iproc=itask_cont_to(ii)
8733 write (iout,*) nn," contacts to processor",iproc,
8734 & " of CONT_TO_COMM group"
8736 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8744 CorrelID1=nfgtasks+fg_rank+1
8746 C Receive the numbers of needed contacts from other processors
8747 do ii=1,ntask_cont_from
8748 iproc=itask_cont_from(ii)
8750 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8751 & FG_COMM,req(ireq),IERR)
8753 c write (iout,*) "IRECV ended"
8755 C Send the number of contacts needed by other processors
8756 do ii=1,ntask_cont_to
8757 iproc=itask_cont_to(ii)
8759 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8760 & FG_COMM,req(ireq),IERR)
8762 c write (iout,*) "ISEND ended"
8763 c write (iout,*) "number of requests (nn)",ireq
8766 & call MPI_Waitall(ireq,req,status_array,ierr)
8768 c & "Numbers of contacts to be received from other processors",
8769 c & (ncont_recv(i),i=1,ntask_cont_from)
8773 do ii=1,ntask_cont_from
8774 iproc=itask_cont_from(ii)
8776 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8777 c & " of CONT_TO_COMM group"
8781 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8782 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8783 c write (iout,*) "ireq,req",ireq,req(ireq)
8786 C Send the contacts to processors that need them
8787 do ii=1,ntask_cont_to
8788 iproc=itask_cont_to(ii)
8790 c write (iout,*) nn," contacts to processor",iproc,
8791 c & " of CONT_TO_COMM group"
8794 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8795 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8796 c write (iout,*) "ireq,req",ireq,req(ireq)
8798 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8802 c write (iout,*) "number of requests (contacts)",ireq
8803 c write (iout,*) "req",(req(i),i=1,4)
8806 & call MPI_Waitall(ireq,req,status_array,ierr)
8807 do iii=1,ntask_cont_from
8808 iproc=itask_cont_from(iii)
8811 write (iout,*) "Received",nn," contacts from processor",iproc,
8812 & " of CONT_FROM_COMM group"
8815 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8820 ii=zapas_recv(1,i,iii)
8821 c Flag the received contacts to prevent double-counting
8822 jj=-zapas_recv(2,i,iii)
8823 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8825 nnn=num_cont_hb(ii)+1
8828 d_cont(nnn,ii)=zapas_recv(3,i,iii)
8832 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8837 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8845 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8854 write (iout,'(a)') 'Contact function values after receive:'
8856 write (iout,'(2i3,50(1x,i3,5f6.3))')
8857 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8858 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8865 write (iout,'(a)') 'Contact function values:'
8867 write (iout,'(2i3,50(1x,i2,5f6.3))')
8868 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8869 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8875 C Remove the loop below after debugging !!!
8882 C Calculate the dipole-dipole interaction energies
8883 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8884 do i=iatel_s,iatel_e+1
8885 num_conti=num_cont_hb(i)
8894 C Calculate the local-electrostatic correlation terms
8895 c write (iout,*) "gradcorr5 in eello5 before loop"
8897 c write (iout,'(i5,3f10.5)')
8898 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8900 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8901 c write (iout,*) "corr loop i",i
8903 num_conti=num_cont_hb(i)
8904 num_conti1=num_cont_hb(i+1)
8911 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8912 c & ' jj=',jj,' kk=',kk
8913 c if (j1.eq.j+1 .or. j1.eq.j-1) then
8914 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8915 & .or. j.lt.0 .and. j1.gt.0) .and.
8916 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8917 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8918 C The system gains extra energy.
8920 sqd1=dsqrt(d_cont(jj,i))
8921 sqd2=dsqrt(d_cont(kk,i1))
8922 sred_geom = sqd1*sqd2
8923 IF (sred_geom.lt.cutoff_corr) THEN
8924 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8926 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8927 cd & ' jj=',jj,' kk=',kk
8928 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8929 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8931 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8932 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8935 cd write (iout,*) 'sred_geom=',sred_geom,
8936 cd & ' ekont=',ekont,' fprim=',fprimcont,
8937 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8938 cd write (iout,*) "g_contij",g_contij
8939 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8940 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8941 call calc_eello(i,jp,i+1,jp1,jj,kk)
8942 if (wcorr4.gt.0.0d0)
8943 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8944 CC & *fac_shield(i)**2*fac_shield(j)**2
8945 if (energy_dec.and.wcorr4.gt.0.0d0)
8946 1 write (iout,'(a6,4i5,0pf7.3)')
8947 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8948 c write (iout,*) "gradcorr5 before eello5"
8950 c write (iout,'(i5,3f10.5)')
8951 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8953 if (wcorr5.gt.0.0d0)
8954 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8955 c write (iout,*) "gradcorr5 after eello5"
8957 c write (iout,'(i5,3f10.5)')
8958 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8960 if (energy_dec.and.wcorr5.gt.0.0d0)
8961 1 write (iout,'(a6,4i5,0pf7.3)')
8962 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8963 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8964 cd write(2,*)'ijkl',i,jp,i+1,jp1
8965 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8966 & .or. wturn6.eq.0.0d0))then
8967 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8968 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8969 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8970 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8971 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8972 cd & 'ecorr6=',ecorr6
8973 cd write (iout,'(4e15.5)') sred_geom,
8974 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8975 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8976 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
8977 else if (wturn6.gt.0.0d0
8978 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8979 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8980 eturn6=eturn6+eello_turn6(i,jj,kk)
8981 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8982 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8983 cd write (2,*) 'multibody_eello:eturn6',eturn6
8992 num_cont_hb(i)=num_cont_hb_old(i)
8994 c write (iout,*) "gradcorr5 in eello5"
8996 c write (iout,'(i5,3f10.5)')
8997 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9001 c------------------------------------------------------------------------------
9002 subroutine add_hb_contact_eello(ii,jj,itask)
9003 implicit real*8 (a-h,o-z)
9004 include "DIMENSIONS"
9005 include "COMMON.IOUNITS"
9008 parameter (max_cont=maxconts)
9009 parameter (max_dim=70)
9010 include "COMMON.CONTACTS"
9011 double precision zapas(max_dim,maxconts,max_fg_procs),
9012 & zapas_recv(max_dim,maxconts,max_fg_procs)
9013 common /przechowalnia/ zapas
9014 integer i,j,ii,jj,iproc,itask(4),nn
9015 c write (iout,*) "itask",itask
9018 if (iproc.gt.0) then
9019 do j=1,num_cont_hb(ii)
9021 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9023 ncont_sent(iproc)=ncont_sent(iproc)+1
9024 nn=ncont_sent(iproc)
9025 zapas(1,nn,iproc)=ii
9026 zapas(2,nn,iproc)=jjc
9027 zapas(3,nn,iproc)=d_cont(j,ii)
9031 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9036 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9044 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9056 c------------------------------------------------------------------------------
9057 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9058 implicit real*8 (a-h,o-z)
9059 include 'DIMENSIONS'
9060 include 'COMMON.IOUNITS'
9061 include 'COMMON.DERIV'
9062 include 'COMMON.INTERACT'
9063 include 'COMMON.CONTACTS'
9064 include 'COMMON.SHIELD'
9065 include 'COMMON.CONTROL'
9066 double precision gx(3),gx1(3)
9069 C print *,"wchodze",fac_shield(i),shield_mode
9077 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9079 C & fac_shield(i)**2*fac_shield(j)**2
9080 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9081 C Following 4 lines for diagnostics.
9086 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9087 c & 'Contacts ',i,j,
9088 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9089 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9091 C Calculate the multi-body contribution to energy.
9092 C ecorr=ecorr+ekont*ees
9093 C Calculate multi-body contributions to the gradient.
9094 coeffpees0pij=coeffp*ees0pij
9095 coeffmees0mij=coeffm*ees0mij
9096 coeffpees0pkl=coeffp*ees0pkl
9097 coeffmees0mkl=coeffm*ees0mkl
9099 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9100 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9101 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9102 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9103 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9104 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9105 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9106 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9107 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9108 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9109 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9110 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9111 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9112 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9113 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9114 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9115 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9116 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9117 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9118 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9119 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9120 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9121 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9122 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9123 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9128 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9129 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9130 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9131 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9136 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9137 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9138 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9139 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9142 c write (iout,*) "ehbcorr",ekont*ees
9143 C print *,ekont,ees,i,k
9145 C now gradient over shielding
9147 if (shield_mode.gt.0) then
9150 C print *,i,j,fac_shield(i),fac_shield(j),
9151 C &fac_shield(k),fac_shield(l)
9152 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9153 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9154 do ilist=1,ishield_list(i)
9155 iresshield=shield_list(ilist,i)
9157 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9159 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9161 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9162 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9166 do ilist=1,ishield_list(j)
9167 iresshield=shield_list(ilist,j)
9169 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9171 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9173 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9174 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9179 do ilist=1,ishield_list(k)
9180 iresshield=shield_list(ilist,k)
9182 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9184 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9186 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9187 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9191 do ilist=1,ishield_list(l)
9192 iresshield=shield_list(ilist,l)
9194 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9196 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9198 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9199 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9203 C print *,gshieldx(m,iresshield)
9205 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9206 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9207 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9208 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9209 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9210 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9211 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9212 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9214 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9215 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9216 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9217 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9218 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9219 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9220 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9221 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9229 C---------------------------------------------------------------------------
9230 subroutine dipole(i,j,jj)
9231 implicit real*8 (a-h,o-z)
9232 include 'DIMENSIONS'
9233 include 'COMMON.IOUNITS'
9234 include 'COMMON.CHAIN'
9235 include 'COMMON.FFIELD'
9236 include 'COMMON.DERIV'
9237 include 'COMMON.INTERACT'
9238 include 'COMMON.CONTACTS'
9239 include 'COMMON.TORSION'
9240 include 'COMMON.VAR'
9241 include 'COMMON.GEO'
9242 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9244 iti1 = itortyp(itype(i+1))
9245 if (j.lt.nres-1) then
9246 itj1 = itype2loc(itype(j+1))
9251 dipi(iii,1)=Ub2(iii,i)
9252 dipderi(iii)=Ub2der(iii,i)
9253 dipi(iii,2)=b1(iii,i+1)
9254 dipj(iii,1)=Ub2(iii,j)
9255 dipderj(iii)=Ub2der(iii,j)
9256 dipj(iii,2)=b1(iii,j+1)
9260 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9263 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9270 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9274 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9279 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9280 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9282 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9284 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9286 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9291 C---------------------------------------------------------------------------
9292 subroutine calc_eello(i,j,k,l,jj,kk)
9294 C This subroutine computes matrices and vectors needed to calculate
9295 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9297 implicit real*8 (a-h,o-z)
9298 include 'DIMENSIONS'
9299 include 'COMMON.IOUNITS'
9300 include 'COMMON.CHAIN'
9301 include 'COMMON.DERIV'
9302 include 'COMMON.INTERACT'
9303 include 'COMMON.CONTACTS'
9304 include 'COMMON.TORSION'
9305 include 'COMMON.VAR'
9306 include 'COMMON.GEO'
9307 include 'COMMON.FFIELD'
9308 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9309 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9312 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9313 cd & ' jj=',jj,' kk=',kk
9314 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9315 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9316 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9319 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9320 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9323 call transpose2(aa1(1,1),aa1t(1,1))
9324 call transpose2(aa2(1,1),aa2t(1,1))
9327 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9328 & aa1tder(1,1,lll,kkk))
9329 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9330 & aa2tder(1,1,lll,kkk))
9334 C parallel orientation of the two CA-CA-CA frames.
9336 iti=itype2loc(itype(i))
9340 itk1=itype2loc(itype(k+1))
9341 itj=itype2loc(itype(j))
9342 if (l.lt.nres-1) then
9343 itl1=itype2loc(itype(l+1))
9347 C A1 kernel(j+1) A2T
9349 cd write (iout,'(3f10.5,5x,3f10.5)')
9350 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9352 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9353 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9354 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9355 C Following matrices are needed only for 6-th order cumulants
9356 IF (wcorr6.gt.0.0d0) THEN
9357 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9358 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9359 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9360 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9361 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9362 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9363 & ADtEAderx(1,1,1,1,1,1))
9365 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9366 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9367 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9368 & ADtEA1derx(1,1,1,1,1,1))
9370 C End 6-th order cumulants
9373 cd write (2,*) 'In calc_eello6'
9375 cd write (2,*) 'iii=',iii
9377 cd write (2,*) 'kkk=',kkk
9379 cd write (2,'(3(2f10.5),5x)')
9380 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9385 call transpose2(EUgder(1,1,k),auxmat(1,1))
9386 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9387 call transpose2(EUg(1,1,k),auxmat(1,1))
9388 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9389 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9393 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9394 & EAEAderx(1,1,lll,kkk,iii,1))
9398 C A1T kernel(i+1) A2
9399 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9400 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9401 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9402 C Following matrices are needed only for 6-th order cumulants
9403 IF (wcorr6.gt.0.0d0) THEN
9404 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9405 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9406 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9407 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9408 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9409 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9410 & ADtEAderx(1,1,1,1,1,2))
9411 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9412 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9413 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9414 & ADtEA1derx(1,1,1,1,1,2))
9416 C End 6-th order cumulants
9417 call transpose2(EUgder(1,1,l),auxmat(1,1))
9418 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9419 call transpose2(EUg(1,1,l),auxmat(1,1))
9420 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9421 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9425 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9426 & EAEAderx(1,1,lll,kkk,iii,2))
9431 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9432 C They are needed only when the fifth- or the sixth-order cumulants are
9434 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9435 call transpose2(AEA(1,1,1),auxmat(1,1))
9436 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9437 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9438 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9439 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9440 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9441 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9442 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9443 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9444 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9445 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9446 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9447 call transpose2(AEA(1,1,2),auxmat(1,1))
9448 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9449 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9450 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9451 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9452 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9453 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9454 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9455 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9456 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9457 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9458 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9459 C Calculate the Cartesian derivatives of the vectors.
9463 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9464 call matvec2(auxmat(1,1),b1(1,i),
9465 & AEAb1derx(1,lll,kkk,iii,1,1))
9466 call matvec2(auxmat(1,1),Ub2(1,i),
9467 & AEAb2derx(1,lll,kkk,iii,1,1))
9468 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9469 & AEAb1derx(1,lll,kkk,iii,2,1))
9470 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9471 & AEAb2derx(1,lll,kkk,iii,2,1))
9472 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9473 call matvec2(auxmat(1,1),b1(1,j),
9474 & AEAb1derx(1,lll,kkk,iii,1,2))
9475 call matvec2(auxmat(1,1),Ub2(1,j),
9476 & AEAb2derx(1,lll,kkk,iii,1,2))
9477 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9478 & AEAb1derx(1,lll,kkk,iii,2,2))
9479 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9480 & AEAb2derx(1,lll,kkk,iii,2,2))
9487 C Antiparallel orientation of the two CA-CA-CA frames.
9489 iti=itype2loc(itype(i))
9493 itk1=itype2loc(itype(k+1))
9494 itl=itype2loc(itype(l))
9495 itj=itype2loc(itype(j))
9496 if (j.lt.nres-1) then
9497 itj1=itype2loc(itype(j+1))
9501 C A2 kernel(j-1)T A1T
9502 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9503 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9504 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9505 C Following matrices are needed only for 6-th order cumulants
9506 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9507 & j.eq.i+4 .and. l.eq.i+3)) THEN
9508 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9509 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9510 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9511 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9512 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9513 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9514 & ADtEAderx(1,1,1,1,1,1))
9515 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9516 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9517 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9518 & ADtEA1derx(1,1,1,1,1,1))
9520 C End 6-th order cumulants
9521 call transpose2(EUgder(1,1,k),auxmat(1,1))
9522 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9523 call transpose2(EUg(1,1,k),auxmat(1,1))
9524 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9525 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9529 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9530 & EAEAderx(1,1,lll,kkk,iii,1))
9534 C A2T kernel(i+1)T A1
9535 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9536 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9537 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9538 C Following matrices are needed only for 6-th order cumulants
9539 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9540 & j.eq.i+4 .and. l.eq.i+3)) THEN
9541 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9542 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9543 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9544 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9545 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9546 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9547 & ADtEAderx(1,1,1,1,1,2))
9548 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9549 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9550 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9551 & ADtEA1derx(1,1,1,1,1,2))
9553 C End 6-th order cumulants
9554 call transpose2(EUgder(1,1,j),auxmat(1,1))
9555 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9556 call transpose2(EUg(1,1,j),auxmat(1,1))
9557 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9558 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9562 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9563 & EAEAderx(1,1,lll,kkk,iii,2))
9568 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9569 C They are needed only when the fifth- or the sixth-order cumulants are
9571 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9572 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9573 call transpose2(AEA(1,1,1),auxmat(1,1))
9574 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9575 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9576 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9577 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9578 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9579 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9580 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9581 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9582 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9583 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9584 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9585 call transpose2(AEA(1,1,2),auxmat(1,1))
9586 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9587 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9588 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9589 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9590 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9591 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9592 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9593 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9594 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9595 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9596 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9597 C Calculate the Cartesian derivatives of the vectors.
9601 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9602 call matvec2(auxmat(1,1),b1(1,i),
9603 & AEAb1derx(1,lll,kkk,iii,1,1))
9604 call matvec2(auxmat(1,1),Ub2(1,i),
9605 & AEAb2derx(1,lll,kkk,iii,1,1))
9606 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9607 & AEAb1derx(1,lll,kkk,iii,2,1))
9608 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9609 & AEAb2derx(1,lll,kkk,iii,2,1))
9610 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9611 call matvec2(auxmat(1,1),b1(1,l),
9612 & AEAb1derx(1,lll,kkk,iii,1,2))
9613 call matvec2(auxmat(1,1),Ub2(1,l),
9614 & AEAb2derx(1,lll,kkk,iii,1,2))
9615 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9616 & AEAb1derx(1,lll,kkk,iii,2,2))
9617 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9618 & AEAb2derx(1,lll,kkk,iii,2,2))
9627 C---------------------------------------------------------------------------
9628 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9629 & KK,KKderg,AKA,AKAderg,AKAderx)
9633 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9634 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9635 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9640 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9642 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9645 cd if (lprn) write (2,*) 'In kernel'
9647 cd if (lprn) write (2,*) 'kkk=',kkk
9649 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9650 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9652 cd write (2,*) 'lll=',lll
9653 cd write (2,*) 'iii=1'
9655 cd write (2,'(3(2f10.5),5x)')
9656 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9659 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9660 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9662 cd write (2,*) 'lll=',lll
9663 cd write (2,*) 'iii=2'
9665 cd write (2,'(3(2f10.5),5x)')
9666 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9673 C---------------------------------------------------------------------------
9674 double precision function eello4(i,j,k,l,jj,kk)
9675 implicit real*8 (a-h,o-z)
9676 include 'DIMENSIONS'
9677 include 'COMMON.IOUNITS'
9678 include 'COMMON.CHAIN'
9679 include 'COMMON.DERIV'
9680 include 'COMMON.INTERACT'
9681 include 'COMMON.CONTACTS'
9682 include 'COMMON.TORSION'
9683 include 'COMMON.VAR'
9684 include 'COMMON.GEO'
9685 double precision pizda(2,2),ggg1(3),ggg2(3)
9686 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9690 cd print *,'eello4:',i,j,k,l,jj,kk
9691 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
9692 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
9693 cold eij=facont_hb(jj,i)
9694 cold ekl=facont_hb(kk,k)
9696 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9697 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9698 gcorr_loc(k-1)=gcorr_loc(k-1)
9699 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9701 gcorr_loc(l-1)=gcorr_loc(l-1)
9702 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9704 gcorr_loc(j-1)=gcorr_loc(j-1)
9705 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9710 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9711 & -EAEAderx(2,2,lll,kkk,iii,1)
9712 cd derx(lll,kkk,iii)=0.0d0
9716 cd gcorr_loc(l-1)=0.0d0
9717 cd gcorr_loc(j-1)=0.0d0
9718 cd gcorr_loc(k-1)=0.0d0
9720 cd write (iout,*)'Contacts have occurred for peptide groups',
9721 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
9722 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9723 if (j.lt.nres-1) then
9730 if (l.lt.nres-1) then
9738 cgrad ggg1(ll)=eel4*g_contij(ll,1)
9739 cgrad ggg2(ll)=eel4*g_contij(ll,2)
9740 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9741 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9742 cgrad ghalf=0.5d0*ggg1(ll)
9743 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9744 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9745 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9746 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9747 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9748 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9749 cgrad ghalf=0.5d0*ggg2(ll)
9750 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9751 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9752 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9753 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9754 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9755 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9759 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9764 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9769 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9774 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9778 cd write (2,*) iii,gcorr_loc(iii)
9781 cd write (2,*) 'ekont',ekont
9782 cd write (iout,*) 'eello4',ekont*eel4
9785 C---------------------------------------------------------------------------
9786 double precision function eello5(i,j,k,l,jj,kk)
9787 implicit real*8 (a-h,o-z)
9788 include 'DIMENSIONS'
9789 include 'COMMON.IOUNITS'
9790 include 'COMMON.CHAIN'
9791 include 'COMMON.DERIV'
9792 include 'COMMON.INTERACT'
9793 include 'COMMON.CONTACTS'
9794 include 'COMMON.TORSION'
9795 include 'COMMON.VAR'
9796 include 'COMMON.GEO'
9797 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9798 double precision ggg1(3),ggg2(3)
9799 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9804 C /l\ / \ \ / \ / \ / C
9805 C / \ / \ \ / \ / \ / C
9806 C j| o |l1 | o | o| o | | o |o C
9807 C \ |/k\| |/ \| / |/ \| |/ \| C
9808 C \i/ \ / \ / / \ / \ C
9810 C (I) (II) (III) (IV) C
9812 C eello5_1 eello5_2 eello5_3 eello5_4 C
9814 C Antiparallel chains C
9817 C /j\ / \ \ / \ / \ / C
9818 C / \ / \ \ / \ / \ / C
9819 C j1| o |l | o | o| o | | o |o C
9820 C \ |/k\| |/ \| / |/ \| |/ \| C
9821 C \i/ \ / \ / / \ / \ C
9823 C (I) (II) (III) (IV) C
9825 C eello5_1 eello5_2 eello5_3 eello5_4 C
9827 C o denotes a local interaction, vertical lines an electrostatic interaction. C
9829 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9830 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9835 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
9837 itk=itype2loc(itype(k))
9838 itl=itype2loc(itype(l))
9839 itj=itype2loc(itype(j))
9844 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9845 cd & eel5_3_num,eel5_4_num)
9849 derx(lll,kkk,iii)=0.0d0
9853 cd eij=facont_hb(jj,i)
9854 cd ekl=facont_hb(kk,k)
9856 cd write (iout,*)'Contacts have occurred for peptide groups',
9857 cd & i,j,' fcont:',eij,' eij',' and ',k,l
9859 C Contribution from the graph I.
9860 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9861 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9862 call transpose2(EUg(1,1,k),auxmat(1,1))
9863 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9864 vv(1)=pizda(1,1)-pizda(2,2)
9865 vv(2)=pizda(1,2)+pizda(2,1)
9866 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9867 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9868 C Explicit gradient in virtual-dihedral angles.
9869 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9870 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9871 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9872 call transpose2(EUgder(1,1,k),auxmat1(1,1))
9873 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9874 vv(1)=pizda(1,1)-pizda(2,2)
9875 vv(2)=pizda(1,2)+pizda(2,1)
9876 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9877 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9878 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9879 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9880 vv(1)=pizda(1,1)-pizda(2,2)
9881 vv(2)=pizda(1,2)+pizda(2,1)
9883 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9884 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9885 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9887 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9888 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9889 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9891 C Cartesian gradient
9895 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9897 vv(1)=pizda(1,1)-pizda(2,2)
9898 vv(2)=pizda(1,2)+pizda(2,1)
9899 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9900 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9901 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9907 C Contribution from graph II
9908 call transpose2(EE(1,1,k),auxmat(1,1))
9909 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9910 vv(1)=pizda(1,1)+pizda(2,2)
9911 vv(2)=pizda(2,1)-pizda(1,2)
9912 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9913 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9914 C Explicit gradient in virtual-dihedral angles.
9915 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9916 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9917 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9918 vv(1)=pizda(1,1)+pizda(2,2)
9919 vv(2)=pizda(2,1)-pizda(1,2)
9921 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9922 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9923 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9925 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9926 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9927 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9929 C Cartesian gradient
9933 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9935 vv(1)=pizda(1,1)+pizda(2,2)
9936 vv(2)=pizda(2,1)-pizda(1,2)
9937 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9938 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9939 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9947 C Parallel orientation
9948 C Contribution from graph III
9949 call transpose2(EUg(1,1,l),auxmat(1,1))
9950 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9951 vv(1)=pizda(1,1)-pizda(2,2)
9952 vv(2)=pizda(1,2)+pizda(2,1)
9953 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9954 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9955 C Explicit gradient in virtual-dihedral angles.
9956 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9957 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9958 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9959 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9960 vv(1)=pizda(1,1)-pizda(2,2)
9961 vv(2)=pizda(1,2)+pizda(2,1)
9962 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9963 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9964 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9965 call transpose2(EUgder(1,1,l),auxmat1(1,1))
9966 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9967 vv(1)=pizda(1,1)-pizda(2,2)
9968 vv(2)=pizda(1,2)+pizda(2,1)
9969 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9970 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9971 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9972 C Cartesian gradient
9976 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9978 vv(1)=pizda(1,1)-pizda(2,2)
9979 vv(2)=pizda(1,2)+pizda(2,1)
9980 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9981 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9982 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9987 C Contribution from graph IV
9989 call transpose2(EE(1,1,l),auxmat(1,1))
9990 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9991 vv(1)=pizda(1,1)+pizda(2,2)
9992 vv(2)=pizda(2,1)-pizda(1,2)
9993 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9994 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
9995 C Explicit gradient in virtual-dihedral angles.
9996 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9997 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9998 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9999 vv(1)=pizda(1,1)+pizda(2,2)
10000 vv(2)=pizda(2,1)-pizda(1,2)
10001 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10002 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10003 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10004 C Cartesian gradient
10008 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10010 vv(1)=pizda(1,1)+pizda(2,2)
10011 vv(2)=pizda(2,1)-pizda(1,2)
10012 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10013 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10014 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10019 C Antiparallel orientation
10020 C Contribution from graph III
10022 call transpose2(EUg(1,1,j),auxmat(1,1))
10023 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10024 vv(1)=pizda(1,1)-pizda(2,2)
10025 vv(2)=pizda(1,2)+pizda(2,1)
10026 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10027 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10028 C Explicit gradient in virtual-dihedral angles.
10029 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10030 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10031 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10032 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10033 vv(1)=pizda(1,1)-pizda(2,2)
10034 vv(2)=pizda(1,2)+pizda(2,1)
10035 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10036 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10037 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10038 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10039 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10040 vv(1)=pizda(1,1)-pizda(2,2)
10041 vv(2)=pizda(1,2)+pizda(2,1)
10042 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10043 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10044 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10045 C Cartesian gradient
10049 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10051 vv(1)=pizda(1,1)-pizda(2,2)
10052 vv(2)=pizda(1,2)+pizda(2,1)
10053 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10054 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10055 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10060 C Contribution from graph IV
10062 call transpose2(EE(1,1,j),auxmat(1,1))
10063 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10064 vv(1)=pizda(1,1)+pizda(2,2)
10065 vv(2)=pizda(2,1)-pizda(1,2)
10066 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10067 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10068 C Explicit gradient in virtual-dihedral angles.
10069 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10070 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10071 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10072 vv(1)=pizda(1,1)+pizda(2,2)
10073 vv(2)=pizda(2,1)-pizda(1,2)
10074 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10075 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10076 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10077 C Cartesian gradient
10081 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10083 vv(1)=pizda(1,1)+pizda(2,2)
10084 vv(2)=pizda(2,1)-pizda(1,2)
10085 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10086 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10087 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10093 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10094 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10095 cd write (2,*) 'ijkl',i,j,k,l
10096 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10097 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10099 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10100 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10101 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10102 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10103 if (j.lt.nres-1) then
10110 if (l.lt.nres-1) then
10120 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10121 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10122 C summed up outside the subrouine as for the other subroutines
10123 C handling long-range interactions. The old code is commented out
10124 C with "cgrad" to keep track of changes.
10126 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10127 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10128 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10129 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10130 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10131 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10132 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10133 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10134 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10135 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10137 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10138 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10139 cgrad ghalf=0.5d0*ggg1(ll)
10141 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10142 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10143 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10144 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10145 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10146 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10147 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10148 cgrad ghalf=0.5d0*ggg2(ll)
10150 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10151 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10152 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10153 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10154 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10155 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10160 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10161 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10166 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10167 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10173 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10178 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10182 cd write (2,*) iii,g_corr5_loc(iii)
10185 cd write (2,*) 'ekont',ekont
10186 cd write (iout,*) 'eello5',ekont*eel5
10189 c--------------------------------------------------------------------------
10190 double precision function eello6(i,j,k,l,jj,kk)
10191 implicit real*8 (a-h,o-z)
10192 include 'DIMENSIONS'
10193 include 'COMMON.IOUNITS'
10194 include 'COMMON.CHAIN'
10195 include 'COMMON.DERIV'
10196 include 'COMMON.INTERACT'
10197 include 'COMMON.CONTACTS'
10198 include 'COMMON.TORSION'
10199 include 'COMMON.VAR'
10200 include 'COMMON.GEO'
10201 include 'COMMON.FFIELD'
10202 double precision ggg1(3),ggg2(3)
10203 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10208 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10216 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10217 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10221 derx(lll,kkk,iii)=0.0d0
10225 cd eij=facont_hb(jj,i)
10226 cd ekl=facont_hb(kk,k)
10232 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10233 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10234 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10235 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10236 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10237 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10239 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10240 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10241 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10242 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10243 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10244 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10248 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10250 C If turn contributions are considered, they will be handled separately.
10251 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10252 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10253 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10254 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10255 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10256 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10257 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10259 if (j.lt.nres-1) then
10266 if (l.lt.nres-1) then
10274 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10275 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10276 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10277 cgrad ghalf=0.5d0*ggg1(ll)
10279 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10280 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10281 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10282 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10283 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10284 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10285 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10286 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10287 cgrad ghalf=0.5d0*ggg2(ll)
10288 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10290 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10291 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10292 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10293 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10294 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10295 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10300 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10301 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10306 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10307 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10313 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10318 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10322 cd write (2,*) iii,g_corr6_loc(iii)
10325 cd write (2,*) 'ekont',ekont
10326 cd write (iout,*) 'eello6',ekont*eel6
10329 c--------------------------------------------------------------------------
10330 double precision function eello6_graph1(i,j,k,l,imat,swap)
10331 implicit real*8 (a-h,o-z)
10332 include 'DIMENSIONS'
10333 include 'COMMON.IOUNITS'
10334 include 'COMMON.CHAIN'
10335 include 'COMMON.DERIV'
10336 include 'COMMON.INTERACT'
10337 include 'COMMON.CONTACTS'
10338 include 'COMMON.TORSION'
10339 include 'COMMON.VAR'
10340 include 'COMMON.GEO'
10341 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10344 common /kutas/ lprn
10345 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10347 C Parallel Antiparallel C
10353 C \ j|/k\| / \ |/k\|l / C
10354 C \ / \ / \ / \ / C
10358 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10359 itk=itype2loc(itype(k))
10360 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10361 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10362 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10363 call transpose2(EUgC(1,1,k),auxmat(1,1))
10364 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10365 vv1(1)=pizda1(1,1)-pizda1(2,2)
10366 vv1(2)=pizda1(1,2)+pizda1(2,1)
10367 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10368 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10369 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10370 s5=scalar2(vv(1),Dtobr2(1,i))
10371 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10372 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10373 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10374 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10375 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10376 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10377 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10378 & +scalar2(vv(1),Dtobr2der(1,i)))
10379 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10380 vv1(1)=pizda1(1,1)-pizda1(2,2)
10381 vv1(2)=pizda1(1,2)+pizda1(2,1)
10382 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10383 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10385 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10386 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10387 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10388 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10389 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10391 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10392 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10393 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10394 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10395 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10397 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10398 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10399 vv1(1)=pizda1(1,1)-pizda1(2,2)
10400 vv1(2)=pizda1(1,2)+pizda1(2,1)
10401 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10402 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10403 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10404 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10413 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10414 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10415 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10416 call transpose2(EUgC(1,1,k),auxmat(1,1))
10417 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10419 vv1(1)=pizda1(1,1)-pizda1(2,2)
10420 vv1(2)=pizda1(1,2)+pizda1(2,1)
10421 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10422 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10423 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10424 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10425 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10426 s5=scalar2(vv(1),Dtobr2(1,i))
10427 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10433 c----------------------------------------------------------------------------
10434 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10435 implicit real*8 (a-h,o-z)
10436 include 'DIMENSIONS'
10437 include 'COMMON.IOUNITS'
10438 include 'COMMON.CHAIN'
10439 include 'COMMON.DERIV'
10440 include 'COMMON.INTERACT'
10441 include 'COMMON.CONTACTS'
10442 include 'COMMON.TORSION'
10443 include 'COMMON.VAR'
10444 include 'COMMON.GEO'
10446 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10447 & auxvec1(2),auxvec2(2),auxmat1(2,2)
10449 common /kutas/ lprn
10450 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10452 C Parallel Antiparallel C
10458 C \ j|/k\| \ |/k\|l C
10463 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10464 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10465 C AL 7/4/01 s1 would occur in the sixth-order moment,
10466 C but not in a cluster cumulant
10468 s1=dip(1,jj,i)*dip(1,kk,k)
10470 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10471 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10472 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10473 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10474 call transpose2(EUg(1,1,k),auxmat(1,1))
10475 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10476 vv(1)=pizda(1,1)-pizda(2,2)
10477 vv(2)=pizda(1,2)+pizda(2,1)
10478 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10479 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10481 eello6_graph2=-(s1+s2+s3+s4)
10483 eello6_graph2=-(s2+s3+s4)
10485 c eello6_graph2=-s3
10486 C Derivatives in gamma(i-1)
10489 s1=dipderg(1,jj,i)*dip(1,kk,k)
10491 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10492 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10493 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10494 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10496 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10498 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10500 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10502 C Derivatives in gamma(k-1)
10504 s1=dip(1,jj,i)*dipderg(1,kk,k)
10506 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10507 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10508 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10509 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10510 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10511 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10512 vv(1)=pizda(1,1)-pizda(2,2)
10513 vv(2)=pizda(1,2)+pizda(2,1)
10514 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10516 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10518 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10520 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10521 C Derivatives in gamma(j-1) or gamma(l-1)
10524 s1=dipderg(3,jj,i)*dip(1,kk,k)
10526 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10527 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10528 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10529 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10530 vv(1)=pizda(1,1)-pizda(2,2)
10531 vv(2)=pizda(1,2)+pizda(2,1)
10532 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10535 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10537 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10540 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10541 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10543 C Derivatives in gamma(l-1) or gamma(j-1)
10546 s1=dip(1,jj,i)*dipderg(3,kk,k)
10548 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10549 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10550 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10551 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10552 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10553 vv(1)=pizda(1,1)-pizda(2,2)
10554 vv(2)=pizda(1,2)+pizda(2,1)
10555 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10558 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10560 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10563 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10564 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10566 C Cartesian derivatives.
10568 write (2,*) 'In eello6_graph2'
10570 write (2,*) 'iii=',iii
10572 write (2,*) 'kkk=',kkk
10574 write (2,'(3(2f10.5),5x)')
10575 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10585 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10587 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10590 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10592 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10593 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10595 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10596 call transpose2(EUg(1,1,k),auxmat(1,1))
10597 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10599 vv(1)=pizda(1,1)-pizda(2,2)
10600 vv(2)=pizda(1,2)+pizda(2,1)
10601 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10602 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10604 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10606 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10609 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10611 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10618 c----------------------------------------------------------------------------
10619 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10620 implicit real*8 (a-h,o-z)
10621 include 'DIMENSIONS'
10622 include 'COMMON.IOUNITS'
10623 include 'COMMON.CHAIN'
10624 include 'COMMON.DERIV'
10625 include 'COMMON.INTERACT'
10626 include 'COMMON.CONTACTS'
10627 include 'COMMON.TORSION'
10628 include 'COMMON.VAR'
10629 include 'COMMON.GEO'
10630 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10632 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10634 C Parallel Antiparallel C
10639 C /| o |o o| o |\ C
10640 C j|/k\| / |/k\|l / C
10645 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10647 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10648 C energy moment and not to the cluster cumulant.
10649 iti=itortyp(itype(i))
10650 if (j.lt.nres-1) then
10651 itj1=itype2loc(itype(j+1))
10655 itk=itype2loc(itype(k))
10656 itk1=itype2loc(itype(k+1))
10657 if (l.lt.nres-1) then
10658 itl1=itype2loc(itype(l+1))
10663 s1=dip(4,jj,i)*dip(4,kk,k)
10665 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10666 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10667 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10668 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10669 call transpose2(EE(1,1,k),auxmat(1,1))
10670 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10671 vv(1)=pizda(1,1)+pizda(2,2)
10672 vv(2)=pizda(2,1)-pizda(1,2)
10673 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10674 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10675 cd & "sum",-(s2+s3+s4)
10677 eello6_graph3=-(s1+s2+s3+s4)
10679 eello6_graph3=-(s2+s3+s4)
10681 c eello6_graph3=-s4
10682 C Derivatives in gamma(k-1)
10683 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10684 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10685 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10686 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10687 C Derivatives in gamma(l-1)
10688 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10689 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10690 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10691 vv(1)=pizda(1,1)+pizda(2,2)
10692 vv(2)=pizda(2,1)-pizda(1,2)
10693 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10694 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10695 C Cartesian derivatives.
10701 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10703 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10706 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10708 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10709 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10711 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10712 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10714 vv(1)=pizda(1,1)+pizda(2,2)
10715 vv(2)=pizda(2,1)-pizda(1,2)
10716 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10718 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10720 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10723 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10725 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10727 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10733 c----------------------------------------------------------------------------
10734 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10735 implicit real*8 (a-h,o-z)
10736 include 'DIMENSIONS'
10737 include 'COMMON.IOUNITS'
10738 include 'COMMON.CHAIN'
10739 include 'COMMON.DERIV'
10740 include 'COMMON.INTERACT'
10741 include 'COMMON.CONTACTS'
10742 include 'COMMON.TORSION'
10743 include 'COMMON.VAR'
10744 include 'COMMON.GEO'
10745 include 'COMMON.FFIELD'
10746 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10747 & auxvec1(2),auxmat1(2,2)
10749 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10751 C Parallel Antiparallel C
10756 C /| o |o o| o |\ C
10757 C \ j|/k\| \ |/k\|l C
10762 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10764 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10765 C energy moment and not to the cluster cumulant.
10766 cd write (2,*) 'eello_graph4: wturn6',wturn6
10767 iti=itype2loc(itype(i))
10768 itj=itype2loc(itype(j))
10769 if (j.lt.nres-1) then
10770 itj1=itype2loc(itype(j+1))
10774 itk=itype2loc(itype(k))
10775 if (k.lt.nres-1) then
10776 itk1=itype2loc(itype(k+1))
10780 itl=itype2loc(itype(l))
10781 if (l.lt.nres-1) then
10782 itl1=itype2loc(itype(l+1))
10786 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10787 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10788 cd & ' itl',itl,' itl1',itl1
10790 if (imat.eq.1) then
10791 s1=dip(3,jj,i)*dip(3,kk,k)
10793 s1=dip(2,jj,j)*dip(2,kk,l)
10796 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10797 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10799 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10800 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10802 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10803 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10805 call transpose2(EUg(1,1,k),auxmat(1,1))
10806 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10807 vv(1)=pizda(1,1)-pizda(2,2)
10808 vv(2)=pizda(2,1)+pizda(1,2)
10809 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10810 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10812 eello6_graph4=-(s1+s2+s3+s4)
10814 eello6_graph4=-(s2+s3+s4)
10816 C Derivatives in gamma(i-1)
10819 if (imat.eq.1) then
10820 s1=dipderg(2,jj,i)*dip(3,kk,k)
10822 s1=dipderg(4,jj,j)*dip(2,kk,l)
10825 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10827 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10828 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10830 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10831 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10833 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10834 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10835 cd write (2,*) 'turn6 derivatives'
10837 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10839 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10843 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10845 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10849 C Derivatives in gamma(k-1)
10851 if (imat.eq.1) then
10852 s1=dip(3,jj,i)*dipderg(2,kk,k)
10854 s1=dip(2,jj,j)*dipderg(4,kk,l)
10857 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10858 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10860 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10861 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10863 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10864 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10866 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10867 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10868 vv(1)=pizda(1,1)-pizda(2,2)
10869 vv(2)=pizda(2,1)+pizda(1,2)
10870 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10871 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10873 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10875 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10879 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10881 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10884 C Derivatives in gamma(j-1) or gamma(l-1)
10885 if (l.eq.j+1 .and. l.gt.1) then
10886 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10887 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10888 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10889 vv(1)=pizda(1,1)-pizda(2,2)
10890 vv(2)=pizda(2,1)+pizda(1,2)
10891 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10892 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10893 else if (j.gt.1) then
10894 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10895 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10896 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10897 vv(1)=pizda(1,1)-pizda(2,2)
10898 vv(2)=pizda(2,1)+pizda(1,2)
10899 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10900 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10901 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10903 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10906 C Cartesian derivatives.
10912 if (imat.eq.1) then
10913 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10915 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10918 if (imat.eq.1) then
10919 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10921 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10925 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10927 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10929 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10930 & b1(1,j+1),auxvec(1))
10931 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10933 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10934 & b1(1,l+1),auxvec(1))
10935 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10937 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10939 vv(1)=pizda(1,1)-pizda(2,2)
10940 vv(2)=pizda(2,1)+pizda(1,2)
10941 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10943 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10945 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10948 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10951 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10954 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10956 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10958 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10962 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10964 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10967 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10969 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10977 c----------------------------------------------------------------------------
10978 double precision function eello_turn6(i,jj,kk)
10979 implicit real*8 (a-h,o-z)
10980 include 'DIMENSIONS'
10981 include 'COMMON.IOUNITS'
10982 include 'COMMON.CHAIN'
10983 include 'COMMON.DERIV'
10984 include 'COMMON.INTERACT'
10985 include 'COMMON.CONTACTS'
10986 include 'COMMON.TORSION'
10987 include 'COMMON.VAR'
10988 include 'COMMON.GEO'
10989 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10990 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10992 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10993 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10994 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10995 C the respective energy moment and not to the cluster cumulant.
11004 iti=itype2loc(itype(i))
11005 itk=itype2loc(itype(k))
11006 itk1=itype2loc(itype(k+1))
11007 itl=itype2loc(itype(l))
11008 itj=itype2loc(itype(j))
11009 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11010 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11011 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11016 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11018 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11022 derx_turn(lll,kkk,iii)=0.0d0
11029 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11031 cd write (2,*) 'eello6_5',eello6_5
11033 call transpose2(AEA(1,1,1),auxmat(1,1))
11034 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11035 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11036 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11038 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11039 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11040 s2 = scalar2(b1(1,k),vtemp1(1))
11042 call transpose2(AEA(1,1,2),atemp(1,1))
11043 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11044 call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11045 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11047 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11048 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11049 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11051 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11052 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11053 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11054 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11055 ss13 = scalar2(b1(1,k),vtemp4(1))
11056 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11058 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11064 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11065 C Derivatives in gamma(i+2)
11069 call transpose2(AEA(1,1,1),auxmatd(1,1))
11070 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11071 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11072 call transpose2(AEAderg(1,1,2),atempd(1,1))
11073 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11074 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11076 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11077 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11078 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11084 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11085 C Derivatives in gamma(i+3)
11087 call transpose2(AEA(1,1,1),auxmatd(1,1))
11088 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11089 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11090 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11092 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11093 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11094 s2d = scalar2(b1(1,k),vtemp1d(1))
11096 call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11097 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11099 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11101 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11102 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11103 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11111 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11112 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11114 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11115 & -0.5d0*ekont*(s2d+s12d)
11117 C Derivatives in gamma(i+4)
11118 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11119 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11120 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11122 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11123 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11124 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11132 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11134 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11136 C Derivatives in gamma(i+5)
11138 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11139 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11140 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11142 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11143 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11144 s2d = scalar2(b1(1,k),vtemp1d(1))
11146 call transpose2(AEA(1,1,2),atempd(1,1))
11147 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11148 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11150 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11151 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11153 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11154 ss13d = scalar2(b1(1,k),vtemp4d(1))
11155 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11163 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11164 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11166 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11167 & -0.5d0*ekont*(s2d+s12d)
11169 C Cartesian derivatives
11174 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11175 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11176 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11178 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11179 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11181 s2d = scalar2(b1(1,k),vtemp1d(1))
11183 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11184 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11185 s8d = -(atempd(1,1)+atempd(2,2))*
11186 & scalar2(cc(1,1,itl),vtemp2(1))
11188 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11190 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11191 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11198 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11199 & - 0.5d0*(s1d+s2d)
11201 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11205 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11206 & - 0.5d0*(s8d+s12d)
11208 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11217 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11218 & achuj_tempd(1,1))
11219 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11220 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11221 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11222 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11223 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11225 ss13d = scalar2(b1(1,k),vtemp4d(1))
11226 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11227 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11231 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11232 cd & 16*eel_turn6_num
11234 if (j.lt.nres-1) then
11241 if (l.lt.nres-1) then
11249 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11250 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11251 cgrad ghalf=0.5d0*ggg1(ll)
11253 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11254 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11255 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11256 & +ekont*derx_turn(ll,2,1)
11257 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11258 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11259 & +ekont*derx_turn(ll,4,1)
11260 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11261 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11262 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11263 cgrad ghalf=0.5d0*ggg2(ll)
11265 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11266 & +ekont*derx_turn(ll,2,2)
11267 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11268 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11269 & +ekont*derx_turn(ll,4,2)
11270 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11271 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11272 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11277 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11282 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11288 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11293 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11297 cd write (2,*) iii,g_corr6_loc(iii)
11299 eello_turn6=ekont*eel_turn6
11300 cd write (2,*) 'ekont',ekont
11301 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11305 C-----------------------------------------------------------------------------
11306 double precision function scalar(u,v)
11307 !DIR$ INLINEALWAYS scalar
11309 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11312 double precision u(3),v(3)
11313 cd double precision sc
11321 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11324 crc-------------------------------------------------
11325 SUBROUTINE MATVEC2(A1,V1,V2)
11326 !DIR$ INLINEALWAYS MATVEC2
11328 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11330 implicit real*8 (a-h,o-z)
11331 include 'DIMENSIONS'
11332 DIMENSION A1(2,2),V1(2),V2(2)
11336 c 3 VI=VI+A1(I,K)*V1(K)
11340 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11341 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11346 C---------------------------------------
11347 SUBROUTINE MATMAT2(A1,A2,A3)
11349 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11351 implicit real*8 (a-h,o-z)
11352 include 'DIMENSIONS'
11353 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11354 c DIMENSION AI3(2,2)
11358 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11364 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11365 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11366 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11367 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11375 c-------------------------------------------------------------------------
11376 double precision function scalar2(u,v)
11377 !DIR$ INLINEALWAYS scalar2
11379 double precision u(2),v(2)
11380 double precision sc
11382 scalar2=u(1)*v(1)+u(2)*v(2)
11386 C-----------------------------------------------------------------------------
11388 subroutine transpose2(a,at)
11389 !DIR$ INLINEALWAYS transpose2
11391 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11394 double precision a(2,2),at(2,2)
11401 c--------------------------------------------------------------------------
11402 subroutine transpose(n,a,at)
11405 double precision a(n,n),at(n,n)
11413 C---------------------------------------------------------------------------
11414 subroutine prodmat3(a1,a2,kk,transp,prod)
11415 !DIR$ INLINEALWAYS prodmat3
11417 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11421 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11423 crc double precision auxmat(2,2),prod_(2,2)
11426 crc call transpose2(kk(1,1),auxmat(1,1))
11427 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11428 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11430 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11431 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11432 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11433 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11434 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11435 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11436 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11437 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11440 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11441 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11443 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11444 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11445 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11446 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11447 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11448 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11449 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11450 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11453 c call transpose2(a2(1,1),a2t(1,1))
11456 crc print *,((prod_(i,j),i=1,2),j=1,2)
11457 crc print *,((prod(i,j),i=1,2),j=1,2)
11461 CCC----------------------------------------------
11462 subroutine Eliptransfer(eliptran)
11463 implicit real*8 (a-h,o-z)
11464 include 'DIMENSIONS'
11465 include 'COMMON.GEO'
11466 include 'COMMON.VAR'
11467 include 'COMMON.LOCAL'
11468 include 'COMMON.CHAIN'
11469 include 'COMMON.DERIV'
11470 include 'COMMON.NAMES'
11471 include 'COMMON.INTERACT'
11472 include 'COMMON.IOUNITS'
11473 include 'COMMON.CALC'
11474 include 'COMMON.CONTROL'
11475 include 'COMMON.SPLITELE'
11476 include 'COMMON.SBRIDGE'
11477 C this is done by Adasko
11478 C print *,"wchodze"
11479 C structure of box:
11481 C--bordliptop-- buffore starts
11482 C--bufliptop--- here true lipid starts
11484 C--buflipbot--- lipid ends buffore starts
11485 C--bordlipbot--buffore ends
11487 do i=ilip_start,ilip_end
11489 if (itype(i).eq.ntyp1) cycle
11491 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11492 if (positi.le.0.0) positi=positi+boxzsize
11494 C first for peptide groups
11495 c for each residue check if it is in lipid or lipid water border area
11496 if ((positi.gt.bordlipbot)
11497 &.and.(positi.lt.bordliptop)) then
11498 C the energy transfer exist
11499 if (positi.lt.buflipbot) then
11500 C what fraction I am in
11502 & ((positi-bordlipbot)/lipbufthick)
11503 C lipbufthick is thickenes of lipid buffore
11504 sslip=sscalelip(fracinbuf)
11505 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11506 eliptran=eliptran+sslip*pepliptran
11507 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11508 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11509 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11511 C print *,"doing sccale for lower part"
11512 C print *,i,sslip,fracinbuf,ssgradlip
11513 elseif (positi.gt.bufliptop) then
11514 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11515 sslip=sscalelip(fracinbuf)
11516 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11517 eliptran=eliptran+sslip*pepliptran
11518 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11519 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11520 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11521 C print *, "doing sscalefor top part"
11522 C print *,i,sslip,fracinbuf,ssgradlip
11524 eliptran=eliptran+pepliptran
11525 C print *,"I am in true lipid"
11528 C eliptran=elpitran+0.0 ! I am in water
11531 C print *, "nic nie bylo w lipidzie?"
11532 C now multiply all by the peptide group transfer factor
11533 C eliptran=eliptran*pepliptran
11534 C now the same for side chains
11536 do i=ilip_start,ilip_end
11537 if (itype(i).eq.ntyp1) cycle
11538 positi=(mod(c(3,i+nres),boxzsize))
11539 if (positi.le.0) positi=positi+boxzsize
11540 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11541 c for each residue check if it is in lipid or lipid water border area
11542 C respos=mod(c(3,i+nres),boxzsize)
11543 C print *,positi,bordlipbot,buflipbot
11544 if ((positi.gt.bordlipbot)
11545 & .and.(positi.lt.bordliptop)) then
11546 C the energy transfer exist
11547 if (positi.lt.buflipbot) then
11549 & ((positi-bordlipbot)/lipbufthick)
11550 C lipbufthick is thickenes of lipid buffore
11551 sslip=sscalelip(fracinbuf)
11552 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11553 eliptran=eliptran+sslip*liptranene(itype(i))
11554 gliptranx(3,i)=gliptranx(3,i)
11555 &+ssgradlip*liptranene(itype(i))
11556 gliptranc(3,i-1)= gliptranc(3,i-1)
11557 &+ssgradlip*liptranene(itype(i))
11558 C print *,"doing sccale for lower part"
11559 elseif (positi.gt.bufliptop) then
11561 &((bordliptop-positi)/lipbufthick)
11562 sslip=sscalelip(fracinbuf)
11563 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11564 eliptran=eliptran+sslip*liptranene(itype(i))
11565 gliptranx(3,i)=gliptranx(3,i)
11566 &+ssgradlip*liptranene(itype(i))
11567 gliptranc(3,i-1)= gliptranc(3,i-1)
11568 &+ssgradlip*liptranene(itype(i))
11569 C print *, "doing sscalefor top part",sslip,fracinbuf
11571 eliptran=eliptran+liptranene(itype(i))
11572 C print *,"I am in true lipid"
11574 endif ! if in lipid or buffor
11576 C eliptran=elpitran+0.0 ! I am in water
11580 C---------------------------------------------------------
11581 C AFM soubroutine for constant force
11582 subroutine AFMforce(Eafmforce)
11583 implicit real*8 (a-h,o-z)
11584 include 'DIMENSIONS'
11585 include 'COMMON.GEO'
11586 include 'COMMON.VAR'
11587 include 'COMMON.LOCAL'
11588 include 'COMMON.CHAIN'
11589 include 'COMMON.DERIV'
11590 include 'COMMON.NAMES'
11591 include 'COMMON.INTERACT'
11592 include 'COMMON.IOUNITS'
11593 include 'COMMON.CALC'
11594 include 'COMMON.CONTROL'
11595 include 'COMMON.SPLITELE'
11596 include 'COMMON.SBRIDGE'
11601 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11602 dist=dist+diffafm(i)**2
11605 Eafmforce=-forceAFMconst*(dist-distafminit)
11607 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11608 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11610 C print *,'AFM',Eafmforce
11613 C---------------------------------------------------------
11614 C AFM subroutine with pseudoconstant velocity
11615 subroutine AFMvel(Eafmforce)
11616 implicit real*8 (a-h,o-z)
11617 include 'DIMENSIONS'
11618 include 'COMMON.GEO'
11619 include 'COMMON.VAR'
11620 include 'COMMON.LOCAL'
11621 include 'COMMON.CHAIN'
11622 include 'COMMON.DERIV'
11623 include 'COMMON.NAMES'
11624 include 'COMMON.INTERACT'
11625 include 'COMMON.IOUNITS'
11626 include 'COMMON.CALC'
11627 include 'COMMON.CONTROL'
11628 include 'COMMON.SPLITELE'
11629 include 'COMMON.SBRIDGE'
11631 C Only for check grad COMMENT if not used for checkgrad
11633 C--------------------------------------------------------
11634 C print *,"wchodze"
11638 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11639 dist=dist+diffafm(i)**2
11642 Eafmforce=0.5d0*forceAFMconst
11643 & *(distafminit+totTafm*velAFMconst-dist)**2
11644 C Eafmforce=-forceAFMconst*(dist-distafminit)
11646 gradafm(i,afmend-1)=-forceAFMconst*
11647 &(distafminit+totTafm*velAFMconst-dist)
11649 gradafm(i,afmbeg-1)=forceAFMconst*
11650 &(distafminit+totTafm*velAFMconst-dist)
11653 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11656 C-----------------------------------------------------------
11657 C first for shielding is setting of function of side-chains
11658 subroutine set_shield_fac
11659 implicit real*8 (a-h,o-z)
11660 include 'DIMENSIONS'
11661 include 'COMMON.CHAIN'
11662 include 'COMMON.DERIV'
11663 include 'COMMON.IOUNITS'
11664 include 'COMMON.SHIELD'
11665 include 'COMMON.INTERACT'
11666 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11667 double precision div77_81/0.974996043d0/,
11668 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11670 C the vector between center of side_chain and peptide group
11671 double precision pep_side(3),long,side_calf(3),
11672 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11673 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11674 C the line belowe needs to be changed for FGPROC>1
11676 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11678 Cif there two consequtive dummy atoms there is no peptide group between them
11679 C the line below has to be changed for FGPROC>1
11682 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11686 C first lets set vector conecting the ithe side-chain with kth side-chain
11687 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11688 C pep_side(j)=2.0d0
11689 C and vector conecting the side-chain with its proper calfa
11690 side_calf(j)=c(j,k+nres)-c(j,k)
11691 C side_calf(j)=2.0d0
11692 pept_group(j)=c(j,i)-c(j,i+1)
11693 C lets have their lenght
11694 dist_pep_side=pep_side(j)**2+dist_pep_side
11695 dist_side_calf=dist_side_calf+side_calf(j)**2
11696 dist_pept_group=dist_pept_group+pept_group(j)**2
11698 dist_pep_side=dsqrt(dist_pep_side)
11699 dist_pept_group=dsqrt(dist_pept_group)
11700 dist_side_calf=dsqrt(dist_side_calf)
11702 pep_side_norm(j)=pep_side(j)/dist_pep_side
11703 side_calf_norm(j)=dist_side_calf
11705 C now sscale fraction
11706 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11707 C print *,buff_shield,"buff"
11709 if (sh_frac_dist.le.0.0) cycle
11710 C If we reach here it means that this side chain reaches the shielding sphere
11711 C Lets add him to the list for gradient
11712 ishield_list(i)=ishield_list(i)+1
11713 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11714 C this list is essential otherwise problem would be O3
11715 shield_list(ishield_list(i),i)=k
11716 C Lets have the sscale value
11717 if (sh_frac_dist.gt.1.0) then
11718 scale_fac_dist=1.0d0
11720 sh_frac_dist_grad(j)=0.0d0
11723 scale_fac_dist=-sh_frac_dist*sh_frac_dist
11724 & *(2.0*sh_frac_dist-3.0d0)
11725 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11726 & /dist_pep_side/buff_shield*0.5
11727 C remember for the final gradient multiply sh_frac_dist_grad(j)
11728 C for side_chain by factor -2 !
11730 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11731 C print *,"jestem",scale_fac_dist,fac_help_scale,
11732 C & sh_frac_dist_grad(j)
11735 C if ((i.eq.3).and.(k.eq.2)) then
11736 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11740 C this is what is now we have the distance scaling now volume...
11741 short=short_r_sidechain(itype(k))
11742 long=long_r_sidechain(itype(k))
11743 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11746 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11747 C costhet_fac=0.0d0
11749 costhet_grad(j)=costhet_fac*pep_side(j)
11751 C remember for the final gradient multiply costhet_grad(j)
11752 C for side_chain by factor -2 !
11753 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11754 C pep_side0pept_group is vector multiplication
11755 pep_side0pept_group=0.0
11757 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11759 cosalfa=(pep_side0pept_group/
11760 & (dist_pep_side*dist_side_calf))
11761 fac_alfa_sin=1.0-cosalfa**2
11762 fac_alfa_sin=dsqrt(fac_alfa_sin)
11763 rkprim=fac_alfa_sin*(long-short)+short
11765 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11766 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11769 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11770 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11771 &*(long-short)/fac_alfa_sin*cosalfa/
11772 &((dist_pep_side*dist_side_calf))*
11773 &((side_calf(j))-cosalfa*
11774 &((pep_side(j)/dist_pep_side)*dist_side_calf))
11776 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11777 &*(long-short)/fac_alfa_sin*cosalfa
11778 &/((dist_pep_side*dist_side_calf))*
11780 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11783 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11786 C now the gradient...
11787 C grad_shield is gradient of Calfa for peptide groups
11788 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11790 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11791 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11793 grad_shield(j,i)=grad_shield(j,i)
11794 C gradient po skalowaniu
11795 & +(sh_frac_dist_grad(j)
11796 C gradient po costhet
11797 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11798 &-scale_fac_dist*(cosphi_grad_long(j))
11799 &/(1.0-cosphi) )*div77_81
11801 C grad_shield_side is Cbeta sidechain gradient
11802 grad_shield_side(j,ishield_list(i),i)=
11803 & (sh_frac_dist_grad(j)*-2.0d0
11804 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11805 & +scale_fac_dist*(cosphi_grad_long(j))
11806 & *2.0d0/(1.0-cosphi))
11807 & *div77_81*VofOverlap
11809 grad_shield_loc(j,ishield_list(i),i)=
11810 & scale_fac_dist*cosphi_grad_loc(j)
11811 & *2.0d0/(1.0-cosphi)
11812 & *div77_81*VofOverlap
11814 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11816 fac_shield(i)=VolumeTotal*div77_81+div4_81
11817 C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11821 C--------------------------------------------------------------------------
11822 double precision function tschebyshev(m,n,x,y)
11824 include "DIMENSIONS"
11826 double precision x(n),y,yy(0:maxvar),aux
11827 c Tschebyshev polynomial. Note that the first term is omitted
11828 c m=0: the constant term is included
11829 c m=1: the constant term is not included
11833 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11842 C--------------------------------------------------------------------------
11843 double precision function gradtschebyshev(m,n,x,y)
11845 include "DIMENSIONS"
11847 double precision x(n+1),y,yy(0:maxvar),aux
11848 c Tschebyshev polynomial. Note that the first term is omitted
11849 c m=0: the constant term is included
11850 c m=1: the constant term is not included
11854 yy(i)=2*y*yy(i-1)-yy(i-2)
11858 aux=aux+x(i+1)*yy(i)*(i+1)
11859 C print *, x(i+1),yy(i),i
11861 gradtschebyshev=aux
11864 C------------------------------------------------------------------------
11865 C first for shielding is setting of function of side-chains
11866 subroutine set_shield_fac2
11867 implicit real*8 (a-h,o-z)
11868 include 'DIMENSIONS'
11869 include 'COMMON.CHAIN'
11870 include 'COMMON.DERIV'
11871 include 'COMMON.IOUNITS'
11872 include 'COMMON.SHIELD'
11873 include 'COMMON.INTERACT'
11874 include 'COMMON.LOCAL'
11876 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11877 double precision div77_81/0.974996043d0/,
11878 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11880 C the vector between center of side_chain and peptide group
11881 double precision pep_side(3),long,side_calf(3),
11882 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11883 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11884 C write(2,*) "ivec",ivec_start,ivec_end
11886 fac_shield(i)=0.0d0
11888 grad_shield(j,i)=0.0d0
11891 C the line belowe needs to be changed for FGPROC>1
11892 do i=ivec_start,ivec_end
11894 C if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11896 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11897 Cif there two consequtive dummy atoms there is no peptide group between them
11898 C the line below has to be changed for FGPROC>1
11901 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11905 C first lets set vector conecting the ithe side-chain with kth side-chain
11906 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11907 C pep_side(j)=2.0d0
11908 C and vector conecting the side-chain with its proper calfa
11909 side_calf(j)=c(j,k+nres)-c(j,k)
11910 C side_calf(j)=2.0d0
11911 pept_group(j)=c(j,i)-c(j,i+1)
11912 C lets have their lenght
11913 dist_pep_side=pep_side(j)**2+dist_pep_side
11914 dist_side_calf=dist_side_calf+side_calf(j)**2
11915 dist_pept_group=dist_pept_group+pept_group(j)**2
11917 dist_pep_side=dsqrt(dist_pep_side)
11918 dist_pept_group=dsqrt(dist_pept_group)
11919 dist_side_calf=dsqrt(dist_side_calf)
11921 pep_side_norm(j)=pep_side(j)/dist_pep_side
11922 side_calf_norm(j)=dist_side_calf
11924 C now sscale fraction
11925 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11926 C print *,buff_shield,"buff"
11928 if (sh_frac_dist.le.0.0) cycle
11929 C print *,ishield_list(i),i
11930 C If we reach here it means that this side chain reaches the shielding sphere
11931 C Lets add him to the list for gradient
11932 ishield_list(i)=ishield_list(i)+1
11933 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11934 C this list is essential otherwise problem would be O3
11935 shield_list(ishield_list(i),i)=k
11936 C Lets have the sscale value
11937 if (sh_frac_dist.gt.1.0) then
11938 scale_fac_dist=1.0d0
11940 sh_frac_dist_grad(j)=0.0d0
11943 scale_fac_dist=-sh_frac_dist*sh_frac_dist
11944 & *(2.0d0*sh_frac_dist-3.0d0)
11945 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11946 & /dist_pep_side/buff_shield*0.5d0
11947 C remember for the final gradient multiply sh_frac_dist_grad(j)
11948 C for side_chain by factor -2 !
11950 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11951 C sh_frac_dist_grad(j)=0.0d0
11952 C scale_fac_dist=1.0d0
11953 C print *,"jestem",scale_fac_dist,fac_help_scale,
11954 C & sh_frac_dist_grad(j)
11957 C this is what is now we have the distance scaling now volume...
11958 short=short_r_sidechain(itype(k))
11959 long=long_r_sidechain(itype(k))
11960 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11961 sinthet=short/dist_pep_side*costhet
11965 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11966 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11967 C & -short/dist_pep_side**2/costhet)
11968 C costhet_fac=0.0d0
11970 costhet_grad(j)=costhet_fac*pep_side(j)
11972 C remember for the final gradient multiply costhet_grad(j)
11973 C for side_chain by factor -2 !
11974 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11975 C pep_side0pept_group is vector multiplication
11976 pep_side0pept_group=0.0d0
11978 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11980 cosalfa=(pep_side0pept_group/
11981 & (dist_pep_side*dist_side_calf))
11982 fac_alfa_sin=1.0d0-cosalfa**2
11983 fac_alfa_sin=dsqrt(fac_alfa_sin)
11984 rkprim=fac_alfa_sin*(long-short)+short
11988 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11990 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11991 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11992 & dist_pep_side**2)
11995 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11996 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11997 &*(long-short)/fac_alfa_sin*cosalfa/
11998 &((dist_pep_side*dist_side_calf))*
11999 &((side_calf(j))-cosalfa*
12000 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12001 C cosphi_grad_long(j)=0.0d0
12002 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12003 &*(long-short)/fac_alfa_sin*cosalfa
12004 &/((dist_pep_side*dist_side_calf))*
12006 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12007 C cosphi_grad_loc(j)=0.0d0
12009 C print *,sinphi,sinthet
12010 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12013 C now the gradient...
12015 grad_shield(j,i)=grad_shield(j,i)
12016 C gradient po skalowaniu
12017 & +(sh_frac_dist_grad(j)*VofOverlap
12018 C gradient po costhet
12019 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12020 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12021 & sinphi/sinthet*costhet*costhet_grad(j)
12022 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12024 C grad_shield_side is Cbeta sidechain gradient
12025 grad_shield_side(j,ishield_list(i),i)=
12026 & (sh_frac_dist_grad(j)*-2.0d0
12028 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12029 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12030 & sinphi/sinthet*costhet*costhet_grad(j)
12031 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12034 grad_shield_loc(j,ishield_list(i),i)=
12035 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12036 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12037 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12041 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12043 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12044 C write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
12048 C-----------------------------------------------------------------------
12049 C-----------------------------------------------------------
12050 C This subroutine is to mimic the histone like structure but as well can be
12051 C utilizet to nanostructures (infinit) small modification has to be used to
12052 C make it finite (z gradient at the ends has to be changes as well as the x,y
12053 C gradient has to be modified at the ends
12054 C The energy function is Kihara potential
12055 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12056 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12057 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12058 C simple Kihara potential
12059 subroutine calctube(Etube)
12060 implicit real*8 (a-h,o-z)
12061 include 'DIMENSIONS'
12062 include 'COMMON.GEO'
12063 include 'COMMON.VAR'
12064 include 'COMMON.LOCAL'
12065 include 'COMMON.CHAIN'
12066 include 'COMMON.DERIV'
12067 include 'COMMON.NAMES'
12068 include 'COMMON.INTERACT'
12069 include 'COMMON.IOUNITS'
12070 include 'COMMON.CALC'
12071 include 'COMMON.CONTROL'
12072 include 'COMMON.SPLITELE'
12073 include 'COMMON.SBRIDGE'
12074 double precision tub_r,vectube(3),enetube(maxres*2)
12079 C first we calculate the distance from tube center
12080 C first sugare-phosphate group for NARES this would be peptide group
12083 C lets ommit dummy atoms for now
12084 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12085 C now calculate distance from center of tube and direction vectors
12086 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12087 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12088 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12089 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12090 vectube(1)=vectube(1)-tubecenter(1)
12091 vectube(2)=vectube(2)-tubecenter(2)
12093 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12094 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12096 C as the tube is infinity we do not calculate the Z-vector use of Z
12099 C now calculte the distance
12100 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12101 C now normalize vector
12102 vectube(1)=vectube(1)/tub_r
12103 vectube(2)=vectube(2)/tub_r
12104 C calculte rdiffrence between r and r0
12107 rdiff6=rdiff**6.0d0
12108 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12109 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12110 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12111 C print *,rdiff,rdiff6,pep_aa_tube
12112 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12113 C now we calculate gradient
12114 fac=(-12.0d0*pep_aa_tube/rdiff6+
12115 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12116 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12119 C now direction of gg_tube vector
12121 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12122 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12125 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12127 C Lets not jump over memory as we use many times iti
12129 C lets ommit dummy atoms for now
12131 C in UNRES uncomment the line below as GLY has no side-chain...
12134 vectube(1)=c(1,i+nres)
12135 vectube(1)=mod(vectube(1),boxxsize)
12136 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12137 vectube(2)=c(2,i+nres)
12138 vectube(2)=mod(vectube(2),boxysize)
12139 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12141 vectube(1)=vectube(1)-tubecenter(1)
12142 vectube(2)=vectube(2)-tubecenter(2)
12144 C as the tube is infinity we do not calculate the Z-vector use of Z
12147 C now calculte the distance
12148 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12149 C now normalize vector
12150 vectube(1)=vectube(1)/tub_r
12151 vectube(2)=vectube(2)/tub_r
12152 C calculte rdiffrence between r and r0
12155 rdiff6=rdiff**6.0d0
12156 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12157 sc_aa_tube=sc_aa_tube_par(iti)
12158 sc_bb_tube=sc_bb_tube_par(iti)
12159 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12160 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12161 C now we calculate gradient
12162 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12163 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12164 C now direction of gg_tube vector
12166 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12167 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12171 Etube=Etube+enetube(i)
12173 C print *,"ETUBE", etube
12176 C TO DO 1) add to total energy
12177 C 2) add to gradient summation
12178 C 3) add reading parameters (AND of course oppening of PARAM file)
12179 C 4) add reading the center of tube
12181 C 6) add to zerograd
12183 C-----------------------------------------------------------------------
12184 C-----------------------------------------------------------
12185 C This subroutine is to mimic the histone like structure but as well can be
12186 C utilizet to nanostructures (infinit) small modification has to be used to
12187 C make it finite (z gradient at the ends has to be changes as well as the x,y
12188 C gradient has to be modified at the ends
12189 C The energy function is Kihara potential
12190 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12191 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12192 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12193 C simple Kihara potential
12194 subroutine calctube2(Etube)
12195 implicit real*8 (a-h,o-z)
12196 include 'DIMENSIONS'
12197 include 'COMMON.GEO'
12198 include 'COMMON.VAR'
12199 include 'COMMON.LOCAL'
12200 include 'COMMON.CHAIN'
12201 include 'COMMON.DERIV'
12202 include 'COMMON.NAMES'
12203 include 'COMMON.INTERACT'
12204 include 'COMMON.IOUNITS'
12205 include 'COMMON.CALC'
12206 include 'COMMON.CONTROL'
12207 include 'COMMON.SPLITELE'
12208 include 'COMMON.SBRIDGE'
12209 double precision tub_r,vectube(3),enetube(maxres*2)
12214 C first we calculate the distance from tube center
12215 C first sugare-phosphate group for NARES this would be peptide group
12218 C lets ommit dummy atoms for now
12220 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12221 C now calculate distance from center of tube and direction vectors
12222 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12223 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12224 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12225 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12226 vectube(1)=vectube(1)-tubecenter(1)
12227 vectube(2)=vectube(2)-tubecenter(2)
12229 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12230 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12232 C as the tube is infinity we do not calculate the Z-vector use of Z
12235 C now calculte the distance
12236 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12237 C now normalize vector
12238 vectube(1)=vectube(1)/tub_r
12239 vectube(2)=vectube(2)/tub_r
12240 C calculte rdiffrence between r and r0
12243 rdiff6=rdiff**6.0d0
12244 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12245 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12246 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12247 C print *,rdiff,rdiff6,pep_aa_tube
12248 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12249 C now we calculate gradient
12250 fac=(-12.0d0*pep_aa_tube/rdiff6+
12251 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12252 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12255 C now direction of gg_tube vector
12257 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12258 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12261 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12263 C Lets not jump over memory as we use many times iti
12265 C lets ommit dummy atoms for now
12267 C in UNRES uncomment the line below as GLY has no side-chain...
12270 vectube(1)=c(1,i+nres)
12271 vectube(1)=mod(vectube(1),boxxsize)
12272 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12273 vectube(2)=c(2,i+nres)
12274 vectube(2)=mod(vectube(2),boxysize)
12275 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12277 vectube(1)=vectube(1)-tubecenter(1)
12278 vectube(2)=vectube(2)-tubecenter(2)
12279 C THIS FRAGMENT MAKES TUBE FINITE
12280 positi=(mod(c(3,i+nres),boxzsize))
12281 if (positi.le.0) positi=positi+boxzsize
12282 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12283 c for each residue check if it is in lipid or lipid water border area
12284 C respos=mod(c(3,i+nres),boxzsize)
12285 print *,positi,bordtubebot,buftubebot,bordtubetop
12286 if ((positi.gt.bordtubebot)
12287 & .and.(positi.lt.bordtubetop)) then
12288 C the energy transfer exist
12289 if (positi.lt.buftubebot) then
12291 & ((positi-bordtubebot)/tubebufthick)
12292 C lipbufthick is thickenes of lipid buffore
12293 sstube=sscalelip(fracinbuf)
12294 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12295 print *,ssgradtube, sstube,tubetranene(itype(i))
12296 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12297 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12298 C &+ssgradtube*tubetranene(itype(i))
12299 C gg_tube(3,i-1)= gg_tube(3,i-1)
12300 C &+ssgradtube*tubetranene(itype(i))
12301 C print *,"doing sccale for lower part"
12302 elseif (positi.gt.buftubetop) then
12304 &((bordtubetop-positi)/tubebufthick)
12305 sstube=sscalelip(fracinbuf)
12306 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12307 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12308 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12309 C &+ssgradtube*tubetranene(itype(i))
12310 C gg_tube(3,i-1)= gg_tube(3,i-1)
12311 C &+ssgradtube*tubetranene(itype(i))
12312 C print *, "doing sscalefor top part",sslip,fracinbuf
12316 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12317 C print *,"I am in true lipid"
12323 endif ! if in lipid or buffor
12324 CEND OF FINITE FRAGMENT
12325 C as the tube is infinity we do not calculate the Z-vector use of Z
12328 C now calculte the distance
12329 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12330 C now normalize vector
12331 vectube(1)=vectube(1)/tub_r
12332 vectube(2)=vectube(2)/tub_r
12333 C calculte rdiffrence between r and r0
12336 rdiff6=rdiff**6.0d0
12337 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12338 sc_aa_tube=sc_aa_tube_par(iti)
12339 sc_bb_tube=sc_bb_tube_par(iti)
12340 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12341 & *sstube+enetube(i+nres)
12342 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12343 C now we calculate gradient
12344 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12345 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12346 C now direction of gg_tube vector
12348 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12349 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12351 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12352 &+ssgradtube*enetube(i+nres)/sstube
12353 gg_tube(3,i-1)= gg_tube(3,i-1)
12354 &+ssgradtube*enetube(i+nres)/sstube
12358 Etube=Etube+enetube(i)
12360 C print *,"ETUBE", etube
12363 C TO DO 1) add to total energy
12364 C 2) add to gradient summation
12365 C 3) add reading parameters (AND of course oppening of PARAM file)
12366 C 4) add reading the center of tube
12368 C 6) add to zerograd