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'
31 double precision fac_shieldbuf(maxres),
32 & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
33 & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
34 & grad_shieldbuf(3,-1:maxres)
35 integer ishield_listbuf(maxres),
36 &shield_listbuf(maxcontsshi,maxres)
38 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
39 c & " nfgtasks",nfgtasks
40 if (nfgtasks.gt.1) then
42 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
43 if (fg_rank.eq.0) then
44 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
45 c print *,"Processor",myrank," BROADCAST iorder"
46 C FG master sets up the WEIGHTS_ array which will be broadcast to the
47 C FG slaves as WEIGHTS array.
69 C FG Master broadcasts the WEIGHTS_ array
70 call MPI_Bcast(weights_(1),n_ene,
71 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
73 C FG slaves receive the WEIGHTS array
74 call MPI_Bcast(weights(1),n_ene,
75 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
97 time_Bcast=time_Bcast+MPI_Wtime()-time00
98 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
99 c call chainbuild_cart
101 c print *,'Processor',myrank,' calling etotal ipot=',ipot
102 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
104 c if (modecalc.eq.12.or.modecalc.eq.14) then
105 c call int_from_cart1(.false.)
112 C Compute the side-chain and electrostatic interaction energy
115 goto (101,102,103,104,105,106) ipot
116 C Lennard-Jones potential.
118 cd print '(a)','Exit ELJ'
120 C Lennard-Jones-Kihara potential (shifted).
123 C Berne-Pechukas potential (dilated LJ, angular dependence).
126 C Gay-Berne potential (shifted LJ, angular dependence).
128 C print *,"bylem w egb"
130 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
133 C Soft-sphere potential
134 106 call e_softsphere(evdw)
136 C Calculate electrostatic (H-bonding) energy of the main chain.
140 cmc Sep-06: egb takes care of dynamic ss bonds too
142 c if (dyn_ss) call dyn_set_nss
144 c print *,"Processor",myrank," computed USCSC"
150 time_vec=time_vec+MPI_Wtime()-time01
152 C Introduction of shielding effect first for each peptide group
153 C the shielding factor is set this factor is describing how each
154 C peptide group is shielded by side-chains
155 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
156 C write (iout,*) "shield_mode",shield_mode
157 if (shield_mode.eq.1) then
159 else if (shield_mode.eq.2) then
161 if (nfgtasks.gt.1) then
164 write(iout,*) "befor reduce fac_shield reduce"
166 write(2,*) "fac",itype(i),fac_shield(i),grad_shield(1,i)
167 write(2,*) "list", shield_list(1,i),ishield_list(i),
168 & grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
171 call MPI_Allgatherv(fac_shield(ivec_start),
172 & ivec_count(fg_rank1),
173 & MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0),
175 & MPI_DOUBLE_PRECISION,FG_COMM,IERR)
176 call MPI_Allgatherv(shield_list(1,ivec_start),
177 & ivec_count(fg_rank1),
178 & MPI_I50,shield_listbuf(1,1),ivec_count(0),
180 & MPI_I50,FG_COMM,IERR)
181 call MPI_Allgatherv(ishield_list(ivec_start),
182 & ivec_count(fg_rank1),
183 & MPI_INTEGER,ishield_listbuf(1),ivec_count(0),
185 & MPI_INTEGER,FG_COMM,IERR)
186 call MPI_Allgatherv(grad_shield(1,ivec_start),
187 & ivec_count(fg_rank1),
188 & MPI_UYZ,grad_shieldbuf(1,1),ivec_count(0),
190 & MPI_UYZ,FG_COMM,IERR)
191 call MPI_Allgatherv(grad_shield_side(1,1,ivec_start),
192 & ivec_count(fg_rank1),
193 & MPI_SHI,grad_shield_sidebuf(1,1,1),ivec_count(0),
195 & MPI_SHI,FG_COMM,IERR)
196 call MPI_Allgatherv(grad_shield_loc(1,1,ivec_start),
197 & ivec_count(fg_rank1),
198 & MPI_SHI,grad_shield_locbuf(1,1,1),ivec_count(0),
200 & MPI_SHI,FG_COMM,IERR)
202 fac_shield(i)=fac_shieldbuf(i)
203 ishield_list(i)=ishield_listbuf(i)
205 grad_shield(j,i)=grad_shieldbuf(j,i)
207 do j=1,ishield_list(i)
208 shield_list(j,i)=shield_listbuf(j,i)
210 grad_shield_loc(k,j,i)=grad_shield_locbuf(k,j,i)
211 grad_shield_side(k,j,i)=grad_shield_sidebuf(k,j,i)
216 write(iout,*) "after reduce fac_shield reduce"
218 write(2,*) "fac",itype(i),fac_shield(i),grad_shield(1,i)
219 write(2,*) "list", shield_list(1,i),ishield_list(i),
220 & grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
227 write(iout,*) fac_shield(i),ishield_list(i),i,grad_shield(1,i)
228 do j=1,ishield_list(i)
229 write(iout,*) "grad", grad_shield_side(1,j,i),
230 & grad_shield_loc(1,j,i)
235 c print *,"Processor",myrank," left VEC_AND_DERIV"
238 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
239 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
240 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
241 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
243 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
244 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
245 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
246 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
248 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
257 write (iout,*) "Soft-spheer ELEC potential"
258 c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
261 c print *,"Processor",myrank," computed UELEC"
263 C Calculate excluded-volume interaction energy between peptide groups
268 call escp(evdw2,evdw2_14)
274 c write (iout,*) "Soft-sphere SCP potential"
275 call escp_soft_sphere(evdw2,evdw2_14)
278 c Calculate the bond-stretching energy
282 C Calculate the disulfide-bridge and other energy and the contributions
283 C from other distance constraints.
284 cd print *,'Calling EHPB'
286 cd print *,'EHPB exitted succesfully.'
288 C Calculate the virtual-bond-angle energy.
290 if (wang.gt.0d0) then
291 if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
292 call ebend(ebe,ethetacnstr)
294 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
296 if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
297 call ebend_kcc(ebe,ethetacnstr)
303 c print *,"Processor",myrank," computed UB"
305 C Calculate the SC local energy.
307 C print *,"TU DOCHODZE?"
309 c print *,"Processor",myrank," computed USC"
311 C Calculate the virtual-bond torsional energy.
313 cd print *,'nterm=',nterm
314 C print *,"tor",tor_mode
316 if ((tor_mode.eq.0).or.(tor_mode.eq.2)) then
317 call etor(etors,edihcnstr)
319 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
321 if ((tor_mode.eq.1).or.(tor_mode.eq.2)) then
322 call etor_kcc(etors,edihcnstr)
328 c print *,"Processor",myrank," computed Utor"
330 C 6/23/01 Calculate double-torsional energy
332 if ((wtor_d.gt.0).and.((tor_mode.eq.0).or.(tor_mode.eq.2))) then
337 c print *,"Processor",myrank," computed Utord"
339 C 21/5/07 Calculate local sicdechain correlation energy
341 if (wsccor.gt.0.0d0) then
342 call eback_sc_corr(esccor)
346 C print *,"PRZED MULIt"
347 c print *,"Processor",myrank," computed Usccorr"
349 C 12/1/95 Multi-body terms
353 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
354 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
355 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
356 cd write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
357 cd &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
364 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
365 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
366 cd write (iout,*) "multibody_hb ecorr",ecorr
368 c print *,"Processor",myrank," computed Ucorr"
370 C If performing constraint dynamics, call the constraint energy
371 C after the equilibration time
372 if(usampl.and.totT.gt.eq_time) then
379 C 01/27/2015 added by adasko
380 C the energy component below is energy transfer into lipid environment
381 C based on partition function
382 C print *,"przed lipidami"
383 if (wliptran.gt.0) then
384 call Eliptransfer(eliptran)
388 C print *,"za lipidami"
389 if (AFMlog.gt.0) then
390 call AFMforce(Eafmforce)
391 else if (selfguide.gt.0) then
392 call AFMvel(Eafmforce)
394 if (TUBElog.eq.1) then
395 C print *,"just before call"
397 elseif (TUBElog.eq.2) then
398 call calctube2(Etube)
399 elseif (TUBElog.eq.3) then
406 time_enecalc=time_enecalc+MPI_Wtime()-time00
408 c print *,"Processor",myrank," computed Uconstr"
417 energia(2)=evdw2-evdw2_14
434 energia(8)=eello_turn3
435 energia(9)=eello_turn4
442 energia(19)=edihcnstr
444 energia(20)=Uconst+Uconst_back
447 energia(23)=Eafmforce
448 energia(24)=ethetacnstr
450 c Here are the energies showed per procesor if the are more processors
451 c per molecule then we sum it up in sum_energy subroutine
452 c print *," Processor",myrank," calls SUM_ENERGY"
453 call sum_energy(energia,.true.)
454 if (dyn_ss) call dyn_set_nss
455 c print *," Processor",myrank," left SUM_ENERGY"
457 time_sumene=time_sumene+MPI_Wtime()-time00
461 c-------------------------------------------------------------------------------
462 subroutine sum_energy(energia,reduce)
463 implicit real*8 (a-h,o-z)
468 cMS$ATTRIBUTES C :: proc_proc
474 include 'COMMON.SETUP'
475 include 'COMMON.IOUNITS'
476 double precision energia(0:n_ene),enebuff(0:n_ene+1)
477 include 'COMMON.FFIELD'
478 include 'COMMON.DERIV'
479 include 'COMMON.INTERACT'
480 include 'COMMON.SBRIDGE'
481 include 'COMMON.CHAIN'
483 include 'COMMON.CONTROL'
484 include 'COMMON.TIME1'
487 if (nfgtasks.gt.1 .and. reduce) then
489 write (iout,*) "energies before REDUCE"
490 call enerprint(energia)
494 enebuff(i)=energia(i)
497 call MPI_Barrier(FG_COMM,IERR)
498 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
500 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
501 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
503 write (iout,*) "energies after REDUCE"
504 call enerprint(energia)
507 time_Reduce=time_Reduce+MPI_Wtime()-time00
509 if (fg_rank.eq.0) then
513 evdw2=energia(2)+energia(18)
529 eello_turn3=energia(8)
530 eello_turn4=energia(9)
537 edihcnstr=energia(19)
542 Eafmforce=energia(23)
543 ethetacnstr=energia(24)
546 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
547 & +wang*ebe+wtor*etors+wscloc*escloc
548 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
549 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
550 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
551 & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
552 & +ethetacnstr+wtube*Etube
554 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
555 & +wang*ebe+wtor*etors+wscloc*escloc
556 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
557 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
558 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
559 & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
561 & +ethetacnstr+wtube*Etube
567 if (isnan(etot).ne.0) energia(0)=1.0d+99
569 if (isnan(etot)) energia(0)=1.0d+99
574 idumm=proc_proc(etot,i)
576 call proc_proc(etot,i)
578 if(i.eq.1)energia(0)=1.0d+99
585 c-------------------------------------------------------------------------------
586 subroutine sum_gradient
587 implicit real*8 (a-h,o-z)
592 cMS$ATTRIBUTES C :: proc_proc
598 double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
599 & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
600 & ,gloc_scbuf(3,-1:maxres)
601 include 'COMMON.SETUP'
602 include 'COMMON.IOUNITS'
603 include 'COMMON.FFIELD'
604 include 'COMMON.DERIV'
605 include 'COMMON.INTERACT'
606 include 'COMMON.SBRIDGE'
607 include 'COMMON.CHAIN'
609 include 'COMMON.CONTROL'
610 include 'COMMON.TIME1'
611 include 'COMMON.MAXGRAD'
612 include 'COMMON.SCCOR'
617 write (iout,*) "sum_gradient gvdwc, gvdwx"
619 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
620 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
625 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
626 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
627 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
630 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
631 C in virtual-bond-vector coordinates
634 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
636 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
637 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
639 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
641 c write (iout,'(i5,3f10.5,2x,f10.5)')
642 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
644 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
646 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
647 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
655 gradbufc(j,i)=wsc*gvdwc(j,i)+
656 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
657 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
658 & wel_loc*gel_loc_long(j,i)+
659 & wcorr*gradcorr_long(j,i)+
660 & wcorr5*gradcorr5_long(j,i)+
661 & wcorr6*gradcorr6_long(j,i)+
662 & wturn6*gcorr6_turn_long(j,i)+
664 & +wliptran*gliptranc(j,i)
666 & +welec*gshieldc(j,i)
667 & +wcorr*gshieldc_ec(j,i)
668 & +wturn3*gshieldc_t3(j,i)
669 & +wturn4*gshieldc_t4(j,i)
670 & +wel_loc*gshieldc_ll(j,i)
671 & +wtube*gg_tube(j,i)
679 C print *,"KUPA2",gradbufc(j,i),wsc*gvdwc(j,i),
680 C & wscp*gvdwc_scp(j,i),gvdwc_scpp(j,i),
681 C & welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i),
682 C & wel_loc*gel_loc_long(j,i),
683 C & wcorr*gradcorr_long(j,i),
684 C & wcorr5*gradcorr5_long(j,i),
685 C & wcorr6*gradcorr6_long(j,i),
686 C & wturn6*gcorr6_turn_long(j,i),
687 C & wstrain*ghpbc(j,i)
688 C & ,wliptran*gliptranc(j,i)
690 C & ,welec*gshieldc(j,i)
691 C & ,wcorr*gshieldc_ec(j,i)
692 C & ,wturn3*gshieldc_t3(j,i)
693 C & ,wturn4*gshieldc_t4(j,i)
694 C & ,wel_loc*gshieldc_ll(j,i)
695 C & ,wtube*gg_tube(j,i)
699 gradbufc(j,i)=wsc*gvdwc(j,i)+
700 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
701 & welec*gelc_long(j,i)+
703 & wel_loc*gel_loc_long(j,i)+
704 & wcorr*gradcorr_long(j,i)+
705 & wcorr5*gradcorr5_long(j,i)+
706 & wcorr6*gradcorr6_long(j,i)+
707 & wturn6*gcorr6_turn_long(j,i)+
709 & +wliptran*gliptranc(j,i)
711 & +welec*gshieldc(j,i)
712 & +wcorr*gshieldc_ec(j,i)
713 & +wturn4*gshieldc_t4(j,i)
714 & +wel_loc*gshieldc_ll(j,i)
715 & +wtube*gg_tube(j,i)
723 if (nfgtasks.gt.1) then
726 write (iout,*) "gradbufc before allreduce"
728 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
734 gradbufc_sum(j,i)=gradbufc(j,i)
737 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
738 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
739 c time_reduce=time_reduce+MPI_Wtime()-time00
741 c write (iout,*) "gradbufc_sum after allreduce"
743 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
748 c time_allreduce=time_allreduce+MPI_Wtime()-time00
756 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
757 write (iout,*) (i," jgrad_start",jgrad_start(i),
758 & " jgrad_end ",jgrad_end(i),
759 & i=igrad_start,igrad_end)
762 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
763 c do not parallelize this part.
765 c do i=igrad_start,igrad_end
766 c do j=jgrad_start(i),jgrad_end(i)
768 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
773 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
777 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
781 write (iout,*) "gradbufc after summing"
783 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
790 write (iout,*) "gradbufc"
792 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
798 gradbufc_sum(j,i)=gradbufc(j,i)
803 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
807 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
812 c gradbufc(k,i)=0.0d0
816 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
821 write (iout,*) "gradbufc after summing"
823 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
831 gradbufc(k,nres)=0.0d0
836 C print *,gradbufc(1,13)
837 C print *,welec*gelc(1,13)
838 C print *,wel_loc*gel_loc(1,13)
839 C print *,0.5d0*(wscp*gvdwc_scpp(1,13))
840 C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
841 C print *,wel_loc*gel_loc_long(1,13)
842 C print *,gradafm(1,13),"AFM"
843 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
844 & wel_loc*gel_loc(j,i)+
845 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
846 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
847 & wel_loc*gel_loc_long(j,i)+
848 & wcorr*gradcorr_long(j,i)+
849 & wcorr5*gradcorr5_long(j,i)+
850 & wcorr6*gradcorr6_long(j,i)+
851 & wturn6*gcorr6_turn_long(j,i))+
853 & wcorr*gradcorr(j,i)+
854 & wturn3*gcorr3_turn(j,i)+
855 & wturn4*gcorr4_turn(j,i)+
856 & wcorr5*gradcorr5(j,i)+
857 & wcorr6*gradcorr6(j,i)+
858 & wturn6*gcorr6_turn(j,i)+
859 & wsccor*gsccorc(j,i)
860 & +wscloc*gscloc(j,i)
861 & +wliptran*gliptranc(j,i)
863 & +welec*gshieldc(j,i)
864 & +welec*gshieldc_loc(j,i)
865 & +wcorr*gshieldc_ec(j,i)
866 & +wcorr*gshieldc_loc_ec(j,i)
867 & +wturn3*gshieldc_t3(j,i)
868 & +wturn3*gshieldc_loc_t3(j,i)
869 & +wturn4*gshieldc_t4(j,i)
870 & +wturn4*gshieldc_loc_t4(j,i)
871 & +wel_loc*gshieldc_ll(j,i)
872 & +wel_loc*gshieldc_loc_ll(j,i)
873 & +wtube*gg_tube(j,i)
876 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
877 & wel_loc*gel_loc(j,i)+
878 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
879 & welec*gelc_long(j,i)+
880 & wel_loc*gel_loc_long(j,i)+
881 & wcorr*gcorr_long(j,i)+
882 & wcorr5*gradcorr5_long(j,i)+
883 & wcorr6*gradcorr6_long(j,i)+
884 & wturn6*gcorr6_turn_long(j,i))+
886 & wcorr*gradcorr(j,i)+
887 & wturn3*gcorr3_turn(j,i)+
888 & wturn4*gcorr4_turn(j,i)+
889 & wcorr5*gradcorr5(j,i)+
890 & wcorr6*gradcorr6(j,i)+
891 & wturn6*gcorr6_turn(j,i)+
892 & wsccor*gsccorc(j,i)
893 & +wscloc*gscloc(j,i)
894 & +wliptran*gliptranc(j,i)
896 & +welec*gshieldc(j,i)
897 & +welec*gshieldc_loc(j,i)
898 & +wcorr*gshieldc_ec(j,i)
899 & +wcorr*gshieldc_loc_ec(j,i)
900 & +wturn3*gshieldc_t3(j,i)
901 & +wturn3*gshieldc_loc_t3(j,i)
902 & +wturn4*gshieldc_t4(j,i)
903 & +wturn4*gshieldc_loc_t4(j,i)
904 & +wel_loc*gshieldc_ll(j,i)
905 & +wel_loc*gshieldc_loc_ll(j,i)
906 & +wtube*gg_tube(j,i)
910 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
912 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
913 & wsccor*gsccorx(j,i)
914 & +wscloc*gsclocx(j,i)
915 & +wliptran*gliptranx(j,i)
916 & +welec*gshieldx(j,i)
917 & +wcorr*gshieldx_ec(j,i)
918 & +wturn3*gshieldx_t3(j,i)
919 & +wturn4*gshieldx_t4(j,i)
920 & +wel_loc*gshieldx_ll(j,i)
921 & +wtube*gg_tube_sc(j,i)
929 C print *,"KUPA", gradbufc(j,i),welec*gelc(j,i),
930 C & wel_loc*gel_loc(j,i),
931 C & 0.5d0*wscp*gvdwc_scpp(j,i),
932 C & welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i),
933 C & wel_loc*gel_loc_long(j,i),
934 C & wcorr*gradcorr_long(j,i),
935 C & wcorr5*gradcorr5_long(j,i),
936 C & wcorr6*gradcorr6_long(j,i),
937 C & wturn6*gcorr6_turn_long(j,i),
938 C & wbond*gradb(j,i),
939 C & wcorr*gradcorr(j,i),
940 C & wturn3*gcorr3_turn(j,i),
941 C & wturn4*gcorr4_turn(j,i),
942 C & wcorr5*gradcorr5(j,i),
943 C & wcorr6*gradcorr6(j,i),
944 C & wturn6*gcorr6_turn(j,i),
945 C & wsccor*gsccorc(j,i)
946 C & ,wscloc*gscloc(j,i)
947 C & ,wliptran*gliptranc(j,i)
949 C & +welec*gshieldc(j,i)
950 C & +welec*gshieldc_loc(j,i)
951 C & +wcorr*gshieldc_ec(j,i)
952 C & +wcorr*gshieldc_loc_ec(j,i)
953 C & +wturn3*gshieldc_t3(j,i)
954 C & +wturn3*gshieldc_loc_t3(j,i)
955 C & +wturn4*gshieldc_t4(j,i)
956 C & ,wturn4*gshieldc_loc_t4(j,i)
957 C & ,wel_loc*gshieldc_ll(j,i)
958 C & ,wel_loc*gshieldc_loc_ll(j,i)
959 C & ,wtube*gg_tube(j,i)
961 C print *,gg_tube(1,0),"TU3"
963 write (iout,*) "gloc before adding corr"
965 write (iout,*) i,gloc(i,icg)
969 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
970 & +wcorr5*g_corr5_loc(i)
971 & +wcorr6*g_corr6_loc(i)
972 & +wturn4*gel_loc_turn4(i)
973 & +wturn3*gel_loc_turn3(i)
974 & +wturn6*gel_loc_turn6(i)
975 & +wel_loc*gel_loc_loc(i)
978 write (iout,*) "gloc after adding corr"
980 write (iout,*) i,gloc(i,icg)
984 if (nfgtasks.gt.1) then
987 gradbufc(j,i)=gradc(j,i,icg)
988 gradbufx(j,i)=gradx(j,i,icg)
992 glocbuf(i)=gloc(i,icg)
996 write (iout,*) "gloc_sc before reduce"
999 write (iout,*) i,j,gloc_sc(j,i,icg)
1006 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1010 call MPI_Barrier(FG_COMM,IERR)
1011 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1013 call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,
1014 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1015 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
1016 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1017 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1018 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1019 time_reduce=time_reduce+MPI_Wtime()-time00
1020 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1021 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1022 time_reduce=time_reduce+MPI_Wtime()-time00
1025 write (iout,*) "gloc_sc after reduce"
1028 write (iout,*) i,j,gloc_sc(j,i,icg)
1034 write (iout,*) "gloc after reduce"
1036 write (iout,*) i,gloc(i,icg)
1041 if (gnorm_check) then
1043 c Compute the maximum elements of the gradient
1053 gcorr3_turn_max=0.0d0
1054 gcorr4_turn_max=0.0d0
1057 gcorr6_turn_max=0.0d0
1067 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1068 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1069 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1070 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1071 & gvdwc_scp_max=gvdwc_scp_norm
1072 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1073 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1074 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1075 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1076 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1077 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1078 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1079 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1080 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1081 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1082 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1083 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1084 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1085 & gcorr3_turn(1,i)))
1086 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1087 & gcorr3_turn_max=gcorr3_turn_norm
1088 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1089 & gcorr4_turn(1,i)))
1090 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1091 & gcorr4_turn_max=gcorr4_turn_norm
1092 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1093 if (gradcorr5_norm.gt.gradcorr5_max)
1094 & gradcorr5_max=gradcorr5_norm
1095 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1096 if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1097 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1098 & gcorr6_turn(1,i)))
1099 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1100 & gcorr6_turn_max=gcorr6_turn_norm
1101 gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1102 if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1103 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1104 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1105 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1106 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1107 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1108 if (gradx_scp_norm.gt.gradx_scp_max)
1109 & gradx_scp_max=gradx_scp_norm
1110 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1111 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1112 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1113 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1114 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1115 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1116 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1117 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1121 open(istat,file=statname,position="append")
1123 open(istat,file=statname,access="append")
1125 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1126 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1127 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1128 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1129 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1130 & gsccorx_max,gsclocx_max
1132 if (gvdwc_max.gt.1.0d4) then
1133 write (iout,*) "gvdwc gvdwx gradb gradbx"
1135 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1136 & gradb(j,i),gradbx(j,i),j=1,3)
1138 call pdbout(0.0d0,'cipiszcze',iout)
1144 write (iout,*) "gradc gradx gloc"
1146 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1147 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1151 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1155 c-------------------------------------------------------------------------------
1156 subroutine rescale_weights(t_bath)
1157 implicit real*8 (a-h,o-z)
1158 include 'DIMENSIONS'
1159 include 'COMMON.IOUNITS'
1160 include 'COMMON.FFIELD'
1161 include 'COMMON.SBRIDGE'
1162 include 'COMMON.CONTROL'
1163 double precision kfac /2.4d0/
1164 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1166 c facT=2*temp0/(t_bath+temp0)
1167 if (rescale_mode.eq.0) then
1173 else if (rescale_mode.eq.1) then
1174 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1175 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1176 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1177 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1178 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1179 else if (rescale_mode.eq.2) then
1185 facT=licznik/dlog(dexp(x)+dexp(-x))
1186 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1187 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1188 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1189 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1191 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1192 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1194 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1198 if (shield_mode.gt.0) then
1199 wscp=weights(2)*fact
1201 wvdwpp=weights(16)*fact
1203 welec=weights(3)*fact
1204 wcorr=weights(4)*fact3
1205 wcorr5=weights(5)*fact4
1206 wcorr6=weights(6)*fact5
1207 wel_loc=weights(7)*fact2
1208 wturn3=weights(8)*fact2
1209 wturn4=weights(9)*fact3
1210 wturn6=weights(10)*fact5
1211 wtor=weights(13)*fact
1212 wtor_d=weights(14)*fact2
1213 wsccor=weights(21)*fact
1217 C------------------------------------------------------------------------
1218 subroutine enerprint(energia)
1219 implicit real*8 (a-h,o-z)
1220 include 'DIMENSIONS'
1221 include 'COMMON.IOUNITS'
1222 include 'COMMON.FFIELD'
1223 include 'COMMON.SBRIDGE'
1225 double precision energia(0:n_ene)
1230 evdw2=energia(2)+energia(18)
1242 eello_turn3=energia(8)
1243 eello_turn4=energia(9)
1244 eello_turn6=energia(10)
1250 edihcnstr=energia(19)
1254 eliptran=energia(22)
1255 Eafmforce=energia(23)
1256 ethetacnstr=energia(24)
1259 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1260 & estr,wbond,ebe,wang,
1261 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1263 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1264 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1265 & ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1268 10 format (/'Virtual-chain energies:'//
1269 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1270 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1271 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1272 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1273 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1274 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1275 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1276 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1277 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1278 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
1279 & ' (SS bridges & dist. cnstr.)'/
1280 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1281 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1282 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1283 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1284 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1285 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1286 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1287 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1288 & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1289 & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1290 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1291 & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1292 & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1293 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1294 & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1295 & 'ETOT= ',1pE16.6,' (total)')
1298 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1299 & estr,wbond,ebe,wang,
1300 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1302 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1303 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1304 & ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1307 10 format (/'Virtual-chain energies:'//
1308 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1309 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1310 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1311 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1312 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1313 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1314 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1315 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1316 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
1317 & ' (SS bridges & dist. cnstr.)'/
1318 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1319 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1320 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1321 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1322 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1323 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1324 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1325 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1326 & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1327 & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1328 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1329 & 'UCONST=',1pE16.6,' (Constraint energy)'/
1330 & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1331 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1332 & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1333 & 'ETOT= ',1pE16.6,' (total)')
1337 C-----------------------------------------------------------------------
1338 subroutine elj(evdw)
1340 C This subroutine calculates the interaction energy of nonbonded side chains
1341 C assuming the LJ potential of interaction.
1343 implicit real*8 (a-h,o-z)
1344 include 'DIMENSIONS'
1345 parameter (accur=1.0d-10)
1346 include 'COMMON.GEO'
1347 include 'COMMON.VAR'
1348 include 'COMMON.LOCAL'
1349 include 'COMMON.CHAIN'
1350 include 'COMMON.DERIV'
1351 include 'COMMON.INTERACT'
1352 include 'COMMON.TORSION'
1353 include 'COMMON.SBRIDGE'
1354 include 'COMMON.NAMES'
1355 include 'COMMON.IOUNITS'
1356 include 'COMMON.CONTACTS'
1358 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1360 do i=iatsc_s,iatsc_e
1361 itypi=iabs(itype(i))
1362 if (itypi.eq.ntyp1) cycle
1363 itypi1=iabs(itype(i+1))
1370 C Calculate SC interaction energy.
1372 do iint=1,nint_gr(i)
1373 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1374 cd & 'iend=',iend(i,iint)
1375 do j=istart(i,iint),iend(i,iint)
1376 itypj=iabs(itype(j))
1377 if (itypj.eq.ntyp1) cycle
1381 C Change 12/1/95 to calculate four-body interactions
1382 rij=xj*xj+yj*yj+zj*zj
1384 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1385 eps0ij=eps(itypi,itypj)
1387 C have you changed here?
1391 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1392 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1393 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1394 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1395 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1396 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1399 C Calculate the components of the gradient in DC and X
1401 fac=-rrij*(e1+evdwij)
1406 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1407 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1408 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1409 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1413 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1417 C 12/1/95, revised on 5/20/97
1419 C Calculate the contact function. The ith column of the array JCONT will
1420 C contain the numbers of atoms that make contacts with the atom I (of numbers
1421 C greater than I). The arrays FACONT and GACONT will contain the values of
1422 C the contact function and its derivative.
1424 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1425 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1426 C Uncomment next line, if the correlation interactions are contact function only
1427 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1429 sigij=sigma(itypi,itypj)
1430 r0ij=rs0(itypi,itypj)
1432 C Check whether the SC's are not too far to make a contact.
1435 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1436 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1438 if (fcont.gt.0.0D0) then
1439 C If the SC-SC distance if close to sigma, apply spline.
1440 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1441 cAdam & fcont1,fprimcont1)
1442 cAdam fcont1=1.0d0-fcont1
1443 cAdam if (fcont1.gt.0.0d0) then
1444 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1445 cAdam fcont=fcont*fcont1
1447 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1448 cga eps0ij=1.0d0/dsqrt(eps0ij)
1450 cga gg(k)=gg(k)*eps0ij
1452 cga eps0ij=-evdwij*eps0ij
1453 C Uncomment for AL's type of SC correlation interactions.
1454 cadam eps0ij=-evdwij
1455 num_conti=num_conti+1
1456 jcont(num_conti,i)=j
1457 facont(num_conti,i)=fcont*eps0ij
1458 fprimcont=eps0ij*fprimcont/rij
1460 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1461 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1462 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1463 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1464 gacont(1,num_conti,i)=-fprimcont*xj
1465 gacont(2,num_conti,i)=-fprimcont*yj
1466 gacont(3,num_conti,i)=-fprimcont*zj
1467 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1468 cd write (iout,'(2i3,3f10.5)')
1469 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1475 num_cont(i)=num_conti
1479 gvdwc(j,i)=expon*gvdwc(j,i)
1480 gvdwx(j,i)=expon*gvdwx(j,i)
1483 C******************************************************************************
1487 C To save time, the factor of EXPON has been extracted from ALL components
1488 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1491 C******************************************************************************
1494 C-----------------------------------------------------------------------------
1495 subroutine eljk(evdw)
1497 C This subroutine calculates the interaction energy of nonbonded side chains
1498 C assuming the LJK potential of interaction.
1500 implicit real*8 (a-h,o-z)
1501 include 'DIMENSIONS'
1502 include 'COMMON.GEO'
1503 include 'COMMON.VAR'
1504 include 'COMMON.LOCAL'
1505 include 'COMMON.CHAIN'
1506 include 'COMMON.DERIV'
1507 include 'COMMON.INTERACT'
1508 include 'COMMON.IOUNITS'
1509 include 'COMMON.NAMES'
1512 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1514 do i=iatsc_s,iatsc_e
1515 itypi=iabs(itype(i))
1516 if (itypi.eq.ntyp1) cycle
1517 itypi1=iabs(itype(i+1))
1522 C Calculate SC interaction energy.
1524 do iint=1,nint_gr(i)
1525 do j=istart(i,iint),iend(i,iint)
1526 itypj=iabs(itype(j))
1527 if (itypj.eq.ntyp1) cycle
1531 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1532 fac_augm=rrij**expon
1533 e_augm=augm(itypi,itypj)*fac_augm
1534 r_inv_ij=dsqrt(rrij)
1536 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1537 fac=r_shift_inv**expon
1538 C have you changed here?
1542 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1543 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1544 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1545 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1546 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1547 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1548 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1551 C Calculate the components of the gradient in DC and X
1553 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1558 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1559 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1560 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1561 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1565 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1573 gvdwc(j,i)=expon*gvdwc(j,i)
1574 gvdwx(j,i)=expon*gvdwx(j,i)
1579 C-----------------------------------------------------------------------------
1580 subroutine ebp(evdw)
1582 C This subroutine calculates the interaction energy of nonbonded side chains
1583 C assuming the Berne-Pechukas potential of interaction.
1585 implicit real*8 (a-h,o-z)
1586 include 'DIMENSIONS'
1587 include 'COMMON.GEO'
1588 include 'COMMON.VAR'
1589 include 'COMMON.LOCAL'
1590 include 'COMMON.CHAIN'
1591 include 'COMMON.DERIV'
1592 include 'COMMON.NAMES'
1593 include 'COMMON.INTERACT'
1594 include 'COMMON.IOUNITS'
1595 include 'COMMON.CALC'
1596 common /srutu/ icall
1597 c double precision rrsave(maxdim)
1600 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1602 c if (icall.eq.0) then
1608 do i=iatsc_s,iatsc_e
1609 itypi=iabs(itype(i))
1610 if (itypi.eq.ntyp1) cycle
1611 itypi1=iabs(itype(i+1))
1615 dxi=dc_norm(1,nres+i)
1616 dyi=dc_norm(2,nres+i)
1617 dzi=dc_norm(3,nres+i)
1618 c dsci_inv=dsc_inv(itypi)
1619 dsci_inv=vbld_inv(i+nres)
1621 C Calculate SC interaction energy.
1623 do iint=1,nint_gr(i)
1624 do j=istart(i,iint),iend(i,iint)
1626 itypj=iabs(itype(j))
1627 if (itypj.eq.ntyp1) cycle
1628 c dscj_inv=dsc_inv(itypj)
1629 dscj_inv=vbld_inv(j+nres)
1630 chi1=chi(itypi,itypj)
1631 chi2=chi(itypj,itypi)
1638 alf12=0.5D0*(alf1+alf2)
1639 C For diagnostics only!!!
1652 dxj=dc_norm(1,nres+j)
1653 dyj=dc_norm(2,nres+j)
1654 dzj=dc_norm(3,nres+j)
1655 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1656 cd if (icall.eq.0) then
1662 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1664 C Calculate whole angle-dependent part of epsilon and contributions
1665 C to its derivatives
1666 C have you changed here?
1667 fac=(rrij*sigsq)**expon2
1670 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1671 eps2der=evdwij*eps3rt
1672 eps3der=evdwij*eps2rt
1673 evdwij=evdwij*eps2rt*eps3rt
1676 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1678 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1679 cd & restyp(itypi),i,restyp(itypj),j,
1680 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1681 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1682 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1685 C Calculate gradient components.
1686 e1=e1*eps1*eps2rt**2*eps3rt**2
1687 fac=-expon*(e1+evdwij)
1690 C Calculate radial part of the gradient
1694 C Calculate the angular part of the gradient and sum add the contributions
1695 C to the appropriate components of the Cartesian gradient.
1703 C-----------------------------------------------------------------------------
1704 subroutine egb(evdw)
1706 C This subroutine calculates the interaction energy of nonbonded side chains
1707 C assuming the Gay-Berne potential of interaction.
1709 implicit real*8 (a-h,o-z)
1710 include 'DIMENSIONS'
1711 include 'COMMON.GEO'
1712 include 'COMMON.VAR'
1713 include 'COMMON.LOCAL'
1714 include 'COMMON.CHAIN'
1715 include 'COMMON.DERIV'
1716 include 'COMMON.NAMES'
1717 include 'COMMON.INTERACT'
1718 include 'COMMON.IOUNITS'
1719 include 'COMMON.CALC'
1720 include 'COMMON.CONTROL'
1721 include 'COMMON.SPLITELE'
1722 include 'COMMON.SBRIDGE'
1724 integer xshift,yshift,zshift
1727 ccccc energy_dec=.false.
1728 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1731 c if (icall.eq.0) lprn=.false.
1733 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1734 C we have the original box)
1738 do i=iatsc_s,iatsc_e
1739 itypi=iabs(itype(i))
1740 if (itypi.eq.ntyp1) cycle
1741 itypi1=iabs(itype(i+1))
1745 C Return atom into box, boxxsize is size of box in x dimension
1747 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1748 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1749 C Condition for being inside the proper box
1750 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1751 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
1755 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1756 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1757 C Condition for being inside the proper box
1758 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1759 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
1763 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1764 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1765 C Condition for being inside the proper box
1766 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1767 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
1771 if (xi.lt.0) xi=xi+boxxsize
1773 if (yi.lt.0) yi=yi+boxysize
1775 if (zi.lt.0) zi=zi+boxzsize
1776 C define scaling factor for lipids
1778 C if (positi.le.0) positi=positi+boxzsize
1780 C first for peptide groups
1781 c for each residue check if it is in lipid or lipid water border area
1782 if ((zi.gt.bordlipbot)
1783 &.and.(zi.lt.bordliptop)) then
1784 C the energy transfer exist
1785 if (zi.lt.buflipbot) then
1786 C what fraction I am in
1788 & ((zi-bordlipbot)/lipbufthick)
1789 C lipbufthick is thickenes of lipid buffore
1790 sslipi=sscalelip(fracinbuf)
1791 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1792 elseif (zi.gt.bufliptop) then
1793 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1794 sslipi=sscalelip(fracinbuf)
1795 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1805 C xi=xi+xshift*boxxsize
1806 C yi=yi+yshift*boxysize
1807 C zi=zi+zshift*boxzsize
1809 dxi=dc_norm(1,nres+i)
1810 dyi=dc_norm(2,nres+i)
1811 dzi=dc_norm(3,nres+i)
1812 c dsci_inv=dsc_inv(itypi)
1813 dsci_inv=vbld_inv(i+nres)
1814 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1815 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1817 C Calculate SC interaction energy.
1819 do iint=1,nint_gr(i)
1820 do j=istart(i,iint),iend(i,iint)
1821 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1823 c write(iout,*) "PRZED ZWYKLE", evdwij
1824 call dyn_ssbond_ene(i,j,evdwij)
1825 c write(iout,*) "PO ZWYKLE", evdwij
1828 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1829 & 'evdw',i,j,evdwij,' ss'
1830 C triple bond artifac removal
1831 do k=j+1,iend(i,iint)
1832 C search over all next residues
1833 if (dyn_ss_mask(k)) then
1834 C check if they are cysteins
1835 C write(iout,*) 'k=',k
1837 c write(iout,*) "PRZED TRI", evdwij
1838 evdwij_przed_tri=evdwij
1839 call triple_ssbond_ene(i,j,k,evdwij)
1840 c if(evdwij_przed_tri.ne.evdwij) then
1841 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1844 c write(iout,*) "PO TRI", evdwij
1845 C call the energy function that removes the artifical triple disulfide
1846 C bond the soubroutine is located in ssMD.F
1848 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1849 & 'evdw',i,j,evdwij,'tss'
1850 endif!dyn_ss_mask(k)
1854 itypj=iabs(itype(j))
1855 if (itypj.eq.ntyp1) cycle
1856 c dscj_inv=dsc_inv(itypj)
1857 dscj_inv=vbld_inv(j+nres)
1858 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1859 c & 1.0d0/vbld(j+nres)
1860 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1861 sig0ij=sigma(itypi,itypj)
1862 chi1=chi(itypi,itypj)
1863 chi2=chi(itypj,itypi)
1870 alf12=0.5D0*(alf1+alf2)
1871 C For diagnostics only!!!
1884 C Return atom J into box the original box
1886 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1887 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1888 C Condition for being inside the proper box
1889 c if ((xj.gt.((0.5d0)*boxxsize)).or.
1890 c & (xj.lt.((-0.5d0)*boxxsize))) then
1894 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1895 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1896 C Condition for being inside the proper box
1897 c if ((yj.gt.((0.5d0)*boxysize)).or.
1898 c & (yj.lt.((-0.5d0)*boxysize))) then
1902 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1903 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1904 C Condition for being inside the proper box
1905 c if ((zj.gt.((0.5d0)*boxzsize)).or.
1906 c & (zj.lt.((-0.5d0)*boxzsize))) then
1910 if (xj.lt.0) xj=xj+boxxsize
1912 if (yj.lt.0) yj=yj+boxysize
1914 if (zj.lt.0) zj=zj+boxzsize
1915 if ((zj.gt.bordlipbot)
1916 &.and.(zj.lt.bordliptop)) then
1917 C the energy transfer exist
1918 if (zj.lt.buflipbot) then
1919 C what fraction I am in
1921 & ((zj-bordlipbot)/lipbufthick)
1922 C lipbufthick is thickenes of lipid buffore
1923 sslipj=sscalelip(fracinbuf)
1924 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1925 elseif (zj.gt.bufliptop) then
1926 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1927 sslipj=sscalelip(fracinbuf)
1928 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1937 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1938 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1939 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1940 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1941 C write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1942 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1943 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1944 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1945 C print *,sslipi,sslipj,bordlipbot,zi,zj
1946 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1954 xj=xj_safe+xshift*boxxsize
1955 yj=yj_safe+yshift*boxysize
1956 zj=zj_safe+zshift*boxzsize
1957 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1958 if(dist_temp.lt.dist_init) then
1968 if (subchap.eq.1) then
1977 dxj=dc_norm(1,nres+j)
1978 dyj=dc_norm(2,nres+j)
1979 dzj=dc_norm(3,nres+j)
1983 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1984 c write (iout,*) "j",j," dc_norm",
1985 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1986 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1988 sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1989 sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1991 c write (iout,'(a7,4f8.3)')
1992 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1993 if (sss.gt.0.0d0) then
1994 C Calculate angle-dependent terms of energy and contributions to their
1998 sig=sig0ij*dsqrt(sigsq)
1999 rij_shift=1.0D0/rij-sig+sig0ij
2000 c for diagnostics; uncomment
2001 c rij_shift=1.2*sig0ij
2002 C I hate to put IF's in the loops, but here don't have another choice!!!!
2003 if (rij_shift.le.0.0D0) then
2005 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2006 cd & restyp(itypi),i,restyp(itypj),j,
2007 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2011 c---------------------------------------------------------------
2012 rij_shift=1.0D0/rij_shift
2013 fac=rij_shift**expon
2014 C here to start with
2019 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2020 eps2der=evdwij*eps3rt
2021 eps3der=evdwij*eps2rt
2022 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2023 C &((sslipi+sslipj)/2.0d0+
2024 C &(2.0d0-sslipi-sslipj)/2.0d0)
2025 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2026 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2027 evdwij=evdwij*eps2rt*eps3rt
2028 evdw=evdw+evdwij*sss
2030 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2032 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2033 & restyp(itypi),i,restyp(itypj),j,
2034 & epsi,sigm,chi1,chi2,chip1,chip2,
2035 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2036 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2040 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2043 C Calculate gradient components.
2044 e1=e1*eps1*eps2rt**2*eps3rt**2
2045 fac=-expon*(e1+evdwij)*rij_shift
2048 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
2049 c & evdwij,fac,sigma(itypi,itypj),expon
2050 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2052 C Calculate the radial part of the gradient
2053 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2054 &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2055 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2056 &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2057 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2058 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2064 C Calculate angular part of the gradient.
2074 c write (iout,*) "Number of loop steps in EGB:",ind
2075 cccc energy_dec=.false.
2078 C-----------------------------------------------------------------------------
2079 subroutine egbv(evdw)
2081 C This subroutine calculates the interaction energy of nonbonded side chains
2082 C assuming the Gay-Berne-Vorobjev potential of interaction.
2084 implicit real*8 (a-h,o-z)
2085 include 'DIMENSIONS'
2086 include 'COMMON.GEO'
2087 include 'COMMON.VAR'
2088 include 'COMMON.LOCAL'
2089 include 'COMMON.CHAIN'
2090 include 'COMMON.DERIV'
2091 include 'COMMON.NAMES'
2092 include 'COMMON.INTERACT'
2093 include 'COMMON.IOUNITS'
2094 include 'COMMON.CALC'
2095 common /srutu/ icall
2098 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2101 c if (icall.eq.0) lprn=.true.
2103 do i=iatsc_s,iatsc_e
2104 itypi=iabs(itype(i))
2105 if (itypi.eq.ntyp1) cycle
2106 itypi1=iabs(itype(i+1))
2111 if (xi.lt.0) xi=xi+boxxsize
2113 if (yi.lt.0) yi=yi+boxysize
2115 if (zi.lt.0) zi=zi+boxzsize
2116 C define scaling factor for lipids
2118 C if (positi.le.0) positi=positi+boxzsize
2120 C first for peptide groups
2121 c for each residue check if it is in lipid or lipid water border area
2122 if ((zi.gt.bordlipbot)
2123 &.and.(zi.lt.bordliptop)) then
2124 C the energy transfer exist
2125 if (zi.lt.buflipbot) then
2126 C what fraction I am in
2128 & ((zi-bordlipbot)/lipbufthick)
2129 C lipbufthick is thickenes of lipid buffore
2130 sslipi=sscalelip(fracinbuf)
2131 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2132 elseif (zi.gt.bufliptop) then
2133 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2134 sslipi=sscalelip(fracinbuf)
2135 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2145 dxi=dc_norm(1,nres+i)
2146 dyi=dc_norm(2,nres+i)
2147 dzi=dc_norm(3,nres+i)
2148 c dsci_inv=dsc_inv(itypi)
2149 dsci_inv=vbld_inv(i+nres)
2151 C Calculate SC interaction energy.
2153 do iint=1,nint_gr(i)
2154 do j=istart(i,iint),iend(i,iint)
2156 itypj=iabs(itype(j))
2157 if (itypj.eq.ntyp1) cycle
2158 c dscj_inv=dsc_inv(itypj)
2159 dscj_inv=vbld_inv(j+nres)
2160 sig0ij=sigma(itypi,itypj)
2161 r0ij=r0(itypi,itypj)
2162 chi1=chi(itypi,itypj)
2163 chi2=chi(itypj,itypi)
2170 alf12=0.5D0*(alf1+alf2)
2171 C For diagnostics only!!!
2185 if (xj.lt.0) xj=xj+boxxsize
2187 if (yj.lt.0) yj=yj+boxysize
2189 if (zj.lt.0) zj=zj+boxzsize
2190 if ((zj.gt.bordlipbot)
2191 &.and.(zj.lt.bordliptop)) then
2192 C the energy transfer exist
2193 if (zj.lt.buflipbot) then
2194 C what fraction I am in
2196 & ((zj-bordlipbot)/lipbufthick)
2197 C lipbufthick is thickenes of lipid buffore
2198 sslipj=sscalelip(fracinbuf)
2199 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2200 elseif (zj.gt.bufliptop) then
2201 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2202 sslipj=sscalelip(fracinbuf)
2203 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2212 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2213 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2214 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2215 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2216 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2217 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2218 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2219 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2227 xj=xj_safe+xshift*boxxsize
2228 yj=yj_safe+yshift*boxysize
2229 zj=zj_safe+zshift*boxzsize
2230 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2231 if(dist_temp.lt.dist_init) then
2241 if (subchap.eq.1) then
2250 dxj=dc_norm(1,nres+j)
2251 dyj=dc_norm(2,nres+j)
2252 dzj=dc_norm(3,nres+j)
2253 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2255 C Calculate angle-dependent terms of energy and contributions to their
2259 sig=sig0ij*dsqrt(sigsq)
2260 rij_shift=1.0D0/rij-sig+r0ij
2261 C I hate to put IF's in the loops, but here don't have another choice!!!!
2262 if (rij_shift.le.0.0D0) then
2267 c---------------------------------------------------------------
2268 rij_shift=1.0D0/rij_shift
2269 fac=rij_shift**expon
2272 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2273 eps2der=evdwij*eps3rt
2274 eps3der=evdwij*eps2rt
2275 fac_augm=rrij**expon
2276 e_augm=augm(itypi,itypj)*fac_augm
2277 evdwij=evdwij*eps2rt*eps3rt
2278 evdw=evdw+evdwij+e_augm
2280 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2282 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2283 & restyp(itypi),i,restyp(itypj),j,
2284 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2285 & chi1,chi2,chip1,chip2,
2286 & eps1,eps2rt**2,eps3rt**2,
2287 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2290 C Calculate gradient components.
2291 e1=e1*eps1*eps2rt**2*eps3rt**2
2292 fac=-expon*(e1+evdwij)*rij_shift
2294 fac=rij*fac-2*expon*rrij*e_augm
2295 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2296 C Calculate the radial part of the gradient
2300 C Calculate angular part of the gradient.
2306 C-----------------------------------------------------------------------------
2307 subroutine sc_angular
2308 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2309 C om12. Called by ebp, egb, and egbv.
2311 include 'COMMON.CALC'
2312 include 'COMMON.IOUNITS'
2316 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2317 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2318 om12=dxi*dxj+dyi*dyj+dzi*dzj
2320 C Calculate eps1(om12) and its derivative in om12
2321 faceps1=1.0D0-om12*chiom12
2322 faceps1_inv=1.0D0/faceps1
2323 eps1=dsqrt(faceps1_inv)
2324 C Following variable is eps1*deps1/dom12
2325 eps1_om12=faceps1_inv*chiom12
2330 c write (iout,*) "om12",om12," eps1",eps1
2331 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2336 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2337 sigsq=1.0D0-facsig*faceps1_inv
2338 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2339 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2340 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2346 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2347 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2349 C Calculate eps2 and its derivatives in om1, om2, and om12.
2352 chipom12=chip12*om12
2353 facp=1.0D0-om12*chipom12
2355 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2356 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2357 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2358 C Following variable is the square root of eps2
2359 eps2rt=1.0D0-facp1*facp_inv
2360 C Following three variables are the derivatives of the square root of eps
2361 C in om1, om2, and om12.
2362 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2363 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2364 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2365 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2366 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2367 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2368 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2369 c & " eps2rt_om12",eps2rt_om12
2370 C Calculate whole angle-dependent part of epsilon and contributions
2371 C to its derivatives
2374 C----------------------------------------------------------------------------
2376 implicit real*8 (a-h,o-z)
2377 include 'DIMENSIONS'
2378 include 'COMMON.CHAIN'
2379 include 'COMMON.DERIV'
2380 include 'COMMON.CALC'
2381 include 'COMMON.IOUNITS'
2382 double precision dcosom1(3),dcosom2(3)
2383 cc print *,'sss=',sss
2384 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2385 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2386 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2387 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2391 c eom12=evdwij*eps1_om12
2393 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2394 c & " sigder",sigder
2395 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2396 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2398 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2399 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2402 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2404 c write (iout,*) "gg",(gg(k),k=1,3)
2406 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2407 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2408 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2409 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2410 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2411 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2412 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2413 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2414 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2415 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2418 C Calculate the components of the gradient in DC and X
2422 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2426 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2427 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2431 C-----------------------------------------------------------------------
2432 subroutine e_softsphere(evdw)
2434 C This subroutine calculates the interaction energy of nonbonded side chains
2435 C assuming the LJ potential of interaction.
2437 implicit real*8 (a-h,o-z)
2438 include 'DIMENSIONS'
2439 parameter (accur=1.0d-10)
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.TORSION'
2447 include 'COMMON.SBRIDGE'
2448 include 'COMMON.NAMES'
2449 include 'COMMON.IOUNITS'
2450 include 'COMMON.CONTACTS'
2452 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2454 do i=iatsc_s,iatsc_e
2455 itypi=iabs(itype(i))
2456 if (itypi.eq.ntyp1) cycle
2457 itypi1=iabs(itype(i+1))
2462 C Calculate SC interaction energy.
2464 do iint=1,nint_gr(i)
2465 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2466 cd & 'iend=',iend(i,iint)
2467 do j=istart(i,iint),iend(i,iint)
2468 itypj=iabs(itype(j))
2469 if (itypj.eq.ntyp1) cycle
2473 rij=xj*xj+yj*yj+zj*zj
2474 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2475 r0ij=r0(itypi,itypj)
2477 c print *,i,j,r0ij,dsqrt(rij)
2478 if (rij.lt.r0ijsq) then
2479 evdwij=0.25d0*(rij-r0ijsq)**2
2487 C Calculate the components of the gradient in DC and X
2493 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2494 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2495 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2496 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2500 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2508 C--------------------------------------------------------------------------
2509 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2512 C Soft-sphere potential of p-p interaction
2514 implicit real*8 (a-h,o-z)
2515 include 'DIMENSIONS'
2516 include 'COMMON.CONTROL'
2517 include 'COMMON.IOUNITS'
2518 include 'COMMON.GEO'
2519 include 'COMMON.VAR'
2520 include 'COMMON.LOCAL'
2521 include 'COMMON.CHAIN'
2522 include 'COMMON.DERIV'
2523 include 'COMMON.INTERACT'
2524 include 'COMMON.CONTACTS'
2525 include 'COMMON.TORSION'
2526 include 'COMMON.VECTORS'
2527 include 'COMMON.FFIELD'
2529 C write(iout,*) 'In EELEC_soft_sphere'
2536 do i=iatel_s,iatel_e
2537 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2541 xmedi=c(1,i)+0.5d0*dxi
2542 ymedi=c(2,i)+0.5d0*dyi
2543 zmedi=c(3,i)+0.5d0*dzi
2544 xmedi=mod(xmedi,boxxsize)
2545 if (xmedi.lt.0) xmedi=xmedi+boxxsize
2546 ymedi=mod(ymedi,boxysize)
2547 if (ymedi.lt.0) ymedi=ymedi+boxysize
2548 zmedi=mod(zmedi,boxzsize)
2549 if (zmedi.lt.0) zmedi=zmedi+boxzsize
2551 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2552 do j=ielstart(i),ielend(i)
2553 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2557 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2558 r0ij=rpp(iteli,itelj)
2567 if (xj.lt.0) xj=xj+boxxsize
2569 if (yj.lt.0) yj=yj+boxysize
2571 if (zj.lt.0) zj=zj+boxzsize
2572 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2580 xj=xj_safe+xshift*boxxsize
2581 yj=yj_safe+yshift*boxysize
2582 zj=zj_safe+zshift*boxzsize
2583 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2584 if(dist_temp.lt.dist_init) then
2594 if (isubchap.eq.1) then
2603 rij=xj*xj+yj*yj+zj*zj
2604 sss=sscale(sqrt(rij))
2605 sssgrad=sscagrad(sqrt(rij))
2606 if (rij.lt.r0ijsq) then
2607 evdw1ij=0.25d0*(rij-r0ijsq)**2
2613 evdw1=evdw1+evdw1ij*sss
2615 C Calculate contributions to the Cartesian gradient.
2617 ggg(1)=fac*xj*sssgrad
2618 ggg(2)=fac*yj*sssgrad
2619 ggg(3)=fac*zj*sssgrad
2621 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2622 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2625 * Loop over residues i+1 thru j-1.
2629 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2634 cgrad do i=nnt,nct-1
2636 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2638 cgrad do j=i+1,nct-1
2640 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2646 c------------------------------------------------------------------------------
2647 subroutine vec_and_deriv
2648 implicit real*8 (a-h,o-z)
2649 include 'DIMENSIONS'
2653 include 'COMMON.IOUNITS'
2654 include 'COMMON.GEO'
2655 include 'COMMON.VAR'
2656 include 'COMMON.LOCAL'
2657 include 'COMMON.CHAIN'
2658 include 'COMMON.VECTORS'
2659 include 'COMMON.SETUP'
2660 include 'COMMON.TIME1'
2661 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2662 C Compute the local reference systems. For reference system (i), the
2663 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2664 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2666 do i=ivec_start,ivec_end
2670 if (i.eq.nres-1) then
2671 C Case of the last full residue
2672 C Compute the Z-axis
2673 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2674 costh=dcos(pi-theta(nres))
2675 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2679 C Compute the derivatives of uz
2681 uzder(2,1,1)=-dc_norm(3,i-1)
2682 uzder(3,1,1)= dc_norm(2,i-1)
2683 uzder(1,2,1)= dc_norm(3,i-1)
2685 uzder(3,2,1)=-dc_norm(1,i-1)
2686 uzder(1,3,1)=-dc_norm(2,i-1)
2687 uzder(2,3,1)= dc_norm(1,i-1)
2690 uzder(2,1,2)= dc_norm(3,i)
2691 uzder(3,1,2)=-dc_norm(2,i)
2692 uzder(1,2,2)=-dc_norm(3,i)
2694 uzder(3,2,2)= dc_norm(1,i)
2695 uzder(1,3,2)= dc_norm(2,i)
2696 uzder(2,3,2)=-dc_norm(1,i)
2698 C Compute the Y-axis
2701 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2703 C Compute the derivatives of uy
2706 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2707 & -dc_norm(k,i)*dc_norm(j,i-1)
2708 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2710 uyder(j,j,1)=uyder(j,j,1)-costh
2711 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2716 uygrad(l,k,j,i)=uyder(l,k,j)
2717 uzgrad(l,k,j,i)=uzder(l,k,j)
2721 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2722 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2723 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2724 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2727 C Compute the Z-axis
2728 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2729 costh=dcos(pi-theta(i+2))
2730 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2734 C Compute the derivatives of uz
2736 uzder(2,1,1)=-dc_norm(3,i+1)
2737 uzder(3,1,1)= dc_norm(2,i+1)
2738 uzder(1,2,1)= dc_norm(3,i+1)
2740 uzder(3,2,1)=-dc_norm(1,i+1)
2741 uzder(1,3,1)=-dc_norm(2,i+1)
2742 uzder(2,3,1)= dc_norm(1,i+1)
2745 uzder(2,1,2)= dc_norm(3,i)
2746 uzder(3,1,2)=-dc_norm(2,i)
2747 uzder(1,2,2)=-dc_norm(3,i)
2749 uzder(3,2,2)= dc_norm(1,i)
2750 uzder(1,3,2)= dc_norm(2,i)
2751 uzder(2,3,2)=-dc_norm(1,i)
2753 C Compute the Y-axis
2756 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2758 C Compute the derivatives of uy
2761 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2762 & -dc_norm(k,i)*dc_norm(j,i+1)
2763 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2765 uyder(j,j,1)=uyder(j,j,1)-costh
2766 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2771 uygrad(l,k,j,i)=uyder(l,k,j)
2772 uzgrad(l,k,j,i)=uzder(l,k,j)
2776 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2777 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2778 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2779 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2783 vbld_inv_temp(1)=vbld_inv(i+1)
2784 if (i.lt.nres-1) then
2785 vbld_inv_temp(2)=vbld_inv(i+2)
2787 vbld_inv_temp(2)=vbld_inv(i)
2792 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2793 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2798 #if defined(PARVEC) && defined(MPI)
2799 if (nfgtasks1.gt.1) then
2801 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2802 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2803 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2804 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2805 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2807 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2808 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2810 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2811 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2812 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2813 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2814 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2815 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2816 time_gather=time_gather+MPI_Wtime()-time00
2818 c if (fg_rank.eq.0) then
2819 c write (iout,*) "Arrays UY and UZ"
2821 c write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2828 C-----------------------------------------------------------------------------
2829 subroutine check_vecgrad
2830 implicit real*8 (a-h,o-z)
2831 include 'DIMENSIONS'
2832 include 'COMMON.IOUNITS'
2833 include 'COMMON.GEO'
2834 include 'COMMON.VAR'
2835 include 'COMMON.LOCAL'
2836 include 'COMMON.CHAIN'
2837 include 'COMMON.VECTORS'
2838 dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2839 dimension uyt(3,maxres),uzt(3,maxres)
2840 dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2841 double precision delta /1.0d-7/
2844 crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2845 crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2846 crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2847 cd write(iout,'(2i5,2(3f10.5,5x))') i,1,
2848 cd & (dc_norm(if90,i),if90=1,3)
2849 cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2850 cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2851 cd write(iout,'(a)')
2857 uygradt(l,k,j,i)=uygrad(l,k,j,i)
2858 uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2871 cd write (iout,*) 'i=',i
2873 erij(k)=dc_norm(k,i)
2877 dc_norm(k,i)=erij(k)
2879 dc_norm(j,i)=dc_norm(j,i)+delta
2880 c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2882 c dc_norm(k,i)=dc_norm(k,i)/fac
2884 c write (iout,*) (dc_norm(k,i),k=1,3)
2885 c write (iout,*) (erij(k),k=1,3)
2888 uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2889 uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2890 uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2891 uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2893 c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2894 c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2895 c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2898 dc_norm(k,i)=erij(k)
2901 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2902 cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2903 cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2904 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2905 cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2906 cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2907 cd write (iout,'(a)')
2912 C--------------------------------------------------------------------------
2913 subroutine set_matrices
2914 implicit real*8 (a-h,o-z)
2915 include 'DIMENSIONS'
2918 include "COMMON.SETUP"
2920 integer status(MPI_STATUS_SIZE)
2922 include 'COMMON.IOUNITS'
2923 include 'COMMON.GEO'
2924 include 'COMMON.VAR'
2925 include 'COMMON.LOCAL'
2926 include 'COMMON.CHAIN'
2927 include 'COMMON.DERIV'
2928 include 'COMMON.INTERACT'
2929 include 'COMMON.CONTACTS'
2930 include 'COMMON.TORSION'
2931 include 'COMMON.VECTORS'
2932 include 'COMMON.FFIELD'
2933 double precision auxvec(2),auxmat(2,2)
2935 C Compute the virtual-bond-torsional-angle dependent quantities needed
2936 C to calculate the el-loc multibody terms of various order.
2938 c write(iout,*) 'nphi=',nphi,nres
2940 do i=ivec_start+2,ivec_end+2
2945 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2946 iti = itype2loc(itype(i-2))
2950 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2951 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2952 iti1 = itype2loc(itype(i-1))
2957 b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2958 & +bnew1(2,1,iti)*dsin(theta(i-1))
2959 & +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2960 gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2961 & +bnew1(2,1,iti)*dcos(theta(i-1))
2962 & -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2963 c & +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2964 c &*(cos(theta(i)/2.0)
2965 b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2966 & +bnew2(2,1,iti)*dsin(theta(i-1))
2967 & +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2968 c & +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2969 c &*(cos(theta(i)/2.0)
2970 gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2971 & +bnew2(2,1,iti)*dcos(theta(i-1))
2972 & -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2973 c if (ggb1(1,i).eq.0.0d0) then
2974 c write(iout,*) 'i=',i,ggb1(1,i),
2975 c &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2976 c &bnew1(2,1,iti)*cos(theta(i)),
2977 c &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2979 b1(2,i-2)=bnew1(1,2,iti)
2981 b2(2,i-2)=bnew2(1,2,iti)
2983 EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2984 EE(1,2,i-2)=eeold(1,2,iti)
2985 EE(2,1,i-2)=eeold(2,1,iti)
2986 EE(2,2,i-2)=eeold(2,2,iti)
2987 gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2992 c EE(1,2,iti)=0.5d0*eenew(1,iti)
2993 c EE(2,1,iti)=0.5d0*eenew(1,iti)
2994 c b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2995 c b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2996 b1tilde(1,i-2)=b1(1,i-2)
2997 b1tilde(2,i-2)=-b1(2,i-2)
2998 b2tilde(1,i-2)=b2(1,i-2)
2999 b2tilde(2,i-2)=-b2(2,i-2)
3000 c write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3001 c write(iout,*) 'b1=',b1(1,i-2)
3002 c write (iout,*) 'theta=', theta(i-1)
3005 if (i.gt. nnt+2 .and. i.lt.nct+2) then
3006 iti = itype2loc(itype(i-2))
3010 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3011 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3012 iti1 = itype2loc(itype(i-1))
3020 b1tilde(1,i-2)=b1(1,i-2)
3021 b1tilde(2,i-2)=-b1(2,i-2)
3022 b2tilde(1,i-2)=b2(1,i-2)
3023 b2tilde(2,i-2)=-b2(2,i-2)
3024 EE(1,2,i-2)=eeold(1,2,iti)
3025 EE(2,1,i-2)=eeold(2,1,iti)
3026 EE(2,2,i-2)=eeold(2,2,iti)
3027 EE(1,1,i-2)=eeold(1,1,iti)
3031 do i=ivec_start+2,ivec_end+2
3035 if (i .lt. nres+1) then
3072 if (i .gt. 3 .and. i .lt. nres+1) then
3073 obrot_der(1,i-2)=-sin1
3074 obrot_der(2,i-2)= cos1
3075 Ugder(1,1,i-2)= sin1
3076 Ugder(1,2,i-2)=-cos1
3077 Ugder(2,1,i-2)=-cos1
3078 Ugder(2,2,i-2)=-sin1
3081 obrot2_der(1,i-2)=-dwasin2
3082 obrot2_der(2,i-2)= dwacos2
3083 Ug2der(1,1,i-2)= dwasin2
3084 Ug2der(1,2,i-2)=-dwacos2
3085 Ug2der(2,1,i-2)=-dwacos2
3086 Ug2der(2,2,i-2)=-dwasin2
3088 obrot_der(1,i-2)=0.0d0
3089 obrot_der(2,i-2)=0.0d0
3090 Ugder(1,1,i-2)=0.0d0
3091 Ugder(1,2,i-2)=0.0d0
3092 Ugder(2,1,i-2)=0.0d0
3093 Ugder(2,2,i-2)=0.0d0
3094 obrot2_der(1,i-2)=0.0d0
3095 obrot2_der(2,i-2)=0.0d0
3096 Ug2der(1,1,i-2)=0.0d0
3097 Ug2der(1,2,i-2)=0.0d0
3098 Ug2der(2,1,i-2)=0.0d0
3099 Ug2der(2,2,i-2)=0.0d0
3101 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3102 if (i.gt. nnt+2 .and. i.lt.nct+2) then
3103 iti = itype2loc(itype(i-2))
3107 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3108 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3109 iti1 = itype2loc(itype(i-1))
3113 cd write (iout,*) '*******i',i,' iti1',iti
3114 cd write (iout,*) 'b1',b1(:,iti)
3115 cd write (iout,*) 'b2',b2(:,iti)
3116 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3117 c if (i .gt. iatel_s+2) then
3118 if (i .gt. nnt+2) then
3119 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3121 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3122 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3124 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3125 c & EE(1,2,iti),EE(2,2,i)
3126 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3127 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3128 c write(iout,*) "Macierz EUG",
3129 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3131 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3133 call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3134 call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3135 call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3136 call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3137 call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3148 DtUg2(l,k,i-2)=0.0d0
3152 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3153 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3155 muder(k,i-2)=Ub2der(k,i-2)
3157 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3158 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3159 if (itype(i-1).le.ntyp) then
3160 iti1 = itype2loc(itype(i-1))
3168 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3171 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3172 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3173 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3174 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3175 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3176 & ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3178 cd write (iout,*) 'mu1',mu1(:,i-2)
3179 cd write (iout,*) 'mu2',mu2(:,i-2)
3180 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3182 call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3183 call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3184 call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3185 call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3186 call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3187 C Vectors and matrices dependent on a single virtual-bond dihedral.
3188 call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3189 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3190 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3191 call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3192 call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3193 call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3194 call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3195 call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3196 call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3199 C Matrices dependent on two consecutive virtual-bond dihedrals.
3200 C The order of matrices is from left to right.
3201 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3203 c do i=max0(ivec_start,2),ivec_end
3205 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3206 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3207 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3208 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3209 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3210 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3211 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3212 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3215 #if defined(MPI) && defined(PARMAT)
3217 c if (fg_rank.eq.0) then
3218 write (iout,*) "Arrays UG and UGDER before GATHER"
3220 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3221 & ((ug(l,k,i),l=1,2),k=1,2),
3222 & ((ugder(l,k,i),l=1,2),k=1,2)
3224 write (iout,*) "Arrays UG2 and UG2DER"
3226 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3227 & ((ug2(l,k,i),l=1,2),k=1,2),
3228 & ((ug2der(l,k,i),l=1,2),k=1,2)
3230 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3232 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3233 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3234 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3236 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3238 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3239 & costab(i),sintab(i),costab2(i),sintab2(i)
3241 write (iout,*) "Array MUDER"
3243 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3247 if (nfgtasks.gt.1) then
3249 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3250 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3251 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3253 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3254 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3256 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3257 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3259 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3260 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3262 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3263 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3265 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3266 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3268 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3269 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3271 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3272 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3273 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3274 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3275 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3276 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3277 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3278 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3279 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3280 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3281 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3282 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3283 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3285 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3286 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3288 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3289 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3291 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3292 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3294 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3295 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3297 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3298 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3300 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3301 & ivec_count(fg_rank1),
3302 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3304 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3305 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3307 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3308 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3310 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3311 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3313 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3314 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3316 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3317 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3319 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3320 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3322 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3323 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3325 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3326 & ivec_count(fg_rank1),
3327 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3329 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3330 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3332 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3333 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3335 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3336 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3338 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3339 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3341 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3342 & ivec_count(fg_rank1),
3343 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3345 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3346 & ivec_count(fg_rank1),
3347 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3349 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3350 & ivec_count(fg_rank1),
3351 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3352 & MPI_MAT2,FG_COMM1,IERR)
3353 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3354 & ivec_count(fg_rank1),
3355 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3356 & MPI_MAT2,FG_COMM1,IERR)
3359 c Passes matrix info through the ring
3362 if (irecv.lt.0) irecv=nfgtasks1-1
3365 if (inext.ge.nfgtasks1) inext=0
3367 c write (iout,*) "isend",isend," irecv",irecv
3369 lensend=lentyp(isend)
3370 lenrecv=lentyp(irecv)
3371 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3372 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3373 c & MPI_ROTAT1(lensend),inext,2200+isend,
3374 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3375 c & iprev,2200+irecv,FG_COMM,status,IERR)
3376 c write (iout,*) "Gather ROTAT1"
3378 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3379 c & MPI_ROTAT2(lensend),inext,3300+isend,
3380 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3381 c & iprev,3300+irecv,FG_COMM,status,IERR)
3382 c write (iout,*) "Gather ROTAT2"
3384 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3385 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3386 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3387 & iprev,4400+irecv,FG_COMM,status,IERR)
3388 c write (iout,*) "Gather ROTAT_OLD"
3390 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3391 & MPI_PRECOMP11(lensend),inext,5500+isend,
3392 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3393 & iprev,5500+irecv,FG_COMM,status,IERR)
3394 c write (iout,*) "Gather PRECOMP11"
3396 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3397 & MPI_PRECOMP12(lensend),inext,6600+isend,
3398 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3399 & iprev,6600+irecv,FG_COMM,status,IERR)
3400 c write (iout,*) "Gather PRECOMP12"
3402 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3404 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3405 & MPI_ROTAT2(lensend),inext,7700+isend,
3406 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3407 & iprev,7700+irecv,FG_COMM,status,IERR)
3408 c write (iout,*) "Gather PRECOMP21"
3410 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3411 & MPI_PRECOMP22(lensend),inext,8800+isend,
3412 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3413 & iprev,8800+irecv,FG_COMM,status,IERR)
3414 c write (iout,*) "Gather PRECOMP22"
3416 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3417 & MPI_PRECOMP23(lensend),inext,9900+isend,
3418 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3419 & MPI_PRECOMP23(lenrecv),
3420 & iprev,9900+irecv,FG_COMM,status,IERR)
3421 c write (iout,*) "Gather PRECOMP23"
3426 if (irecv.lt.0) irecv=nfgtasks1-1
3429 time_gather=time_gather+MPI_Wtime()-time00
3432 c if (fg_rank.eq.0) then
3433 write (iout,*) "Arrays UG and UGDER"
3435 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3436 & ((ug(l,k,i),l=1,2),k=1,2),
3437 & ((ugder(l,k,i),l=1,2),k=1,2)
3439 write (iout,*) "Arrays UG2 and UG2DER"
3441 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3442 & ((ug2(l,k,i),l=1,2),k=1,2),
3443 & ((ug2der(l,k,i),l=1,2),k=1,2)
3445 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3447 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3448 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3449 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3451 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3453 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3454 & costab(i),sintab(i),costab2(i),sintab2(i)
3456 write (iout,*) "Array MUDER"
3458 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3464 cd iti = itype2loc(itype(i))
3467 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3468 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3473 C--------------------------------------------------------------------------
3474 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3476 C This subroutine calculates the average interaction energy and its gradient
3477 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3478 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3479 C The potential depends both on the distance of peptide-group centers and on
3480 C the orientation of the CA-CA virtual bonds.
3482 implicit real*8 (a-h,o-z)
3486 include 'DIMENSIONS'
3487 include 'COMMON.CONTROL'
3488 include 'COMMON.SETUP'
3489 include 'COMMON.IOUNITS'
3490 include 'COMMON.GEO'
3491 include 'COMMON.VAR'
3492 include 'COMMON.LOCAL'
3493 include 'COMMON.CHAIN'
3494 include 'COMMON.DERIV'
3495 include 'COMMON.INTERACT'
3496 include 'COMMON.CONTACTS'
3497 include 'COMMON.TORSION'
3498 include 'COMMON.VECTORS'
3499 include 'COMMON.FFIELD'
3500 include 'COMMON.TIME1'
3501 include 'COMMON.SPLITELE'
3502 include 'COMMON.SHIELD'
3503 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3504 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3505 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3506 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3507 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3508 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3510 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3512 double precision scal_el /1.0d0/
3514 double precision scal_el /0.5d0/
3517 C 13-go grudnia roku pamietnego...
3518 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3519 & 0.0d0,1.0d0,0.0d0,
3520 & 0.0d0,0.0d0,1.0d0/
3521 cd write(iout,*) 'In EELEC'
3523 cd write(iout,*) 'Type',i
3524 cd write(iout,*) 'B1',B1(:,i)
3525 cd write(iout,*) 'B2',B2(:,i)
3526 cd write(iout,*) 'CC',CC(:,:,i)
3527 cd write(iout,*) 'DD',DD(:,:,i)
3528 cd write(iout,*) 'EE',EE(:,:,i)
3530 cd call check_vecgrad
3532 if (icheckgrad.eq.1) then
3534 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3536 dc_norm(k,i)=dc(k,i)*fac
3538 c write (iout,*) 'i',i,' fac',fac
3541 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3542 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3543 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3544 c call vec_and_deriv
3550 time_mat=time_mat+MPI_Wtime()-time01
3554 cd write (iout,*) 'i=',i
3556 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3559 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3560 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3573 cd print '(a)','Enter EELEC'
3574 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3576 gel_loc_loc(i)=0.0d0
3581 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3583 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3585 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3586 do i=iturn3_start,iturn3_end
3588 C write(iout,*) "tu jest i",i
3589 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3590 C changes suggested by Ana to avoid out of bounds
3591 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3592 c & .or.((i+4).gt.nres)
3593 c & .or.((i-1).le.0)
3594 C end of changes by Ana
3595 & .or. itype(i+2).eq.ntyp1
3596 & .or. itype(i+3).eq.ntyp1) cycle
3597 C Adam: Instructions below will switch off existing interactions
3599 c if(itype(i-1).eq.ntyp1)cycle
3601 c if(i.LT.nres-3)then
3602 c if (itype(i+4).eq.ntyp1) cycle
3607 dx_normi=dc_norm(1,i)
3608 dy_normi=dc_norm(2,i)
3609 dz_normi=dc_norm(3,i)
3610 xmedi=c(1,i)+0.5d0*dxi
3611 ymedi=c(2,i)+0.5d0*dyi
3612 zmedi=c(3,i)+0.5d0*dzi
3613 xmedi=mod(xmedi,boxxsize)
3614 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3615 ymedi=mod(ymedi,boxysize)
3616 if (ymedi.lt.0) ymedi=ymedi+boxysize
3617 zmedi=mod(zmedi,boxzsize)
3618 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3619 zmedi2=mod(zmedi,boxzsize)
3620 if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3621 if ((zmedi2.gt.bordlipbot)
3622 &.and.(zmedi2.lt.bordliptop)) then
3623 C the energy transfer exist
3624 if (zmedi2.lt.buflipbot) then
3625 C what fraction I am in
3627 & ((zmedi2-bordlipbot)/lipbufthick)
3628 C lipbufthick is thickenes of lipid buffore
3629 sslipi=sscalelip(fracinbuf)
3630 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3631 elseif (zmedi2.gt.bufliptop) then
3632 fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3633 sslipi=sscalelip(fracinbuf)
3634 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3644 call eelecij(i,i+2,ees,evdw1,eel_loc)
3645 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3646 num_cont_hb(i)=num_conti
3648 do i=iturn4_start,iturn4_end
3650 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3651 C changes suggested by Ana to avoid out of bounds
3652 c & .or.((i+5).gt.nres)
3653 c & .or.((i-1).le.0)
3654 C end of changes suggested by Ana
3655 & .or. itype(i+3).eq.ntyp1
3656 & .or. itype(i+4).eq.ntyp1
3657 c & .or. itype(i+5).eq.ntyp1
3658 c & .or. itype(i).eq.ntyp1
3659 c & .or. itype(i-1).eq.ntyp1
3664 dx_normi=dc_norm(1,i)
3665 dy_normi=dc_norm(2,i)
3666 dz_normi=dc_norm(3,i)
3667 xmedi=c(1,i)+0.5d0*dxi
3668 ymedi=c(2,i)+0.5d0*dyi
3669 zmedi=c(3,i)+0.5d0*dzi
3670 C Return atom into box, boxxsize is size of box in x dimension
3672 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3673 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3674 C Condition for being inside the proper box
3675 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3676 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3680 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3681 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3682 C Condition for being inside the proper box
3683 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3684 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3688 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3689 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3690 C Condition for being inside the proper box
3691 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3692 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3695 xmedi=mod(xmedi,boxxsize)
3696 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3697 ymedi=mod(ymedi,boxysize)
3698 if (ymedi.lt.0) ymedi=ymedi+boxysize
3699 zmedi=mod(zmedi,boxzsize)
3700 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3701 zmedi2=mod(zmedi,boxzsize)
3702 if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3703 if ((zmedi2.gt.bordlipbot)
3704 &.and.(zmedi2.lt.bordliptop)) then
3705 C the energy transfer exist
3706 if (zmedi2.lt.buflipbot) then
3707 C what fraction I am in
3709 & ((zmedi2-bordlipbot)/lipbufthick)
3710 C lipbufthick is thickenes of lipid buffore
3711 sslipi=sscalelip(fracinbuf)
3712 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3713 elseif (zmedi2.gt.bufliptop) then
3714 fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3715 sslipi=sscalelip(fracinbuf)
3716 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3725 num_conti=num_cont_hb(i)
3726 c write(iout,*) "JESTEM W PETLI"
3727 call eelecij(i,i+3,ees,evdw1,eel_loc)
3728 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3729 & call eturn4(i,eello_turn4)
3730 num_cont_hb(i)=num_conti
3732 C Loop over all neighbouring boxes
3737 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3740 do i=iatel_s,iatel_e
3743 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3744 C changes suggested by Ana to avoid out of bounds
3745 c & .or.((i+2).gt.nres)
3746 c & .or.((i-1).le.0)
3747 C end of changes by Ana
3748 c & .or. itype(i+2).eq.ntyp1
3749 c & .or. itype(i-1).eq.ntyp1
3754 dx_normi=dc_norm(1,i)
3755 dy_normi=dc_norm(2,i)
3756 dz_normi=dc_norm(3,i)
3757 xmedi=c(1,i)+0.5d0*dxi
3758 ymedi=c(2,i)+0.5d0*dyi
3759 zmedi=c(3,i)+0.5d0*dzi
3760 xmedi=mod(xmedi,boxxsize)
3761 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3762 ymedi=mod(ymedi,boxysize)
3763 if (ymedi.lt.0) ymedi=ymedi+boxysize
3764 zmedi=mod(zmedi,boxzsize)
3765 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3766 if ((zmedi.gt.bordlipbot)
3767 &.and.(zmedi.lt.bordliptop)) then
3768 C the energy transfer exist
3769 if (zmedi.lt.buflipbot) then
3770 C what fraction I am in
3772 & ((zmedi-bordlipbot)/lipbufthick)
3773 C lipbufthick is thickenes of lipid buffore
3774 sslipi=sscalelip(fracinbuf)
3775 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3776 elseif (zmedi.gt.bufliptop) then
3777 fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3778 sslipi=sscalelip(fracinbuf)
3779 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3788 C print *,sslipi,"TU?!"
3789 C xmedi=xmedi+xshift*boxxsize
3790 C ymedi=ymedi+yshift*boxysize
3791 C zmedi=zmedi+zshift*boxzsize
3793 C Return tom into box, boxxsize is size of box in x dimension
3795 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3796 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3797 C Condition for being inside the proper box
3798 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3799 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3803 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3804 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3805 C Condition for being inside the proper box
3806 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3807 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3811 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3812 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3813 cC Condition for being inside the proper box
3814 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3815 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3819 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3820 num_conti=num_cont_hb(i)
3822 do j=ielstart(i),ielend(i)
3824 C write (iout,*) i,j
3826 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3827 C changes suggested by Ana to avoid out of bounds
3828 c & .or.((j+2).gt.nres)
3829 c & .or.((j-1).le.0)
3830 C end of changes by Ana
3831 c & .or.itype(j+2).eq.ntyp1
3832 c & .or.itype(j-1).eq.ntyp1
3834 call eelecij(i,j,ees,evdw1,eel_loc)
3836 num_cont_hb(i)=num_conti
3842 c write (iout,*) "Number of loop steps in EELEC:",ind
3844 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3845 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3847 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3848 ccc eel_loc=eel_loc+eello_turn3
3849 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3852 C-------------------------------------------------------------------------------
3853 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3854 implicit real*8 (a-h,o-z)
3855 include 'DIMENSIONS'
3859 include 'COMMON.CONTROL'
3860 include 'COMMON.IOUNITS'
3861 include 'COMMON.GEO'
3862 include 'COMMON.VAR'
3863 include 'COMMON.LOCAL'
3864 include 'COMMON.CHAIN'
3865 include 'COMMON.DERIV'
3866 include 'COMMON.INTERACT'
3867 include 'COMMON.CONTACTS'
3868 include 'COMMON.TORSION'
3869 include 'COMMON.VECTORS'
3870 include 'COMMON.FFIELD'
3871 include 'COMMON.TIME1'
3872 include 'COMMON.SPLITELE'
3873 include 'COMMON.SHIELD'
3874 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3875 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3876 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3877 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3878 & gmuij2(4),gmuji2(4)
3879 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3880 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3882 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3884 double precision scal_el /1.0d0/
3886 double precision scal_el /0.5d0/
3889 C 13-go grudnia roku pamietnego...
3890 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3891 & 0.0d0,1.0d0,0.0d0,
3892 & 0.0d0,0.0d0,1.0d0/
3893 integer xshift,yshift,zshift
3894 c time00=MPI_Wtime()
3895 cd write (iout,*) "eelecij",i,j
3899 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3900 aaa=app(iteli,itelj)
3901 bbb=bpp(iteli,itelj)
3902 ael6i=ael6(iteli,itelj)
3903 ael3i=ael3(iteli,itelj)
3907 dx_normj=dc_norm(1,j)
3908 dy_normj=dc_norm(2,j)
3909 dz_normj=dc_norm(3,j)
3910 C xj=c(1,j)+0.5D0*dxj-xmedi
3911 C yj=c(2,j)+0.5D0*dyj-ymedi
3912 C zj=c(3,j)+0.5D0*dzj-zmedi
3917 if (xj.lt.0) xj=xj+boxxsize
3919 if (yj.lt.0) yj=yj+boxysize
3921 if (zj.lt.0) zj=zj+boxzsize
3922 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3923 if ((zj.gt.bordlipbot)
3924 &.and.(zj.lt.bordliptop)) then
3925 C the energy transfer exist
3926 if (zj.lt.buflipbot) then
3927 C what fraction I am in
3929 & ((zj-bordlipbot)/lipbufthick)
3930 C lipbufthick is thickenes of lipid buffore
3931 sslipj=sscalelip(fracinbuf)
3932 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3933 elseif (zj.gt.bufliptop) then
3934 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3935 sslipj=sscalelip(fracinbuf)
3936 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3945 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3953 xj=xj_safe+xshift*boxxsize
3954 yj=yj_safe+yshift*boxysize
3955 zj=zj_safe+zshift*boxzsize
3956 dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3957 if(dist_temp.lt.dist_init) then
3967 if (isubchap.eq.1) then
3976 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3978 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3979 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3980 C Condition for being inside the proper box
3981 c if ((xj.gt.((0.5d0)*boxxsize)).or.
3982 c & (xj.lt.((-0.5d0)*boxxsize))) then
3986 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3987 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3988 C Condition for being inside the proper box
3989 c if ((yj.gt.((0.5d0)*boxysize)).or.
3990 c & (yj.lt.((-0.5d0)*boxysize))) then
3994 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3995 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3996 C Condition for being inside the proper box
3997 c if ((zj.gt.((0.5d0)*boxzsize)).or.
3998 c & (zj.lt.((-0.5d0)*boxzsize))) then
4001 C endif !endPBC condintion
4005 rij=xj*xj+yj*yj+zj*zj
4007 sss=sscale(sqrt(rij))
4008 sssgrad=sscagrad(sqrt(rij))
4009 c if (sss.gt.0.0d0) then
4015 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
4016 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
4017 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
4018 fac=cosa-3.0D0*cosb*cosg
4020 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
4021 if (j.eq.i+2) ev1=scal_el*ev1
4026 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
4030 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
4031 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
4032 if (shield_mode.gt.0) then
4035 el1=el1*fac_shield(i)**2*fac_shield(j)**2
4036 el2=el2*fac_shield(i)**2*fac_shield(j)**2
4039 C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
4040 C & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4046 &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4047 C print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
4049 evdw1=evdw1+evdwij*sss
4050 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4051 C print *,sslipi,sslipj,lipscale**2,
4052 C & (sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
4053 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
4054 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
4055 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
4056 cd & xmedi,ymedi,zmedi,xj,yj,zj
4058 if (energy_dec) then
4059 write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
4061 &,iteli,itelj,aaa,evdw1
4063 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4064 &fac_shield(i),fac_shield(j)
4068 C Calculate contributions to the Cartesian gradient.
4071 facvdw=-6*rrmij*(ev1+evdwij)*sss
4072 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4073 facel=-3*rrmij*(el1+eesij)
4074 &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4081 * Radial derivatives. First process both termini of the fragment (i,j)
4086 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4087 & (shield_mode.gt.0)) then
4089 do ilist=1,ishield_list(i)
4090 iresshield=shield_list(ilist,i)
4092 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4094 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4096 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4097 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4098 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4099 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4100 C if (iresshield.gt.i) then
4101 C do ishi=i+1,iresshield-1
4102 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4103 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4107 C do ishi=iresshield,i
4108 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4109 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4115 do ilist=1,ishield_list(j)
4116 iresshield=shield_list(ilist,j)
4118 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4120 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4122 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4123 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4125 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4126 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4127 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4128 C if (iresshield.gt.j) then
4129 C do ishi=j+1,iresshield-1
4130 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4131 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4135 C do ishi=iresshield,j
4136 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4137 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4144 gshieldc(k,i)=gshieldc(k,i)+
4145 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4146 gshieldc(k,j)=gshieldc(k,j)+
4147 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4148 gshieldc(k,i-1)=gshieldc(k,i-1)+
4149 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4150 gshieldc(k,j-1)=gshieldc(k,j-1)+
4151 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4156 c ghalf=0.5D0*ggg(k)
4157 c gelc(k,i)=gelc(k,i)+ghalf
4158 c gelc(k,j)=gelc(k,j)+ghalf
4160 c 9/28/08 AL Gradient compotents will be summed only at the end
4161 C print *,"before", gelc_long(1,i), gelc_long(1,j)
4163 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4164 C & +grad_shield(k,j)*eesij/fac_shield(j)
4165 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4166 C & +grad_shield(k,i)*eesij/fac_shield(i)
4167 C gelc_long(k,i-1)=gelc_long(k,i-1)
4168 C & +grad_shield(k,i)*eesij/fac_shield(i)
4169 C gelc_long(k,j-1)=gelc_long(k,j-1)
4170 C & +grad_shield(k,j)*eesij/fac_shield(j)
4172 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4173 C Lipidic part for lipscale
4174 gelc_long(3,j)=gelc_long(3,j)+
4175 & ssgradlipj*eesij/2.0d0*lipscale**2
4177 gelc_long(3,i)=gelc_long(3,i)+
4178 & ssgradlipi*eesij/2.0d0*lipscale**2
4181 * Loop over residues i+1 thru j-1.
4185 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4188 if (sss.gt.0.0) then
4189 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4190 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4192 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4193 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4195 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4196 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4203 c ghalf=0.5D0*ggg(k)
4204 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4205 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4207 c 9/28/08 AL Gradient compotents will be summed only at the end
4209 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4210 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4212 C Lipidic part for scaling weight
4213 gvdwpp(3,j)=gvdwpp(3,j)+
4214 & sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4215 gvdwpp(3,i)=gvdwpp(3,i)+
4216 & sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4219 * Loop over residues i+1 thru j-1.
4223 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4228 facvdw=(ev1+evdwij)*sss
4229 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4232 fac=-3*rrmij*(facvdw+facvdw+facel)
4237 * Radial derivatives. First process both termini of the fragment (i,j)
4240 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4242 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4244 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4246 c ghalf=0.5D0*ggg(k)
4247 c gelc(k,i)=gelc(k,i)+ghalf
4248 c gelc(k,j)=gelc(k,j)+ghalf
4250 c 9/28/08 AL Gradient compotents will be summed only at the end
4252 gelc_long(k,j)=gelc(k,j)+ggg(k)
4253 gelc_long(k,i)=gelc(k,i)-ggg(k)
4256 * Loop over residues i+1 thru j-1.
4260 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4263 c 9/28/08 AL Gradient compotents will be summed only at the end
4264 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4265 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4267 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4268 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4270 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4271 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4273 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4274 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4276 gvdwpp(3,j)=gvdwpp(3,j)+
4277 & sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4278 gvdwpp(3,i)=gvdwpp(3,i)+
4279 & sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4285 ecosa=2.0D0*fac3*fac1+fac4
4288 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4289 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4291 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4292 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4294 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4295 cd & (dcosg(k),k=1,3)
4297 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4298 & fac_shield(i)**2*fac_shield(j)**2
4299 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4302 c ghalf=0.5D0*ggg(k)
4303 c gelc(k,i)=gelc(k,i)+ghalf
4304 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4305 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4306 c gelc(k,j)=gelc(k,j)+ghalf
4307 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4308 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4312 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4315 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4318 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4319 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4320 & *fac_shield(i)**2*fac_shield(j)**2
4321 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4323 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4324 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4325 & *fac_shield(i)**2*fac_shield(j)**2
4326 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4327 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4328 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4330 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4334 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4335 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4336 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4338 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4339 C energy of a peptide unit is assumed in the form of a second-order
4340 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4341 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4342 C are computed for EVERY pair of non-contiguous peptide groups.
4345 if (j.lt.nres-1) then
4357 muij(kkk)=mu(k,i)*mu(l,j)
4358 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4360 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4361 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4362 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4363 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4364 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4365 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4369 cd write (iout,*) 'EELEC: i',i,' j',j
4370 cd write (iout,*) 'j',j,' j1',j1,' j2',j2
4371 cd write(iout,*) 'muij',muij
4372 ury=scalar(uy(1,i),erij)
4373 urz=scalar(uz(1,i),erij)
4374 vry=scalar(uy(1,j),erij)
4375 vrz=scalar(uz(1,j),erij)
4376 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4377 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4378 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4379 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4380 fac=dsqrt(-ael6i)*r3ij
4385 cd write (iout,'(4i5,4f10.5)')
4386 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4387 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4388 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4389 cd & uy(:,j),uz(:,j)
4390 cd write (iout,'(4f10.5)')
4391 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4392 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4393 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4394 cd write (iout,'(9f10.5/)')
4395 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4396 C Derivatives of the elements of A in virtual-bond vectors
4397 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4399 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4400 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4401 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4402 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4403 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4404 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4405 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4406 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4407 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4408 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4409 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4410 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4412 C Compute radial contributions to the gradient
4430 C Add the contributions coming from er
4433 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4434 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4435 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4436 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4439 C Derivatives in DC(i)
4440 cgrad ghalf1=0.5d0*agg(k,1)
4441 cgrad ghalf2=0.5d0*agg(k,2)
4442 cgrad ghalf3=0.5d0*agg(k,3)
4443 cgrad ghalf4=0.5d0*agg(k,4)
4444 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4445 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4446 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4447 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4448 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4449 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4450 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4451 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4452 C Derivatives in DC(i+1)
4453 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4454 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4455 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4456 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4457 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4458 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4459 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4460 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4461 C Derivatives in DC(j)
4462 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4463 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4464 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4465 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4466 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4467 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4468 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4469 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4470 C Derivatives in DC(j+1) or DC(nres-1)
4471 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4472 & -3.0d0*vryg(k,3)*ury)
4473 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4474 & -3.0d0*vrzg(k,3)*ury)
4475 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4476 & -3.0d0*vryg(k,3)*urz)
4477 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4478 & -3.0d0*vrzg(k,3)*urz)
4479 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4481 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4494 aggi(k,l)=-aggi(k,l)
4495 aggi1(k,l)=-aggi1(k,l)
4496 aggj(k,l)=-aggj(k,l)
4497 aggj1(k,l)=-aggj1(k,l)
4500 if (j.lt.nres-1) then
4506 aggi(k,l)=-aggi(k,l)
4507 aggi1(k,l)=-aggi1(k,l)
4508 aggj(k,l)=-aggj(k,l)
4509 aggj1(k,l)=-aggj1(k,l)
4520 aggi(k,l)=-aggi(k,l)
4521 aggi1(k,l)=-aggi1(k,l)
4522 aggj(k,l)=-aggj(k,l)
4523 aggj1(k,l)=-aggj1(k,l)
4528 IF (wel_loc.gt.0.0d0) THEN
4529 C Contribution to the local-electrostatic energy coming from the i-j pair
4530 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4532 if (shield_mode.eq.0) then
4539 eel_loc_ij=eel_loc_ij
4540 & *fac_shield(i)*fac_shield(j)
4541 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4543 C Now derivative over eel_loc
4544 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4545 & (shield_mode.gt.0)) then
4548 do ilist=1,ishield_list(i)
4549 iresshield=shield_list(ilist,i)
4551 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4554 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4556 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4557 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4561 do ilist=1,ishield_list(j)
4562 iresshield=shield_list(ilist,j)
4564 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4567 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4569 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4570 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4577 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4578 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4579 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4580 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4581 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4582 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4583 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4584 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4589 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4590 c & ' eel_loc_ij',eel_loc_ij
4591 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4592 C Calculate patrial derivative for theta angle
4594 geel_loc_ij=(a22*gmuij1(1)
4598 & *fac_shield(i)*fac_shield(j)
4599 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4601 c write(iout,*) "derivative over thatai"
4602 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4604 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4605 & geel_loc_ij*wel_loc
4606 c write(iout,*) "derivative over thatai-1"
4607 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4614 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4615 & geel_loc_ij*wel_loc
4616 & *fac_shield(i)*fac_shield(j)
4617 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4620 c Derivative over j residue
4621 geel_loc_ji=a22*gmuji1(1)
4625 c write(iout,*) "derivative over thataj"
4626 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4629 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4630 & geel_loc_ji*wel_loc
4631 & *fac_shield(i)*fac_shield(j)
4632 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4639 c write(iout,*) "derivative over thataj-1"
4640 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4642 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4643 & geel_loc_ji*wel_loc
4644 & *fac_shield(i)*fac_shield(j)
4645 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4648 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4650 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4651 & 'eelloc',i,j,eel_loc_ij
4652 c if (eel_loc_ij.ne.0)
4653 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4654 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4656 eel_loc=eel_loc+eel_loc_ij
4657 C Partial derivatives in virtual-bond dihedral angles gamma
4659 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4660 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4661 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4662 & *fac_shield(i)*fac_shield(j)
4663 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4665 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4666 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4667 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4668 & *fac_shield(i)*fac_shield(j)
4669 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4671 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4673 ggg(l)=(agg(l,1)*muij(1)+
4674 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4675 & *fac_shield(i)*fac_shield(j)
4676 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4678 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4679 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4680 cgrad ghalf=0.5d0*ggg(l)
4681 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4682 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4684 gel_loc_long(3,j)=gel_loc_long(3,j)+
4685 & ssgradlipj*eel_loc_ij/2.0d0*lipscale/
4686 & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4688 gel_loc_long(3,i)=gel_loc_long(3,i)+
4689 & ssgradlipi*eel_loc_ij/2.0d0*lipscale/
4690 & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4694 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4697 C Remaining derivatives of eello
4699 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4700 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4701 & *fac_shield(i)*fac_shield(j)
4702 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4704 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4705 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4706 & *fac_shield(i)*fac_shield(j)
4707 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4709 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4710 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4711 & *fac_shield(i)*fac_shield(j)
4712 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4714 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4715 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4716 & *fac_shield(i)*fac_shield(j)
4717 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4721 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4722 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4723 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4724 & .and. num_conti.le.maxconts) then
4725 c write (iout,*) i,j," entered corr"
4727 C Calculate the contact function. The ith column of the array JCONT will
4728 C contain the numbers of atoms that make contacts with the atom I (of numbers
4729 C greater than I). The arrays FACONT and GACONT will contain the values of
4730 C the contact function and its derivative.
4731 c r0ij=1.02D0*rpp(iteli,itelj)
4732 c r0ij=1.11D0*rpp(iteli,itelj)
4733 r0ij=2.20D0*rpp(iteli,itelj)
4734 c r0ij=1.55D0*rpp(iteli,itelj)
4735 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4736 if (fcont.gt.0.0D0) then
4737 num_conti=num_conti+1
4738 if (num_conti.gt.maxconts) then
4739 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4740 & ' will skip next contacts for this conf.'
4742 jcont_hb(num_conti,i)=j
4743 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4744 cd & " jcont_hb",jcont_hb(num_conti,i)
4745 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4746 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4747 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4749 d_cont(num_conti,i)=rij
4750 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4751 C --- Electrostatic-interaction matrix ---
4752 a_chuj(1,1,num_conti,i)=a22
4753 a_chuj(1,2,num_conti,i)=a23
4754 a_chuj(2,1,num_conti,i)=a32
4755 a_chuj(2,2,num_conti,i)=a33
4756 C --- Gradient of rij
4758 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4765 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4766 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4767 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4768 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4769 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4774 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4775 C Calculate contact energies
4777 wij=cosa-3.0D0*cosb*cosg
4780 c fac3=dsqrt(-ael6i)/r0ij**3
4781 fac3=dsqrt(-ael6i)*r3ij
4782 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4783 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4784 if (ees0tmp.gt.0) then
4785 ees0pij=dsqrt(ees0tmp)
4789 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4790 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4791 if (ees0tmp.gt.0) then
4792 ees0mij=dsqrt(ees0tmp)
4797 if (shield_mode.eq.0) then
4801 ees0plist(num_conti,i)=j
4802 C fac_shield(i)=0.4d0
4803 C fac_shield(j)=0.6d0
4805 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4806 & *fac_shield(i)*fac_shield(j)
4807 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4808 & *fac_shield(i)*fac_shield(j)
4809 C Diagnostics. Comment out or remove after debugging!
4810 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4811 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4812 c ees0m(num_conti,i)=0.0D0
4814 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4815 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4816 C Angular derivatives of the contact function
4817 ees0pij1=fac3/ees0pij
4818 ees0mij1=fac3/ees0mij
4819 fac3p=-3.0D0*fac3*rrmij
4820 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4821 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4823 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4824 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4825 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4826 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4827 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4828 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4829 ecosap=ecosa1+ecosa2
4830 ecosbp=ecosb1+ecosb2
4831 ecosgp=ecosg1+ecosg2
4832 ecosam=ecosa1-ecosa2
4833 ecosbm=ecosb1-ecosb2
4834 ecosgm=ecosg1-ecosg2
4843 facont_hb(num_conti,i)=fcont
4844 fprimcont=fprimcont/rij
4845 cd facont_hb(num_conti,i)=1.0D0
4846 C Following line is for diagnostics.
4849 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4850 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4853 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4854 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4856 gggp(1)=gggp(1)+ees0pijp*xj
4857 gggp(2)=gggp(2)+ees0pijp*yj
4858 gggp(3)=gggp(3)+ees0pijp*zj
4859 gggm(1)=gggm(1)+ees0mijp*xj
4860 gggm(2)=gggm(2)+ees0mijp*yj
4861 gggm(3)=gggm(3)+ees0mijp*zj
4862 C Derivatives due to the contact function
4863 gacont_hbr(1,num_conti,i)=fprimcont*xj
4864 gacont_hbr(2,num_conti,i)=fprimcont*yj
4865 gacont_hbr(3,num_conti,i)=fprimcont*zj
4868 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4869 c following the change of gradient-summation algorithm.
4871 cgrad ghalfp=0.5D0*gggp(k)
4872 cgrad ghalfm=0.5D0*gggm(k)
4873 gacontp_hb1(k,num_conti,i)=!ghalfp
4874 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4875 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4876 & *fac_shield(i)*fac_shield(j)
4878 gacontp_hb2(k,num_conti,i)=!ghalfp
4879 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4880 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4881 & *fac_shield(i)*fac_shield(j)
4883 gacontp_hb3(k,num_conti,i)=gggp(k)
4884 & *fac_shield(i)*fac_shield(j)
4886 gacontm_hb1(k,num_conti,i)=!ghalfm
4887 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4888 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4889 & *fac_shield(i)*fac_shield(j)
4891 gacontm_hb2(k,num_conti,i)=!ghalfm
4892 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4893 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4894 & *fac_shield(i)*fac_shield(j)
4896 gacontm_hb3(k,num_conti,i)=gggm(k)
4897 & *fac_shield(i)*fac_shield(j)
4900 C Diagnostics. Comment out or remove after debugging!
4902 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4903 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4904 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4905 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4906 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4907 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4910 endif ! num_conti.le.maxconts
4913 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4916 ghalf=0.5d0*agg(l,k)
4917 aggi(l,k)=aggi(l,k)+ghalf
4918 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4919 aggj(l,k)=aggj(l,k)+ghalf
4922 if (j.eq.nres-1 .and. i.lt.j-2) then
4925 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4930 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4933 C-----------------------------------------------------------------------------
4934 subroutine eturn3(i,eello_turn3)
4935 C Third- and fourth-order contributions from turns
4936 implicit real*8 (a-h,o-z)
4937 include 'DIMENSIONS'
4938 include 'COMMON.IOUNITS'
4939 include 'COMMON.GEO'
4940 include 'COMMON.VAR'
4941 include 'COMMON.LOCAL'
4942 include 'COMMON.CHAIN'
4943 include 'COMMON.DERIV'
4944 include 'COMMON.INTERACT'
4945 include 'COMMON.CONTACTS'
4946 include 'COMMON.TORSION'
4947 include 'COMMON.VECTORS'
4948 include 'COMMON.FFIELD'
4949 include 'COMMON.CONTROL'
4950 include 'COMMON.SHIELD'
4952 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4953 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4954 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4955 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4956 & auxgmat2(2,2),auxgmatt2(2,2)
4957 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4958 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4959 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4960 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4963 C xj=(c(1,j)+c(1,j+1))/2.0d0
4964 C yj=(c(2,j)+c(2,j+1))/2.0d0
4965 zj=(c(3,j)+c(3,j+1))/2.0d0
4966 C xj=mod(xj,boxxsize)
4967 C if (xj.lt.0) xj=xj+boxxsize
4968 C yj=mod(yj,boxysize)
4969 C if (yj.lt.0) yj=yj+boxysize
4971 if (zj.lt.0) zj=zj+boxzsize
4972 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4973 if ((zj.gt.bordlipbot)
4974 &.and.(zj.lt.bordliptop)) then
4975 C the energy transfer exist
4976 if (zj.lt.buflipbot) then
4977 C what fraction I am in
4979 & ((zj-bordlipbot)/lipbufthick)
4980 C lipbufthick is thickenes of lipid buffore
4981 sslipj=sscalelip(fracinbuf)
4982 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4983 elseif (zj.gt.bufliptop) then
4984 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4985 sslipj=sscalelip(fracinbuf)
4986 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4998 C write (iout,*) "eturn3",i,j,j1,j2
5003 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5005 C Third-order contributions
5012 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5013 cd call checkint_turn3(i,a_temp,eello_turn3_num)
5014 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
5015 c auxalary matices for theta gradient
5016 c auxalary matrix for i+1 and constant i+2
5017 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
5018 c auxalary matrix for i+2 and constant i+1
5019 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
5020 call transpose2(auxmat(1,1),auxmat1(1,1))
5021 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
5022 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
5023 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5024 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
5025 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
5026 if (shield_mode.eq.0) then
5034 C & write(iout,*) i,j,fac_shield(i),fac_shield(j)
5035 eello_turn3=eello_turn3+
5036 C & 1.0*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5037 &0.5d0*(pizda(1,1)+pizda(2,2))
5038 & *fac_shield(i)*fac_shield(j)
5039 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5041 &0.5d0*(pizda(1,1)+pizda(2,2))
5042 & *fac_shield(i)*fac_shield(j)
5044 C Derivatives in theta
5045 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5046 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
5047 & *fac_shield(i)*fac_shield(j)
5048 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5050 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
5051 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
5052 & *fac_shield(i)*fac_shield(j)
5053 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5057 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5058 C Derivatives in shield mode
5059 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5060 & (shield_mode.gt.0)) then
5063 do ilist=1,ishield_list(i)
5064 iresshield=shield_list(ilist,i)
5066 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5068 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5070 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5071 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5075 do ilist=1,ishield_list(j)
5076 iresshield=shield_list(ilist,j)
5078 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5080 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5082 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5083 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5090 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5091 & grad_shield(k,i)*eello_t3/fac_shield(i)
5092 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5093 & grad_shield(k,j)*eello_t3/fac_shield(j)
5094 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5095 & grad_shield(k,i)*eello_t3/fac_shield(i)
5096 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5097 & grad_shield(k,j)*eello_t3/fac_shield(j)
5101 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5102 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
5103 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
5104 cd & ' eello_turn3_num',4*eello_turn3_num
5105 C Derivatives in gamma(i)
5106 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5107 call transpose2(auxmat2(1,1),auxmat3(1,1))
5108 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5109 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5110 & *fac_shield(i)*fac_shield(j)
5111 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5113 C Derivatives in gamma(i+1)
5114 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5115 call transpose2(auxmat2(1,1),auxmat3(1,1))
5116 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5117 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5118 & +0.5d0*(pizda(1,1)+pizda(2,2))
5119 & *fac_shield(i)*fac_shield(j)
5120 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5122 C Cartesian derivatives
5124 c ghalf1=0.5d0*agg(l,1)
5125 c ghalf2=0.5d0*agg(l,2)
5126 c ghalf3=0.5d0*agg(l,3)
5127 c ghalf4=0.5d0*agg(l,4)
5128 a_temp(1,1)=aggi(l,1)!+ghalf1
5129 a_temp(1,2)=aggi(l,2)!+ghalf2
5130 a_temp(2,1)=aggi(l,3)!+ghalf3
5131 a_temp(2,2)=aggi(l,4)!+ghalf4
5132 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5133 gcorr3_turn(l,i)=gcorr3_turn(l,i)
5134 & +0.5d0*(pizda(1,1)+pizda(2,2))
5135 & *fac_shield(i)*fac_shield(j)
5136 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5138 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5139 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5140 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5141 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5142 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5143 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5144 & +0.5d0*(pizda(1,1)+pizda(2,2))
5145 & *fac_shield(i)*fac_shield(j)
5146 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5147 a_temp(1,1)=aggj(l,1)!+ghalf1
5148 a_temp(1,2)=aggj(l,2)!+ghalf2
5149 a_temp(2,1)=aggj(l,3)!+ghalf3
5150 a_temp(2,2)=aggj(l,4)!+ghalf4
5151 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5152 gcorr3_turn(l,j)=gcorr3_turn(l,j)
5153 & +0.5d0*(pizda(1,1)+pizda(2,2))
5154 & *fac_shield(i)*fac_shield(j)
5155 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5157 a_temp(1,1)=aggj1(l,1)
5158 a_temp(1,2)=aggj1(l,2)
5159 a_temp(2,1)=aggj1(l,3)
5160 a_temp(2,2)=aggj1(l,4)
5161 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5162 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5163 & +0.5d0*(pizda(1,1)+pizda(2,2))
5164 & *fac_shield(i)*fac_shield(j)
5165 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5167 gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5168 & ssgradlipi*eello_t3/4.0d0*lipscale
5169 gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5170 & ssgradlipj*eello_t3/4.0d0*lipscale
5171 gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5172 & ssgradlipi*eello_t3/4.0d0*lipscale
5173 gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5174 & ssgradlipj*eello_t3/4.0d0*lipscale
5176 C print *,ssgradlipi,ssgradlipj,eello_t3,sslipi,sslipj
5179 C-------------------------------------------------------------------------------
5180 subroutine eturn4(i,eello_turn4)
5181 C Third- and fourth-order contributions from turns
5182 implicit real*8 (a-h,o-z)
5183 include 'DIMENSIONS'
5184 include 'COMMON.IOUNITS'
5185 include 'COMMON.GEO'
5186 include 'COMMON.VAR'
5187 include 'COMMON.LOCAL'
5188 include 'COMMON.CHAIN'
5189 include 'COMMON.DERIV'
5190 include 'COMMON.INTERACT'
5191 include 'COMMON.CONTACTS'
5192 include 'COMMON.TORSION'
5193 include 'COMMON.VECTORS'
5194 include 'COMMON.FFIELD'
5195 include 'COMMON.CONTROL'
5196 include 'COMMON.SHIELD'
5198 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5199 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5200 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5201 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5202 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
5203 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5204 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5205 double precision agg(3,4),aggi(3,4),aggi1(3,4),
5206 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5207 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5208 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5211 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5213 C Fourth-order contributions
5221 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5222 cd call checkint_turn4(i,a_temp,eello_turn4_num)
5223 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5224 c write(iout,*)"WCHODZE W PROGRAM"
5225 zj=(c(3,j)+c(3,j+1))/2.0d0
5226 C xj=mod(xj,boxxsize)
5227 C if (xj.lt.0) xj=xj+boxxsize
5228 C yj=mod(yj,boxysize)
5229 C if (yj.lt.0) yj=yj+boxysize
5231 if (zj.lt.0) zj=zj+boxzsize
5232 C if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
5233 if ((zj.gt.bordlipbot)
5234 &.and.(zj.lt.bordliptop)) then
5235 C the energy transfer exist
5236 if (zj.lt.buflipbot) then
5237 C what fraction I am in
5239 & ((zj-bordlipbot)/lipbufthick)
5240 C lipbufthick is thickenes of lipid buffore
5241 sslipj=sscalelip(fracinbuf)
5242 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5243 elseif (zj.gt.bufliptop) then
5244 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5245 sslipj=sscalelip(fracinbuf)
5246 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5260 iti1=itype2loc(itype(i+1))
5261 iti2=itype2loc(itype(i+2))
5262 iti3=itype2loc(itype(i+3))
5263 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5264 call transpose2(EUg(1,1,i+1),e1t(1,1))
5265 call transpose2(Eug(1,1,i+2),e2t(1,1))
5266 call transpose2(Eug(1,1,i+3),e3t(1,1))
5267 C Ematrix derivative in theta
5268 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5269 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5270 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5271 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5272 c eta1 in derivative theta
5273 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5274 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5275 c auxgvec is derivative of Ub2 so i+3 theta
5276 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5277 c auxalary matrix of E i+1
5278 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5281 s1=scalar2(b1(1,i+2),auxvec(1))
5282 c derivative of theta i+2 with constant i+3
5283 gs23=scalar2(gtb1(1,i+2),auxvec(1))
5284 c derivative of theta i+2 with constant i+2
5285 gs32=scalar2(b1(1,i+2),auxgvec(1))
5286 c derivative of E matix in theta of i+1
5287 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5289 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5290 c ea31 in derivative theta
5291 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5292 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5293 c auxilary matrix auxgvec of Ub2 with constant E matirx
5294 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5295 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5296 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5300 s2=scalar2(b1(1,i+1),auxvec(1))
5301 c derivative of theta i+1 with constant i+3
5302 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5303 c derivative of theta i+2 with constant i+1
5304 gs21=scalar2(b1(1,i+1),auxgvec(1))
5305 c derivative of theta i+3 with constant i+1
5306 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5307 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5309 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5310 c two derivatives over diffetent matrices
5311 c gtae3e2 is derivative over i+3
5312 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5313 c ae3gte2 is derivative over i+2
5314 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5315 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5316 c three possible derivative over theta E matices
5318 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5320 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5322 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5323 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5325 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5326 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5327 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5328 if (shield_mode.eq.0) then
5335 eello_turn4=eello_turn4-(s1+s2+s3)
5336 & *fac_shield(i)*fac_shield(j)
5337 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5339 eello_t4=-(s1+s2+s3)
5340 & *fac_shield(i)*fac_shield(j)
5341 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5342 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5343 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5344 C Now derivative over shield:
5345 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5346 & (shield_mode.gt.0)) then
5349 do ilist=1,ishield_list(i)
5350 iresshield=shield_list(ilist,i)
5352 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5354 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5356 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5357 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5361 do ilist=1,ishield_list(j)
5362 iresshield=shield_list(ilist,j)
5364 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5366 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5368 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5369 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5376 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5377 & grad_shield(k,i)*eello_t4/fac_shield(i)
5378 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5379 & grad_shield(k,j)*eello_t4/fac_shield(j)
5380 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5381 & grad_shield(k,i)*eello_t4/fac_shield(i)
5382 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5383 & grad_shield(k,j)*eello_t4/fac_shield(j)
5392 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5393 cd & ' eello_turn4_num',8*eello_turn4_num
5395 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5396 & -(gs13+gsE13+gsEE1)*wturn4
5397 & *fac_shield(i)*fac_shield(j)
5398 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5400 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5401 & -(gs23+gs21+gsEE2)*wturn4
5402 & *fac_shield(i)*fac_shield(j)
5403 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5405 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5406 & -(gs32+gsE31+gsEE3)*wturn4
5407 & *fac_shield(i)*fac_shield(j)
5408 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5410 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5413 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5414 & 'eturn4',i,j,-(s1+s2+s3)
5415 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5416 c & ' eello_turn4_num',8*eello_turn4_num
5417 C Derivatives in gamma(i)
5418 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5419 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5420 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5421 s1=scalar2(b1(1,i+2),auxvec(1))
5422 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5423 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5424 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5425 & *fac_shield(i)*fac_shield(j)
5426 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5428 C Derivatives in gamma(i+1)
5429 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5430 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5431 s2=scalar2(b1(1,i+1),auxvec(1))
5432 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5433 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5434 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5435 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5436 & *fac_shield(i)*fac_shield(j)
5437 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5439 C Derivatives in gamma(i+2)
5440 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5441 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5442 s1=scalar2(b1(1,i+2),auxvec(1))
5443 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5444 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5445 s2=scalar2(b1(1,i+1),auxvec(1))
5446 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5447 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5448 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5449 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5450 & *fac_shield(i)*fac_shield(j)
5451 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5453 C Cartesian derivatives
5454 C Derivatives of this turn contributions in DC(i+2)
5455 if (j.lt.nres-1) then
5457 a_temp(1,1)=agg(l,1)
5458 a_temp(1,2)=agg(l,2)
5459 a_temp(2,1)=agg(l,3)
5460 a_temp(2,2)=agg(l,4)
5461 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5462 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5463 s1=scalar2(b1(1,i+2),auxvec(1))
5464 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5465 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5466 s2=scalar2(b1(1,i+1),auxvec(1))
5467 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5468 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5469 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5471 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5472 & *fac_shield(i)*fac_shield(j)
5473 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5477 C Remaining derivatives of this turn contribution
5479 a_temp(1,1)=aggi(l,1)
5480 a_temp(1,2)=aggi(l,2)
5481 a_temp(2,1)=aggi(l,3)
5482 a_temp(2,2)=aggi(l,4)
5483 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5484 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5485 s1=scalar2(b1(1,i+2),auxvec(1))
5486 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5487 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5488 s2=scalar2(b1(1,i+1),auxvec(1))
5489 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5490 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5491 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5492 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5493 & *fac_shield(i)*fac_shield(j)
5494 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5496 a_temp(1,1)=aggi1(l,1)
5497 a_temp(1,2)=aggi1(l,2)
5498 a_temp(2,1)=aggi1(l,3)
5499 a_temp(2,2)=aggi1(l,4)
5500 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5501 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5502 s1=scalar2(b1(1,i+2),auxvec(1))
5503 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5504 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5505 s2=scalar2(b1(1,i+1),auxvec(1))
5506 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5507 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5508 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5509 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5510 & *fac_shield(i)*fac_shield(j)
5511 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5513 a_temp(1,1)=aggj(l,1)
5514 a_temp(1,2)=aggj(l,2)
5515 a_temp(2,1)=aggj(l,3)
5516 a_temp(2,2)=aggj(l,4)
5517 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5518 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5519 s1=scalar2(b1(1,i+2),auxvec(1))
5520 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5521 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5522 s2=scalar2(b1(1,i+1),auxvec(1))
5523 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5524 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5525 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5526 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5527 & *fac_shield(i)*fac_shield(j)
5528 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5530 a_temp(1,1)=aggj1(l,1)
5531 a_temp(1,2)=aggj1(l,2)
5532 a_temp(2,1)=aggj1(l,3)
5533 a_temp(2,2)=aggj1(l,4)
5534 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5535 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5536 s1=scalar2(b1(1,i+2),auxvec(1))
5537 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5538 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5539 s2=scalar2(b1(1,i+1),auxvec(1))
5540 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5541 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5542 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5543 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5544 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5545 & *fac_shield(i)*fac_shield(j)
5546 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5548 gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5549 & ssgradlipi*eello_t4/4.0d0*lipscale
5550 gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5551 & ssgradlipj*eello_t4/4.0d0*lipscale
5552 gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5553 & ssgradlipi*eello_t4/4.0d0*lipscale
5554 gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5555 & ssgradlipj*eello_t4/4.0d0*lipscale
5558 C-----------------------------------------------------------------------------
5559 subroutine vecpr(u,v,w)
5560 implicit real*8(a-h,o-z)
5561 dimension u(3),v(3),w(3)
5562 w(1)=u(2)*v(3)-u(3)*v(2)
5563 w(2)=-u(1)*v(3)+u(3)*v(1)
5564 w(3)=u(1)*v(2)-u(2)*v(1)
5567 C-----------------------------------------------------------------------------
5568 subroutine unormderiv(u,ugrad,unorm,ungrad)
5569 C This subroutine computes the derivatives of a normalized vector u, given
5570 C the derivatives computed without normalization conditions, ugrad. Returns
5573 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5574 double precision vec(3)
5575 double precision scalar
5577 c write (2,*) 'ugrad',ugrad
5580 vec(i)=scalar(ugrad(1,i),u(1))
5582 c write (2,*) 'vec',vec
5585 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5588 c write (2,*) 'ungrad',ungrad
5591 C-----------------------------------------------------------------------------
5592 subroutine escp_soft_sphere(evdw2,evdw2_14)
5594 C This subroutine calculates the excluded-volume interaction energy between
5595 C peptide-group centers and side chains and its gradient in virtual-bond and
5596 C side-chain vectors.
5598 implicit real*8 (a-h,o-z)
5599 include 'DIMENSIONS'
5600 include 'COMMON.GEO'
5601 include 'COMMON.VAR'
5602 include 'COMMON.LOCAL'
5603 include 'COMMON.CHAIN'
5604 include 'COMMON.DERIV'
5605 include 'COMMON.INTERACT'
5606 include 'COMMON.FFIELD'
5607 include 'COMMON.IOUNITS'
5608 include 'COMMON.CONTROL'
5613 cd print '(a)','Enter ESCP'
5614 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5618 do i=iatscp_s,iatscp_e
5619 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5621 xi=0.5D0*(c(1,i)+c(1,i+1))
5622 yi=0.5D0*(c(2,i)+c(2,i+1))
5623 zi=0.5D0*(c(3,i)+c(3,i+1))
5624 C Return atom into box, boxxsize is size of box in x dimension
5626 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5627 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5628 C Condition for being inside the proper box
5629 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5630 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5634 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5635 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5636 C Condition for being inside the proper box
5637 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5638 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5642 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5643 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5644 cC Condition for being inside the proper box
5645 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5646 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5650 if (xi.lt.0) xi=xi+boxxsize
5652 if (yi.lt.0) yi=yi+boxysize
5654 if (zi.lt.0) zi=zi+boxzsize
5655 C xi=xi+xshift*boxxsize
5656 C yi=yi+yshift*boxysize
5657 C zi=zi+zshift*boxzsize
5658 do iint=1,nscp_gr(i)
5660 do j=iscpstart(i,iint),iscpend(i,iint)
5661 if (itype(j).eq.ntyp1) cycle
5662 itypj=iabs(itype(j))
5663 C Uncomment following three lines for SC-p interactions
5667 C Uncomment following three lines for Ca-p interactions
5672 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5673 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5674 C Condition for being inside the proper box
5675 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5676 c & (xj.lt.((-0.5d0)*boxxsize))) then
5680 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5681 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5682 cC Condition for being inside the proper box
5683 c if ((yj.gt.((0.5d0)*boxysize)).or.
5684 c & (yj.lt.((-0.5d0)*boxysize))) then
5688 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5689 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5690 C Condition for being inside the proper box
5691 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5692 c & (zj.lt.((-0.5d0)*boxzsize))) then
5695 if (xj.lt.0) xj=xj+boxxsize
5697 if (yj.lt.0) yj=yj+boxysize
5699 if (zj.lt.0) zj=zj+boxzsize
5700 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5708 xj=xj_safe+xshift*boxxsize
5709 yj=yj_safe+yshift*boxysize
5710 zj=zj_safe+zshift*boxzsize
5711 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5712 if(dist_temp.lt.dist_init) then
5722 if (subchap.eq.1) then
5735 rij=xj*xj+yj*yj+zj*zj
5739 if (rij.lt.r0ijsq) then
5740 evdwij=0.25d0*(rij-r0ijsq)**2
5748 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5753 cgrad if (j.lt.i) then
5754 cd write (iout,*) 'j<i'
5755 C Uncomment following three lines for SC-p interactions
5757 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5760 cd write (iout,*) 'j>i'
5762 cgrad ggg(k)=-ggg(k)
5763 C Uncomment following line for SC-p interactions
5764 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5768 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5770 cgrad kstart=min0(i+1,j)
5771 cgrad kend=max0(i-1,j-1)
5772 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5773 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5774 cgrad do k=kstart,kend
5776 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5780 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5781 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5792 C-----------------------------------------------------------------------------
5793 subroutine escp(evdw2,evdw2_14)
5795 C This subroutine calculates the excluded-volume interaction energy between
5796 C peptide-group centers and side chains and its gradient in virtual-bond and
5797 C side-chain vectors.
5799 implicit real*8 (a-h,o-z)
5800 include 'DIMENSIONS'
5801 include 'COMMON.GEO'
5802 include 'COMMON.VAR'
5803 include 'COMMON.LOCAL'
5804 include 'COMMON.CHAIN'
5805 include 'COMMON.DERIV'
5806 include 'COMMON.INTERACT'
5807 include 'COMMON.FFIELD'
5808 include 'COMMON.IOUNITS'
5809 include 'COMMON.CONTROL'
5810 include 'COMMON.SPLITELE'
5814 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5815 cd print '(a)','Enter ESCP'
5816 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5820 do i=iatscp_s,iatscp_e
5821 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5823 xi=0.5D0*(c(1,i)+c(1,i+1))
5824 yi=0.5D0*(c(2,i)+c(2,i+1))
5825 zi=0.5D0*(c(3,i)+c(3,i+1))
5827 if (xi.lt.0) xi=xi+boxxsize
5829 if (yi.lt.0) yi=yi+boxysize
5831 if (zi.lt.0) zi=zi+boxzsize
5832 c xi=xi+xshift*boxxsize
5833 c yi=yi+yshift*boxysize
5834 c zi=zi+zshift*boxzsize
5835 c print *,xi,yi,zi,'polozenie i'
5836 C Return atom into box, boxxsize is size of box in x dimension
5838 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5839 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5840 C Condition for being inside the proper box
5841 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5842 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5846 c print *,xi,boxxsize,"pierwszy"
5848 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5849 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5850 C Condition for being inside the proper box
5851 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5852 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5856 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5857 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5858 C Condition for being inside the proper box
5859 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5860 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5863 do iint=1,nscp_gr(i)
5865 do j=iscpstart(i,iint),iscpend(i,iint)
5866 itypj=iabs(itype(j))
5867 if (itypj.eq.ntyp1) cycle
5868 C Uncomment following three lines for SC-p interactions
5872 C Uncomment following three lines for Ca-p interactions
5877 if (xj.lt.0) xj=xj+boxxsize
5879 if (yj.lt.0) yj=yj+boxysize
5881 if (zj.lt.0) zj=zj+boxzsize
5883 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5884 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5885 C Condition for being inside the proper box
5886 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5887 c & (xj.lt.((-0.5d0)*boxxsize))) then
5891 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5892 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5893 cC Condition for being inside the proper box
5894 c if ((yj.gt.((0.5d0)*boxysize)).or.
5895 c & (yj.lt.((-0.5d0)*boxysize))) then
5899 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5900 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5901 C Condition for being inside the proper box
5902 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5903 c & (zj.lt.((-0.5d0)*boxzsize))) then
5906 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5907 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5915 xj=xj_safe+xshift*boxxsize
5916 yj=yj_safe+yshift*boxysize
5917 zj=zj_safe+zshift*boxzsize
5918 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5919 if(dist_temp.lt.dist_init) then
5929 if (subchap.eq.1) then
5938 c print *,xj,yj,zj,'polozenie j'
5939 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5941 sss=sscale(1.0d0/(dsqrt(rrij)))
5942 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5943 c if (sss.eq.0) print *,'czasem jest OK'
5944 if (sss.le.0.0d0) cycle
5945 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5947 e1=fac*fac*aad(itypj,iteli)
5948 e2=fac*bad(itypj,iteli)
5949 if (iabs(j-i) .le. 2) then
5952 evdw2_14=evdw2_14+(e1+e2)*sss
5955 evdw2=evdw2+evdwij*sss
5956 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5957 & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5960 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5962 fac=-(evdwij+e1)*rrij*sss
5963 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5967 cgrad if (j.lt.i) then
5968 cd write (iout,*) 'j<i'
5969 C Uncomment following three lines for SC-p interactions
5971 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5974 cd write (iout,*) 'j>i'
5976 cgrad ggg(k)=-ggg(k)
5977 C Uncomment following line for SC-p interactions
5978 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5979 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5983 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5985 cgrad kstart=min0(i+1,j)
5986 cgrad kend=max0(i-1,j-1)
5987 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5988 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5989 cgrad do k=kstart,kend
5991 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5995 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5996 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5998 c endif !endif for sscale cutoff
6008 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
6009 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
6010 gradx_scp(j,i)=expon*gradx_scp(j,i)
6013 C******************************************************************************
6017 C To save time the factor EXPON has been extracted from ALL components
6018 C of GVDWC and GRADX. Remember to multiply them by this factor before further
6021 C******************************************************************************
6024 C--------------------------------------------------------------------------
6025 subroutine edis(ehpb)
6027 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
6029 implicit real*8 (a-h,o-z)
6030 include 'DIMENSIONS'
6031 include 'COMMON.SBRIDGE'
6032 include 'COMMON.CHAIN'
6033 include 'COMMON.DERIV'
6034 include 'COMMON.VAR'
6035 include 'COMMON.INTERACT'
6036 include 'COMMON.IOUNITS'
6037 include 'COMMON.CONTROL'
6043 C write (iout,*) ,"link_end",link_end,constr_dist
6044 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
6045 cd write(iout,*)'link_start=',link_start,' link_end=',link_end
6046 if (link_end.eq.0) return
6047 do i=link_start,link_end
6048 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
6049 C CA-CA distance used in regularization of structure.
6052 C iii and jjj point to the residues for which the distance is assigned.
6053 if (ii.gt.nres) then
6060 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6061 c & dhpb(i),dhpb1(i),forcon(i)
6062 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6063 C distance and angle dependent SS bond potential.
6064 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6065 C & iabs(itype(jjj)).eq.1) then
6066 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6067 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6068 if (.not.dyn_ss .and. i.le.nss) then
6069 C 15/02/13 CC dynamic SSbond - additional check
6070 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6071 & iabs(itype(jjj)).eq.1) then
6072 call ssbond_ene(iii,jjj,eij)
6075 cd write (iout,*) "eij",eij
6076 cd & ' waga=',waga,' fac=',fac
6077 else if (ii.gt.nres .and. jj.gt.nres) then
6078 c Restraints from contact prediction
6080 if (constr_dist.eq.11) then
6081 ehpb=ehpb+fordepth(i)**4.0d0
6082 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6083 fac=fordepth(i)**4.0d0
6084 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6085 if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6086 & ehpb,fordepth(i),dd
6088 if (dhpb1(i).gt.0.0d0) then
6089 ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6090 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6091 c write (iout,*) "beta nmr",
6092 c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6096 C Get the force constant corresponding to this distance.
6098 C Calculate the contribution to energy.
6099 ehpb=ehpb+waga*rdis*rdis
6100 c write (iout,*) "beta reg",dd,waga*rdis*rdis
6102 C Evaluate gradient.
6108 ggg(j)=fac*(c(j,jj)-c(j,ii))
6111 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6112 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6115 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6116 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6119 C Calculate the distance between the two points and its difference from the
6122 if (constr_dist.eq.11) then
6123 ehpb=ehpb+fordepth(i)**4.0d0
6124 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6125 fac=fordepth(i)**4.0d0
6126 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6127 if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6128 & ehpb,fordepth(i),dd
6130 if (dhpb1(i).gt.0.0d0) then
6131 ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6132 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6133 c write (iout,*) "alph nmr",
6134 c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6137 C Get the force constant corresponding to this distance.
6139 C Calculate the contribution to energy.
6140 ehpb=ehpb+waga*rdis*rdis
6141 c write (iout,*) "alpha reg",dd,waga*rdis*rdis
6143 C Evaluate gradient.
6149 ggg(j)=fac*(c(j,jj)-c(j,ii))
6151 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6152 C If this is a SC-SC distance, we need to calculate the contributions to the
6153 C Cartesian gradient in the SC vectors (ghpbx).
6156 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6157 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6160 cgrad do j=iii,jjj-1
6162 cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k)
6166 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6167 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6171 if (constr_dist.ne.11) ehpb=0.5D0*ehpb
6174 C--------------------------------------------------------------------------
6175 subroutine ssbond_ene(i,j,eij)
6177 C Calculate the distance and angle dependent SS-bond potential energy
6178 C using a free-energy function derived based on RHF/6-31G** ab initio
6179 C calculations of diethyl disulfide.
6181 C A. Liwo and U. Kozlowska, 11/24/03
6183 implicit real*8 (a-h,o-z)
6184 include 'DIMENSIONS'
6185 include 'COMMON.SBRIDGE'
6186 include 'COMMON.CHAIN'
6187 include 'COMMON.DERIV'
6188 include 'COMMON.LOCAL'
6189 include 'COMMON.INTERACT'
6190 include 'COMMON.VAR'
6191 include 'COMMON.IOUNITS'
6192 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6193 itypi=iabs(itype(i))
6197 dxi=dc_norm(1,nres+i)
6198 dyi=dc_norm(2,nres+i)
6199 dzi=dc_norm(3,nres+i)
6200 c dsci_inv=dsc_inv(itypi)
6201 dsci_inv=vbld_inv(nres+i)
6202 itypj=iabs(itype(j))
6203 c dscj_inv=dsc_inv(itypj)
6204 dscj_inv=vbld_inv(nres+j)
6208 dxj=dc_norm(1,nres+j)
6209 dyj=dc_norm(2,nres+j)
6210 dzj=dc_norm(3,nres+j)
6211 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6216 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6217 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6218 om12=dxi*dxj+dyi*dyj+dzi*dzj
6220 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6221 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6227 deltat12=om2-om1+2.0d0
6229 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6230 & +akct*deltad*deltat12
6231 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6232 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6233 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6234 c & " deltat12",deltat12," eij",eij
6235 ed=2*akcm*deltad+akct*deltat12
6237 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6238 eom1=-2*akth*deltat1-pom1-om2*pom2
6239 eom2= 2*akth*deltat2+pom1-om1*pom2
6242 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6243 ghpbx(k,i)=ghpbx(k,i)-ggk
6244 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6245 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6246 ghpbx(k,j)=ghpbx(k,j)+ggk
6247 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6248 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6249 ghpbc(k,i)=ghpbc(k,i)-ggk
6250 ghpbc(k,j)=ghpbc(k,j)+ggk
6253 C Calculate the components of the gradient in DC and X
6257 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
6262 C--------------------------------------------------------------------------
6263 subroutine ebond(estr)
6265 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6267 implicit real*8 (a-h,o-z)
6268 include 'DIMENSIONS'
6269 include 'COMMON.LOCAL'
6270 include 'COMMON.GEO'
6271 include 'COMMON.INTERACT'
6272 include 'COMMON.DERIV'
6273 include 'COMMON.VAR'
6274 include 'COMMON.CHAIN'
6275 include 'COMMON.IOUNITS'
6276 include 'COMMON.NAMES'
6277 include 'COMMON.FFIELD'
6278 include 'COMMON.CONTROL'
6279 include 'COMMON.SETUP'
6280 double precision u(3),ud(3)
6283 do i=ibondp_start,ibondp_end
6284 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6285 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6287 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6288 c & *dc(j,i-1)/vbld(i)
6290 c if (energy_dec) write(iout,*)
6291 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6293 C Checking if it involves dummy (NH3+ or COO-) group
6294 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6295 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
6296 diff = vbld(i)-vbldpDUM
6297 if (energy_dec) write(iout,*) "dum_bond",i,diff
6299 C NO vbldp0 is the equlibrium lenght of spring for peptide group
6300 diff = vbld(i)-vbldp0
6302 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6303 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6306 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6308 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6312 estr=0.5d0*AKP*estr+estr1
6314 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6316 do i=ibond_start,ibond_end
6318 if (iti.ne.10 .and. iti.ne.ntyp1) then
6321 diff=vbld(i+nres)-vbldsc0(1,iti)
6322 if (energy_dec) write (iout,*)
6323 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6324 & AKSC(1,iti),AKSC(1,iti)*diff*diff
6325 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6327 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6331 diff=vbld(i+nres)-vbldsc0(j,iti)
6332 ud(j)=aksc(j,iti)*diff
6333 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6347 uprod2=uprod2*u(k)*u(k)
6351 usumsqder=usumsqder+ud(j)*uprod2
6353 estr=estr+uprod/usum
6355 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6363 C--------------------------------------------------------------------------
6364 subroutine ebend(etheta,ethetacnstr)
6366 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6367 C angles gamma and its derivatives in consecutive thetas and gammas.
6369 implicit real*8 (a-h,o-z)
6370 include 'DIMENSIONS'
6371 include 'COMMON.LOCAL'
6372 include 'COMMON.GEO'
6373 include 'COMMON.INTERACT'
6374 include 'COMMON.DERIV'
6375 include 'COMMON.VAR'
6376 include 'COMMON.CHAIN'
6377 include 'COMMON.IOUNITS'
6378 include 'COMMON.NAMES'
6379 include 'COMMON.FFIELD'
6380 include 'COMMON.CONTROL'
6381 include 'COMMON.TORCNSTR'
6382 common /calcthet/ term1,term2,termm,diffak,ratak,
6383 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6384 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6385 double precision y(2),z(2)
6387 c time11=dexp(-2*time)
6390 c write (*,'(a,i2)') 'EBEND ICG=',icg
6391 do i=ithet_start,ithet_end
6392 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6393 & .or.itype(i).eq.ntyp1) cycle
6394 C Zero the energy function and its derivative at 0 or pi.
6395 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6397 ichir1=isign(1,itype(i-2))
6398 ichir2=isign(1,itype(i))
6399 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6400 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6401 if (itype(i-1).eq.10) then
6402 itype1=isign(10,itype(i-2))
6403 ichir11=isign(1,itype(i-2))
6404 ichir12=isign(1,itype(i-2))
6405 itype2=isign(10,itype(i))
6406 ichir21=isign(1,itype(i))
6407 ichir22=isign(1,itype(i))
6410 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6413 if (phii.ne.phii) phii=150.0
6423 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6426 if (phii1.ne.phii1) phii1=150.0
6438 C Calculate the "mean" value of theta from the part of the distribution
6439 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6440 C In following comments this theta will be referred to as t_c.
6441 thet_pred_mean=0.0d0
6443 athetk=athet(k,it,ichir1,ichir2)
6444 bthetk=bthet(k,it,ichir1,ichir2)
6446 athetk=athet(k,itype1,ichir11,ichir12)
6447 bthetk=bthet(k,itype2,ichir21,ichir22)
6449 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6450 c write(iout,*) 'chuj tu', y(k),z(k)
6452 dthett=thet_pred_mean*ssd
6453 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6454 C Derivatives of the "mean" values in gamma1 and gamma2.
6455 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6456 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6457 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6458 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6460 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6461 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6462 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6463 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6465 if (theta(i).gt.pi-delta) then
6466 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6468 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6469 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6470 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6472 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6474 else if (theta(i).lt.delta) then
6475 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6476 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6477 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6479 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6480 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6483 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6486 etheta=etheta+ethetai
6487 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6488 & 'ebend',i,ethetai,theta(i),itype(i)
6489 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6490 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6491 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6494 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
6495 do i=ithetaconstr_start,ithetaconstr_end
6496 itheta=itheta_constr(i)
6497 thetiii=theta(itheta)
6498 difi=pinorm(thetiii-theta_constr0(i))
6499 if (difi.gt.theta_drange(i)) then
6500 difi=difi-theta_drange(i)
6501 ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6502 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6503 & +for_thet_constr(i)*difi**3
6504 else if (difi.lt.-drange(i)) then
6506 ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6507 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6508 & +for_thet_constr(i)*difi**3
6512 if (energy_dec) then
6513 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6514 & i,itheta,rad2deg*thetiii,
6515 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
6516 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6517 & gloc(itheta+nphi-2,icg)
6521 C Ufff.... We've done all this!!!
6524 C---------------------------------------------------------------------------
6525 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6527 implicit real*8 (a-h,o-z)
6528 include 'DIMENSIONS'
6529 include 'COMMON.LOCAL'
6530 include 'COMMON.IOUNITS'
6531 common /calcthet/ term1,term2,termm,diffak,ratak,
6532 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6533 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6534 C Calculate the contributions to both Gaussian lobes.
6535 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6536 C The "polynomial part" of the "standard deviation" of this part of
6537 C the distributioni.
6538 ccc write (iout,*) thetai,thet_pred_mean
6541 sig=sig*thet_pred_mean+polthet(j,it)
6543 C Derivative of the "interior part" of the "standard deviation of the"
6544 C gamma-dependent Gaussian lobe in t_c.
6545 sigtc=3*polthet(3,it)
6547 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6550 C Set the parameters of both Gaussian lobes of the distribution.
6551 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6552 fac=sig*sig+sigc0(it)
6555 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6556 sigsqtc=-4.0D0*sigcsq*sigtc
6557 c print *,i,sig,sigtc,sigsqtc
6558 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6559 sigtc=-sigtc/(fac*fac)
6560 C Following variable is sigma(t_c)**(-2)
6561 sigcsq=sigcsq*sigcsq
6563 sig0inv=1.0D0/sig0i**2
6564 delthec=thetai-thet_pred_mean
6565 delthe0=thetai-theta0i
6566 term1=-0.5D0*sigcsq*delthec*delthec
6567 term2=-0.5D0*sig0inv*delthe0*delthe0
6568 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6569 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6570 C NaNs in taking the logarithm. We extract the largest exponent which is added
6571 C to the energy (this being the log of the distribution) at the end of energy
6572 C term evaluation for this virtual-bond angle.
6573 if (term1.gt.term2) then
6575 term2=dexp(term2-termm)
6579 term1=dexp(term1-termm)
6582 C The ratio between the gamma-independent and gamma-dependent lobes of
6583 C the distribution is a Gaussian function of thet_pred_mean too.
6584 diffak=gthet(2,it)-thet_pred_mean
6585 ratak=diffak/gthet(3,it)**2
6586 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6587 C Let's differentiate it in thet_pred_mean NOW.
6589 C Now put together the distribution terms to make complete distribution.
6590 termexp=term1+ak*term2
6591 termpre=sigc+ak*sig0i
6592 C Contribution of the bending energy from this theta is just the -log of
6593 C the sum of the contributions from the two lobes and the pre-exponential
6594 C factor. Simple enough, isn't it?
6595 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6596 C write (iout,*) 'termexp',termexp,termm,termpre,i
6597 C NOW the derivatives!!!
6598 C 6/6/97 Take into account the deformation.
6599 E_theta=(delthec*sigcsq*term1
6600 & +ak*delthe0*sig0inv*term2)/termexp
6601 E_tc=((sigtc+aktc*sig0i)/termpre
6602 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6603 & aktc*term2)/termexp)
6606 c-----------------------------------------------------------------------------
6607 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6608 implicit real*8 (a-h,o-z)
6609 include 'DIMENSIONS'
6610 include 'COMMON.LOCAL'
6611 include 'COMMON.IOUNITS'
6612 common /calcthet/ term1,term2,termm,diffak,ratak,
6613 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6614 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6615 delthec=thetai-thet_pred_mean
6616 delthe0=thetai-theta0i
6617 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6618 t3 = thetai-thet_pred_mean
6622 t14 = t12+t6*sigsqtc
6624 t21 = thetai-theta0i
6630 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6631 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6632 & *(-t12*t9-ak*sig0inv*t27)
6636 C--------------------------------------------------------------------------
6637 subroutine ebend(etheta,ethetacnstr)
6639 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6640 C angles gamma and its derivatives in consecutive thetas and gammas.
6641 C ab initio-derived potentials from
6642 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6644 implicit real*8 (a-h,o-z)
6645 include 'DIMENSIONS'
6646 include 'COMMON.LOCAL'
6647 include 'COMMON.GEO'
6648 include 'COMMON.INTERACT'
6649 include 'COMMON.DERIV'
6650 include 'COMMON.VAR'
6651 include 'COMMON.CHAIN'
6652 include 'COMMON.IOUNITS'
6653 include 'COMMON.NAMES'
6654 include 'COMMON.FFIELD'
6655 include 'COMMON.CONTROL'
6656 include 'COMMON.TORCNSTR'
6657 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6658 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6659 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6660 & sinph1ph2(maxdouble,maxdouble)
6661 logical lprn /.false./, lprn1 /.false./
6663 do i=ithet_start,ithet_end
6664 c print *,i,itype(i-1),itype(i),itype(i-2)
6665 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6666 & .or.itype(i).eq.ntyp1) cycle
6667 C print *,i,theta(i)
6668 if (iabs(itype(i+1)).eq.20) iblock=2
6669 if (iabs(itype(i+1)).ne.20) iblock=1
6673 theti2=0.5d0*theta(i)
6674 ityp2=ithetyp((itype(i-1)))
6676 coskt(k)=dcos(k*theti2)
6677 sinkt(k)=dsin(k*theti2)
6680 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6683 if (phii.ne.phii) phii=150.0
6687 ityp1=ithetyp((itype(i-2)))
6688 C propagation of chirality for glycine type
6690 cosph1(k)=dcos(k*phii)
6691 sinph1(k)=dsin(k*phii)
6696 ityp1=ithetyp((itype(i-2)))
6701 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6704 if (phii1.ne.phii1) phii1=150.0
6709 ityp3=ithetyp((itype(i)))
6711 cosph2(k)=dcos(k*phii1)
6712 sinph2(k)=dsin(k*phii1)
6716 ityp3=ithetyp((itype(i)))
6722 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6725 ccl=cosph1(l)*cosph2(k-l)
6726 ssl=sinph1(l)*sinph2(k-l)
6727 scl=sinph1(l)*cosph2(k-l)
6728 csl=cosph1(l)*sinph2(k-l)
6729 cosph1ph2(l,k)=ccl-ssl
6730 cosph1ph2(k,l)=ccl+ssl
6731 sinph1ph2(l,k)=scl+csl
6732 sinph1ph2(k,l)=scl-csl
6736 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6737 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6738 write (iout,*) "coskt and sinkt"
6740 write (iout,*) k,coskt(k),sinkt(k)
6744 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6745 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6748 & write (iout,*) "k",k,"
6749 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6750 & " ethetai",ethetai
6753 write (iout,*) "cosph and sinph"
6755 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6757 write (iout,*) "cosph1ph2 and sinph2ph2"
6760 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6761 & sinph1ph2(l,k),sinph1ph2(k,l)
6764 write(iout,*) "ethetai",ethetai
6769 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6770 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6771 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6772 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6773 ethetai=ethetai+sinkt(m)*aux
6774 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6775 dephii=dephii+k*sinkt(m)*(
6776 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6777 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6778 dephii1=dephii1+k*sinkt(m)*(
6779 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6780 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6782 & write (iout,*) "m",m," k",k," bbthet",
6783 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6784 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6785 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6786 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6787 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6790 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6791 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6792 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6793 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6795 & write(iout,*) "ethetai",ethetai
6796 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6800 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6801 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6802 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6803 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6804 ethetai=ethetai+sinkt(m)*aux
6805 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6806 dephii=dephii+l*sinkt(m)*(
6807 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6808 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6809 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6810 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6811 dephii1=dephii1+(k-l)*sinkt(m)*(
6812 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6813 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6814 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6815 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6817 write (iout,*) "m",m," k",k," l",l," ffthet",
6818 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6819 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6820 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6821 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6822 & " ethetai",ethetai
6823 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6824 & cosph1ph2(k,l)*sinkt(m),
6825 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6834 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6835 & i,theta(i)*rad2deg,phii*rad2deg,
6836 & phii1*rad2deg,ethetai
6838 etheta=etheta+ethetai
6839 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6840 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6841 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6845 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
6846 do i=ithetaconstr_start,ithetaconstr_end
6847 itheta=itheta_constr(i)
6848 thetiii=theta(itheta)
6849 difi=pinorm(thetiii-theta_constr0(i))
6850 if (difi.gt.theta_drange(i)) then
6851 difi=difi-theta_drange(i)
6852 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6853 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6854 & +for_thet_constr(i)*difi**3
6855 else if (difi.lt.-drange(i)) then
6857 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6858 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6859 & +for_thet_constr(i)*difi**3
6863 if (energy_dec) then
6864 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6865 & i,itheta,rad2deg*thetiii,
6866 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
6867 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6868 & gloc(itheta+nphi-2,icg)
6876 c-----------------------------------------------------------------------------
6877 subroutine esc(escloc)
6878 C Calculate the local energy of a side chain and its derivatives in the
6879 C corresponding virtual-bond valence angles THETA and the spherical angles
6881 implicit real*8 (a-h,o-z)
6882 include 'DIMENSIONS'
6883 include 'COMMON.GEO'
6884 include 'COMMON.LOCAL'
6885 include 'COMMON.VAR'
6886 include 'COMMON.INTERACT'
6887 include 'COMMON.DERIV'
6888 include 'COMMON.CHAIN'
6889 include 'COMMON.IOUNITS'
6890 include 'COMMON.NAMES'
6891 include 'COMMON.FFIELD'
6892 include 'COMMON.CONTROL'
6893 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6894 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6895 common /sccalc/ time11,time12,time112,theti,it,nlobit
6898 c write (iout,'(a)') 'ESC'
6899 do i=loc_start,loc_end
6901 if (it.eq.ntyp1) cycle
6902 if (it.eq.10) goto 1
6903 nlobit=nlob(iabs(it))
6904 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6905 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6906 theti=theta(i+1)-pipol
6911 if (x(2).gt.pi-delta) then
6915 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6917 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6918 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6920 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6921 & ddersc0(1),dersc(1))
6922 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6923 & ddersc0(3),dersc(3))
6925 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6927 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6928 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6929 & dersc0(2),esclocbi,dersc02)
6930 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6932 call splinthet(x(2),0.5d0*delta,ss,ssd)
6937 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6939 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6940 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6942 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6944 c write (iout,*) escloci
6945 else if (x(2).lt.delta) then
6949 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6951 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6952 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6954 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6955 & ddersc0(1),dersc(1))
6956 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6957 & ddersc0(3),dersc(3))
6959 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6961 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6962 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6963 & dersc0(2),esclocbi,dersc02)
6964 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6969 call splinthet(x(2),0.5d0*delta,ss,ssd)
6971 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6973 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6974 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6976 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6977 c write (iout,*) escloci
6979 call enesc(x,escloci,dersc,ddummy,.false.)
6982 escloc=escloc+escloci
6983 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6984 & 'escloc',i,escloci
6985 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6987 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6989 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6990 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6995 C---------------------------------------------------------------------------
6996 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6997 implicit real*8 (a-h,o-z)
6998 include 'DIMENSIONS'
6999 include 'COMMON.GEO'
7000 include 'COMMON.LOCAL'
7001 include 'COMMON.IOUNITS'
7002 common /sccalc/ time11,time12,time112,theti,it,nlobit
7003 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
7004 double precision contr(maxlob,-1:1)
7006 c write (iout,*) 'it=',it,' nlobit=',nlobit
7010 if (mixed) ddersc(j)=0.0d0
7014 C Because of periodicity of the dependence of the SC energy in omega we have
7015 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
7016 C To avoid underflows, first compute & store the exponents.
7024 z(k)=x(k)-censc(k,j,it)
7029 Axk=Axk+gaussc(l,k,j,it)*z(l)
7035 expfac=expfac+Ax(k,j,iii)*z(k)
7043 C As in the case of ebend, we want to avoid underflows in exponentiation and
7044 C subsequent NaNs and INFs in energy calculation.
7045 C Find the largest exponent
7049 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
7053 cd print *,'it=',it,' emin=',emin
7055 C Compute the contribution to SC energy and derivatives
7060 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7061 if(adexp.ne.adexp) adexp=1.0
7064 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7066 cd print *,'j=',j,' expfac=',expfac
7067 escloc_i=escloc_i+expfac
7069 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7073 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7074 & +gaussc(k,2,j,it))*expfac
7081 dersc(1)=dersc(1)/cos(theti)**2
7082 ddersc(1)=ddersc(1)/cos(theti)**2
7085 escloci=-(dlog(escloc_i)-emin)
7087 dersc(j)=dersc(j)/escloc_i
7091 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7096 C------------------------------------------------------------------------------
7097 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7098 implicit real*8 (a-h,o-z)
7099 include 'DIMENSIONS'
7100 include 'COMMON.GEO'
7101 include 'COMMON.LOCAL'
7102 include 'COMMON.IOUNITS'
7103 common /sccalc/ time11,time12,time112,theti,it,nlobit
7104 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7105 double precision contr(maxlob)
7116 z(k)=x(k)-censc(k,j,it)
7122 Axk=Axk+gaussc(l,k,j,it)*z(l)
7128 expfac=expfac+Ax(k,j)*z(k)
7133 C As in the case of ebend, we want to avoid underflows in exponentiation and
7134 C subsequent NaNs and INFs in energy calculation.
7135 C Find the largest exponent
7138 if (emin.gt.contr(j)) emin=contr(j)
7142 C Compute the contribution to SC energy and derivatives
7146 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7147 escloc_i=escloc_i+expfac
7149 dersc(k)=dersc(k)+Ax(k,j)*expfac
7151 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7152 & +gaussc(1,2,j,it))*expfac
7156 dersc(1)=dersc(1)/cos(theti)**2
7157 dersc12=dersc12/cos(theti)**2
7158 escloci=-(dlog(escloc_i)-emin)
7160 dersc(j)=dersc(j)/escloc_i
7162 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7166 c----------------------------------------------------------------------------------
7167 subroutine esc(escloc)
7168 C Calculate the local energy of a side chain and its derivatives in the
7169 C corresponding virtual-bond valence angles THETA and the spherical angles
7170 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7171 C added by Urszula Kozlowska. 07/11/2007
7173 implicit real*8 (a-h,o-z)
7174 include 'DIMENSIONS'
7175 include 'COMMON.GEO'
7176 include 'COMMON.LOCAL'
7177 include 'COMMON.VAR'
7178 include 'COMMON.SCROT'
7179 include 'COMMON.INTERACT'
7180 include 'COMMON.DERIV'
7181 include 'COMMON.CHAIN'
7182 include 'COMMON.IOUNITS'
7183 include 'COMMON.NAMES'
7184 include 'COMMON.FFIELD'
7185 include 'COMMON.CONTROL'
7186 include 'COMMON.VECTORS'
7187 double precision x_prime(3),y_prime(3),z_prime(3)
7188 & , sumene,dsc_i,dp2_i,x(65),
7189 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7190 & de_dxx,de_dyy,de_dzz,de_dt
7191 double precision s1_t,s1_6_t,s2_t,s2_6_t
7193 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7194 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7195 & dt_dCi(3),dt_dCi1(3)
7196 common /sccalc/ time11,time12,time112,theti,it,nlobit
7199 do i=loc_start,loc_end
7200 if (itype(i).eq.ntyp1) cycle
7201 costtab(i+1) =dcos(theta(i+1))
7202 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7203 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7204 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7205 cosfac2=0.5d0/(1.0d0+costtab(i+1))
7206 cosfac=dsqrt(cosfac2)
7207 sinfac2=0.5d0/(1.0d0-costtab(i+1))
7208 sinfac=dsqrt(sinfac2)
7210 if (it.eq.10) goto 1
7212 C Compute the axes of tghe local cartesian coordinates system; store in
7213 c x_prime, y_prime and z_prime
7220 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7221 C & dc_norm(3,i+nres)
7223 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7224 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7227 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7230 c write (2,*) "x_prime",(x_prime(j),j=1,3)
7231 c write (2,*) "y_prime",(y_prime(j),j=1,3)
7232 c write (2,*) "z_prime",(z_prime(j),j=1,3)
7233 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7234 c & " xy",scalar(x_prime(1),y_prime(1)),
7235 c & " xz",scalar(x_prime(1),z_prime(1)),
7236 c & " yy",scalar(y_prime(1),y_prime(1)),
7237 c & " yz",scalar(y_prime(1),z_prime(1)),
7238 c & " zz",scalar(z_prime(1),z_prime(1))
7240 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7241 C to local coordinate system. Store in xx, yy, zz.
7247 xx = xx + x_prime(j)*dc_norm(j,i+nres)
7248 yy = yy + y_prime(j)*dc_norm(j,i+nres)
7249 zz = zz + z_prime(j)*dc_norm(j,i+nres)
7256 C Compute the energy of the ith side cbain
7258 c write (2,*) "xx",xx," yy",yy," zz",zz
7261 x(j) = sc_parmin(j,it)
7264 Cc diagnostics - remove later
7266 yy1 = dsin(alph(2))*dcos(omeg(2))
7267 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7268 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7269 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7271 C," --- ", xx_w,yy_w,zz_w
7274 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7275 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7277 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7278 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7280 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7281 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7282 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7283 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7284 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7286 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7287 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7288 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7289 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7290 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7292 dsc_i = 0.743d0+x(61)
7294 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7295 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7296 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7297 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7298 s1=(1+x(63))/(0.1d0 + dscp1)
7299 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7300 s2=(1+x(65))/(0.1d0 + dscp2)
7301 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7302 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7303 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7304 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7306 c & dscp1,dscp2,sumene
7307 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7308 escloc = escloc + sumene
7309 c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7314 C This section to check the numerical derivatives of the energy of ith side
7315 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7316 C #define DEBUG in the code to turn it on.
7318 write (2,*) "sumene =",sumene
7322 write (2,*) xx,yy,zz
7323 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7324 de_dxx_num=(sumenep-sumene)/aincr
7326 write (2,*) "xx+ sumene from enesc=",sumenep
7329 write (2,*) xx,yy,zz
7330 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7331 de_dyy_num=(sumenep-sumene)/aincr
7333 write (2,*) "yy+ sumene from enesc=",sumenep
7336 write (2,*) xx,yy,zz
7337 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7338 de_dzz_num=(sumenep-sumene)/aincr
7340 write (2,*) "zz+ sumene from enesc=",sumenep
7341 costsave=cost2tab(i+1)
7342 sintsave=sint2tab(i+1)
7343 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7344 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7345 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7346 de_dt_num=(sumenep-sumene)/aincr
7347 write (2,*) " t+ sumene from enesc=",sumenep
7348 cost2tab(i+1)=costsave
7349 sint2tab(i+1)=sintsave
7350 C End of diagnostics section.
7353 C Compute the gradient of esc
7355 c zz=zz*dsign(1.0,dfloat(itype(i)))
7356 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7357 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7358 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7359 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7360 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7361 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7362 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7363 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7364 pom1=(sumene3*sint2tab(i+1)+sumene1)
7365 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7366 pom2=(sumene4*cost2tab(i+1)+sumene2)
7367 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7368 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7369 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7370 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7372 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7373 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7374 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7376 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7377 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7378 & +(pom1+pom2)*pom_dx
7380 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7383 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7384 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7385 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7387 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7388 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7389 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7390 & +x(59)*zz**2 +x(60)*xx*zz
7391 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7392 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7393 & +(pom1-pom2)*pom_dy
7395 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7398 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7399 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7400 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7401 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7402 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7403 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7404 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7405 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7407 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7410 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7411 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7412 & +pom1*pom_dt1+pom2*pom_dt2
7414 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7419 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7420 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7421 cosfac2xx=cosfac2*xx
7422 sinfac2yy=sinfac2*yy
7424 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7426 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7428 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7429 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7430 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7431 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7432 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7433 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7434 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7435 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7436 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7437 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7441 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7442 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7443 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7444 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7447 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7448 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7449 dZZ_XYZ(k)=vbld_inv(i+nres)*
7450 & (z_prime(k)-zz*dC_norm(k,i+nres))
7452 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7453 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7457 dXX_Ctab(k,i)=dXX_Ci(k)
7458 dXX_C1tab(k,i)=dXX_Ci1(k)
7459 dYY_Ctab(k,i)=dYY_Ci(k)
7460 dYY_C1tab(k,i)=dYY_Ci1(k)
7461 dZZ_Ctab(k,i)=dZZ_Ci(k)
7462 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7463 dXX_XYZtab(k,i)=dXX_XYZ(k)
7464 dYY_XYZtab(k,i)=dYY_XYZ(k)
7465 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7469 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7470 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7471 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7472 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7473 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7475 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7476 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7477 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7478 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7479 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7480 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7481 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7482 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7484 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7485 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7487 C to check gradient call subroutine check_grad
7493 c------------------------------------------------------------------------------
7494 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7496 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7497 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7498 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7499 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7501 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7502 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7504 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7505 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7506 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7507 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7508 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7510 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7511 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7512 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7513 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7514 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7516 dsc_i = 0.743d0+x(61)
7518 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7519 & *(xx*cost2+yy*sint2))
7520 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7521 & *(xx*cost2-yy*sint2))
7522 s1=(1+x(63))/(0.1d0 + dscp1)
7523 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7524 s2=(1+x(65))/(0.1d0 + dscp2)
7525 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7526 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7527 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7532 c------------------------------------------------------------------------------
7533 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7535 C This procedure calculates two-body contact function g(rij) and its derivative:
7538 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7541 C where x=(rij-r0ij)/delta
7543 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7546 double precision rij,r0ij,eps0ij,fcont,fprimcont
7547 double precision x,x2,x4,delta
7551 if (x.lt.-1.0D0) then
7554 else if (x.le.1.0D0) then
7557 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7558 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7565 c------------------------------------------------------------------------------
7566 subroutine splinthet(theti,delta,ss,ssder)
7567 implicit real*8 (a-h,o-z)
7568 include 'DIMENSIONS'
7569 include 'COMMON.VAR'
7570 include 'COMMON.GEO'
7573 if (theti.gt.pipol) then
7574 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7576 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7581 c------------------------------------------------------------------------------
7582 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7584 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7585 double precision ksi,ksi2,ksi3,a1,a2,a3
7586 a1=fprim0*delta/(f1-f0)
7592 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7593 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7596 c------------------------------------------------------------------------------
7597 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7599 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7600 double precision ksi,ksi2,ksi3,a1,a2,a3
7605 a2=3*(f1x-f0x)-2*fprim0x*delta
7606 a3=fprim0x*delta-2*(f1x-f0x)
7607 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7610 C-----------------------------------------------------------------------------
7612 C-----------------------------------------------------------------------------
7613 subroutine etor(etors,edihcnstr)
7614 implicit real*8 (a-h,o-z)
7615 include 'DIMENSIONS'
7616 include 'COMMON.VAR'
7617 include 'COMMON.GEO'
7618 include 'COMMON.LOCAL'
7619 include 'COMMON.TORSION'
7620 include 'COMMON.INTERACT'
7621 include 'COMMON.DERIV'
7622 include 'COMMON.CHAIN'
7623 include 'COMMON.NAMES'
7624 include 'COMMON.IOUNITS'
7625 include 'COMMON.FFIELD'
7626 include 'COMMON.TORCNSTR'
7627 include 'COMMON.CONTROL'
7629 C Set lprn=.true. for debugging
7633 do i=iphi_start,iphi_end
7635 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7636 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7637 itori=itortyp(itype(i-2))
7638 itori1=itortyp(itype(i-1))
7641 C Proline-Proline pair is a special case...
7642 if (itori.eq.3 .and. itori1.eq.3) then
7643 if (phii.gt.-dwapi3) then
7645 fac=1.0D0/(1.0D0-cosphi)
7646 etorsi=v1(1,3,3)*fac
7647 etorsi=etorsi+etorsi
7648 etors=etors+etorsi-v1(1,3,3)
7649 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7650 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7653 v1ij=v1(j+1,itori,itori1)
7654 v2ij=v2(j+1,itori,itori1)
7657 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7658 if (energy_dec) etors_ii=etors_ii+
7659 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7660 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7664 v1ij=v1(j,itori,itori1)
7665 v2ij=v2(j,itori,itori1)
7668 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7669 if (energy_dec) etors_ii=etors_ii+
7670 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7671 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7674 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7677 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7678 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7679 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7680 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7681 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7683 ! 6/20/98 - dihedral angle constraints
7686 itori=idih_constr(i)
7689 if (difi.gt.drange(i)) then
7691 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7692 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7693 else if (difi.lt.-drange(i)) then
7695 edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7696 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7698 ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7699 ! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7701 ! write (iout,*) 'edihcnstr',edihcnstr
7704 c------------------------------------------------------------------------------
7705 subroutine etor_d(etors_d)
7709 c----------------------------------------------------------------------------
7711 subroutine etor(etors,edihcnstr)
7712 implicit real*8 (a-h,o-z)
7713 include 'DIMENSIONS'
7714 include 'COMMON.VAR'
7715 include 'COMMON.GEO'
7716 include 'COMMON.LOCAL'
7717 include 'COMMON.TORSION'
7718 include 'COMMON.INTERACT'
7719 include 'COMMON.DERIV'
7720 include 'COMMON.CHAIN'
7721 include 'COMMON.NAMES'
7722 include 'COMMON.IOUNITS'
7723 include 'COMMON.FFIELD'
7724 include 'COMMON.TORCNSTR'
7725 include 'COMMON.CONTROL'
7727 C Set lprn=.true. for debugging
7731 do i=iphi_start,iphi_end
7732 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7733 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7734 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7735 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7736 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7737 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7738 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7739 C For introducing the NH3+ and COO- group please check the etor_d for reference
7742 if (iabs(itype(i)).eq.20) then
7747 itori=itortyp(itype(i-2))
7748 itori1=itortyp(itype(i-1))
7751 C Regular cosine and sine terms
7752 do j=1,nterm(itori,itori1,iblock)
7753 v1ij=v1(j,itori,itori1,iblock)
7754 v2ij=v2(j,itori,itori1,iblock)
7757 etors=etors+v1ij*cosphi+v2ij*sinphi
7758 if (energy_dec) etors_ii=etors_ii+
7759 & v1ij*cosphi+v2ij*sinphi
7760 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7764 C E = SUM ----------------------------------- - v1
7765 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7767 cosphi=dcos(0.5d0*phii)
7768 sinphi=dsin(0.5d0*phii)
7769 do j=1,nlor(itori,itori1,iblock)
7770 vl1ij=vlor1(j,itori,itori1)
7771 vl2ij=vlor2(j,itori,itori1)
7772 vl3ij=vlor3(j,itori,itori1)
7773 pom=vl2ij*cosphi+vl3ij*sinphi
7774 pom1=1.0d0/(pom*pom+1.0d0)
7775 etors=etors+vl1ij*pom1
7776 if (energy_dec) etors_ii=etors_ii+
7779 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7781 C Subtract the constant term
7782 etors=etors-v0(itori,itori1,iblock)
7783 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7784 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7786 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7787 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7788 & (v1(j,itori,itori1,iblock),j=1,6),
7789 & (v2(j,itori,itori1,iblock),j=1,6)
7790 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7791 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7793 ! 6/20/98 - dihedral angle constraints
7795 c do i=1,ndih_constr
7796 do i=idihconstr_start,idihconstr_end
7797 itori=idih_constr(i)
7799 difi=pinorm(phii-phi0(i))
7800 if (difi.gt.drange(i)) then
7802 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7803 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7804 else if (difi.lt.-drange(i)) then
7806 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7807 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7811 if (energy_dec) then
7812 write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7813 & i,itori,rad2deg*phii,
7814 & rad2deg*phi0(i), rad2deg*drange(i),
7815 & rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7818 cd write (iout,*) 'edihcnstr',edihcnstr
7821 c----------------------------------------------------------------------------
7822 subroutine etor_d(etors_d)
7823 C 6/23/01 Compute double torsional energy
7824 implicit real*8 (a-h,o-z)
7825 include 'DIMENSIONS'
7826 include 'COMMON.VAR'
7827 include 'COMMON.GEO'
7828 include 'COMMON.LOCAL'
7829 include 'COMMON.TORSION'
7830 include 'COMMON.INTERACT'
7831 include 'COMMON.DERIV'
7832 include 'COMMON.CHAIN'
7833 include 'COMMON.NAMES'
7834 include 'COMMON.IOUNITS'
7835 include 'COMMON.FFIELD'
7836 include 'COMMON.TORCNSTR'
7838 C Set lprn=.true. for debugging
7842 c write(iout,*) "a tu??"
7843 do i=iphid_start,iphid_end
7844 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7845 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7846 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7847 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7848 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7849 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7850 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7851 & (itype(i+1).eq.ntyp1)) cycle
7852 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7853 itori=itortyp(itype(i-2))
7854 itori1=itortyp(itype(i-1))
7855 itori2=itortyp(itype(i))
7861 if (iabs(itype(i+1)).eq.20) iblock=2
7862 C Iblock=2 Proline type
7863 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7864 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7865 C if (itype(i+1).eq.ntyp1) iblock=3
7866 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7867 C IS or IS NOT need for this
7868 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7869 C is (itype(i-3).eq.ntyp1) ntblock=2
7870 C ntblock is N-terminal blocking group
7872 C Regular cosine and sine terms
7873 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7874 C Example of changes for NH3+ blocking group
7875 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7876 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7877 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7878 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7879 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7880 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7881 cosphi1=dcos(j*phii)
7882 sinphi1=dsin(j*phii)
7883 cosphi2=dcos(j*phii1)
7884 sinphi2=dsin(j*phii1)
7885 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7886 & v2cij*cosphi2+v2sij*sinphi2
7887 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7888 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7890 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7892 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7893 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7894 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7895 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7896 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7897 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7898 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7899 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7900 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7901 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7902 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7903 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7904 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7905 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7908 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7909 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7914 C----------------------------------------------------------------------------------
7915 C The rigorous attempt to derive energy function
7916 subroutine etor_kcc(etors,edihcnstr)
7917 implicit real*8 (a-h,o-z)
7918 include 'DIMENSIONS'
7919 include 'COMMON.VAR'
7920 include 'COMMON.GEO'
7921 include 'COMMON.LOCAL'
7922 include 'COMMON.TORSION'
7923 include 'COMMON.INTERACT'
7924 include 'COMMON.DERIV'
7925 include 'COMMON.CHAIN'
7926 include 'COMMON.NAMES'
7927 include 'COMMON.IOUNITS'
7928 include 'COMMON.FFIELD'
7929 include 'COMMON.TORCNSTR'
7930 include 'COMMON.CONTROL'
7932 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7933 C Set lprn=.true. for debugging
7936 C print *,"wchodze kcc"
7937 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7938 if (tor_mode.ne.2) then
7941 do i=iphi_start,iphi_end
7942 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7943 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7944 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7945 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7946 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7947 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7948 itori=itortyp_kcc(itype(i-2))
7949 itori1=itortyp_kcc(itype(i-1))
7954 sumnonchebyshev=0.0d0
7956 C to avoid multiple devision by 2
7957 c theti22=0.5d0*theta(i)
7958 C theta 12 is the theta_1 /2
7959 C theta 22 is theta_2 /2
7960 c theti12=0.5d0*theta(i-1)
7961 C and appropriate sinus function
7962 sinthet1=dsin(theta(i-1))
7963 sinthet2=dsin(theta(i))
7964 costhet1=dcos(theta(i-1))
7965 costhet2=dcos(theta(i))
7966 c Cosines of halves thetas
7967 costheti12=0.5d0*(1.0d0+costhet1)
7968 costheti22=0.5d0*(1.0d0+costhet2)
7969 C to speed up lets store its mutliplication
7970 sint1t2=sinthet2*sinthet1
7972 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7973 C +d_n*sin(n*gamma)) *
7974 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7975 C we have two sum 1) Non-Chebyshev which is with n and gamma
7977 do j=1,nterm_kcc(itori,itori1)
7979 nval=nterm_kcc_Tb(itori,itori1)
7980 v1ij=v1_kcc(j,itori,itori1)
7981 v2ij=v2_kcc(j,itori,itori1)
7982 c write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7983 C v1ij is c_n and d_n in euation above
7987 sint1t2n=sint1t2n*sint1t2
7988 sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7990 gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7991 & v11_chyb(1,j,itori,itori1),costheti12)
7992 c write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7993 c & " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7994 sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7996 gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7997 & v21_chyb(1,j,itori,itori1),costheti22)
7998 c write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7999 c & " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
8000 sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
8002 gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
8003 & v12_chyb(1,j,itori,itori1),costheti12)
8004 c write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
8005 c & " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
8006 sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
8008 gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
8009 & v22_chyb(1,j,itori,itori1),costheti22)
8010 c write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
8011 c & " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
8012 C etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
8013 C if (energy_dec) etors_ii=etors_ii+
8014 C & v1ij*cosphi+v2ij*sinphi
8015 C glocig is the gradient local i site in gamma
8016 actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
8017 actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
8018 etori=etori+sint1t2n*(actval1+actval2)
8020 & j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
8021 & -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
8022 C now gradient over theta_1
8024 & j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
8025 & sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
8027 & j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
8028 & sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
8030 C now the Czebyshev polinominal sum
8031 c do k=1,nterm_kcc_Tb(itori,itori1)
8032 c thybt1(k)=v1_chyb(k,j,itori,itori1)
8033 c thybt2(k)=v2_chyb(k,j,itori,itori1)
8037 C print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
8039 C & (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
8040 C & dcos(theti22)**2),
8043 C now overal sumation
8044 C print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
8047 C derivative over gamma
8048 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
8049 C derivative over theta1
8050 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
8051 C now derivative over theta2
8052 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
8054 & write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
8055 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
8057 C gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
8058 ! 6/20/98 - dihedral angle constraints
8059 if (tor_mode.ne.2) then
8061 c do i=1,ndih_constr
8062 do i=idihconstr_start,idihconstr_end
8063 itori=idih_constr(i)
8065 difi=pinorm(phii-phi0(i))
8066 if (difi.gt.drange(i)) then
8068 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8069 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8070 else if (difi.lt.-drange(i)) then
8072 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8073 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8082 C The rigorous attempt to derive energy function
8083 subroutine ebend_kcc(etheta,ethetacnstr)
8085 implicit real*8 (a-h,o-z)
8086 include 'DIMENSIONS'
8087 include 'COMMON.VAR'
8088 include 'COMMON.GEO'
8089 include 'COMMON.LOCAL'
8090 include 'COMMON.TORSION'
8091 include 'COMMON.INTERACT'
8092 include 'COMMON.DERIV'
8093 include 'COMMON.CHAIN'
8094 include 'COMMON.NAMES'
8095 include 'COMMON.IOUNITS'
8096 include 'COMMON.FFIELD'
8097 include 'COMMON.TORCNSTR'
8098 include 'COMMON.CONTROL'
8100 double precision thybt1(maxtermkcc)
8101 C Set lprn=.true. for debugging
8104 C print *,"wchodze kcc"
8105 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8106 if (tor_mode.ne.2) etheta=0.0D0
8107 do i=ithet_start,ithet_end
8108 c print *,i,itype(i-1),itype(i),itype(i-2)
8109 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8110 & .or.itype(i).eq.ntyp1) cycle
8111 iti=itortyp_kcc(itype(i-1))
8112 sinthet=dsin(theta(i)/2.0d0)
8113 costhet=dcos(theta(i)/2.0d0)
8114 do j=1,nbend_kcc_Tb(iti)
8115 thybt1(j)=v1bend_chyb(j,iti)
8117 sumth1thyb=tschebyshev
8118 & (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8119 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8121 ihelp=nbend_kcc_Tb(iti)-1
8122 gradthybt1=gradtschebyshev
8123 & (0,ihelp,thybt1(1),costhet)
8124 etheta=etheta+sumth1thyb
8125 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8126 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
8127 & gradthybt1*sinthet*(-0.5d0)
8129 if (tor_mode.ne.2) then
8131 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8132 do i=ithetaconstr_start,ithetaconstr_end
8133 itheta=itheta_constr(i)
8134 thetiii=theta(itheta)
8135 difi=pinorm(thetiii-theta_constr0(i))
8136 if (difi.gt.theta_drange(i)) then
8137 difi=difi-theta_drange(i)
8138 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8139 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8140 & +for_thet_constr(i)*difi**3
8141 else if (difi.lt.-drange(i)) then
8143 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8144 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8145 & +for_thet_constr(i)*difi**3
8149 if (energy_dec) then
8150 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8151 & i,itheta,rad2deg*thetiii,
8152 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8153 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8154 & gloc(itheta+nphi-2,icg)
8160 c------------------------------------------------------------------------------
8161 subroutine eback_sc_corr(esccor)
8162 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8163 c conformational states; temporarily implemented as differences
8164 c between UNRES torsional potentials (dependent on three types of
8165 c residues) and the torsional potentials dependent on all 20 types
8166 c of residues computed from AM1 energy surfaces of terminally-blocked
8167 c amino-acid residues.
8168 implicit real*8 (a-h,o-z)
8169 include 'DIMENSIONS'
8170 include 'COMMON.VAR'
8171 include 'COMMON.GEO'
8172 include 'COMMON.LOCAL'
8173 include 'COMMON.TORSION'
8174 include 'COMMON.SCCOR'
8175 include 'COMMON.INTERACT'
8176 include 'COMMON.DERIV'
8177 include 'COMMON.CHAIN'
8178 include 'COMMON.NAMES'
8179 include 'COMMON.IOUNITS'
8180 include 'COMMON.FFIELD'
8181 include 'COMMON.CONTROL'
8183 C Set lprn=.true. for debugging
8186 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8188 do i=itau_start,itau_end
8189 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8191 isccori=isccortyp(itype(i-2))
8192 isccori1=isccortyp(itype(i-1))
8193 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8195 do intertyp=1,3 !intertyp
8196 cc Added 09 May 2012 (Adasko)
8197 cc Intertyp means interaction type of backbone mainchain correlation:
8198 c 1 = SC...Ca...Ca...Ca
8199 c 2 = Ca...Ca...Ca...SC
8200 c 3 = SC...Ca...Ca...SCi
8202 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8203 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8204 & (itype(i-1).eq.ntyp1)))
8205 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8206 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8207 & .or.(itype(i).eq.ntyp1)))
8208 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8209 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8210 & (itype(i-3).eq.ntyp1)))) cycle
8211 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8212 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8214 do j=1,nterm_sccor(isccori,isccori1)
8215 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8216 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8217 cosphi=dcos(j*tauangle(intertyp,i))
8218 sinphi=dsin(j*tauangle(intertyp,i))
8219 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8220 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8222 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8223 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8225 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8226 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8227 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8228 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8229 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8235 c----------------------------------------------------------------------------
8236 subroutine multibody(ecorr)
8237 C This subroutine calculates multi-body contributions to energy following
8238 C the idea of Skolnick et al. If side chains I and J make a contact and
8239 C at the same time side chains I+1 and J+1 make a contact, an extra
8240 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8241 implicit real*8 (a-h,o-z)
8242 include 'DIMENSIONS'
8243 include 'COMMON.IOUNITS'
8244 include 'COMMON.DERIV'
8245 include 'COMMON.INTERACT'
8246 include 'COMMON.CONTACTS'
8247 double precision gx(3),gx1(3)
8250 C Set lprn=.true. for debugging
8254 write (iout,'(a)') 'Contact function values:'
8256 write (iout,'(i2,20(1x,i2,f10.5))')
8257 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8272 num_conti=num_cont(i)
8273 num_conti1=num_cont(i1)
8278 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8279 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8280 cd & ' ishift=',ishift
8281 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8282 C The system gains extra energy.
8283 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8284 endif ! j1==j+-ishift
8293 c------------------------------------------------------------------------------
8294 double precision function esccorr(i,j,k,l,jj,kk)
8295 implicit real*8 (a-h,o-z)
8296 include 'DIMENSIONS'
8297 include 'COMMON.IOUNITS'
8298 include 'COMMON.DERIV'
8299 include 'COMMON.INTERACT'
8300 include 'COMMON.CONTACTS'
8301 include 'COMMON.SHIELD'
8302 double precision gx(3),gx1(3)
8307 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8308 C Calculate the multi-body contribution to energy.
8309 C Calculate multi-body contributions to the gradient.
8310 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8311 cd & k,l,(gacont(m,kk,k),m=1,3)
8313 gx(m) =ekl*gacont(m,jj,i)
8314 gx1(m)=eij*gacont(m,kk,k)
8315 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8316 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8317 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8318 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8322 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8327 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8333 c------------------------------------------------------------------------------
8334 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8335 C This subroutine calculates multi-body contributions to hydrogen-bonding
8336 implicit real*8 (a-h,o-z)
8337 include 'DIMENSIONS'
8338 include 'COMMON.IOUNITS'
8341 parameter (max_cont=maxconts)
8342 parameter (max_dim=26)
8343 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8344 double precision zapas(max_dim,maxconts,max_fg_procs),
8345 & zapas_recv(max_dim,maxconts,max_fg_procs)
8346 common /przechowalnia/ zapas
8347 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8348 & status_array(MPI_STATUS_SIZE,maxconts*2)
8350 include 'COMMON.SETUP'
8351 include 'COMMON.FFIELD'
8352 include 'COMMON.DERIV'
8353 include 'COMMON.INTERACT'
8354 include 'COMMON.CONTACTS'
8355 include 'COMMON.CONTROL'
8356 include 'COMMON.LOCAL'
8357 double precision gx(3),gx1(3),time00
8360 C Set lprn=.true. for debugging
8365 if (nfgtasks.le.1) goto 30
8367 write (iout,'(a)') 'Contact function values before RECEIVE:'
8369 write (iout,'(2i3,50(1x,i2,f5.2))')
8370 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8371 & j=1,num_cont_hb(i))
8375 do i=1,ntask_cont_from
8378 do i=1,ntask_cont_to
8381 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8383 C Make the list of contacts to send to send to other procesors
8384 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8386 do i=iturn3_start,iturn3_end
8387 c write (iout,*) "make contact list turn3",i," num_cont",
8389 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8391 do i=iturn4_start,iturn4_end
8392 c write (iout,*) "make contact list turn4",i," num_cont",
8394 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8398 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8400 do j=1,num_cont_hb(i)
8403 iproc=iint_sent_local(k,jjc,ii)
8404 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8405 if (iproc.gt.0) then
8406 ncont_sent(iproc)=ncont_sent(iproc)+1
8407 nn=ncont_sent(iproc)
8409 zapas(2,nn,iproc)=jjc
8410 zapas(3,nn,iproc)=facont_hb(j,i)
8411 zapas(4,nn,iproc)=ees0p(j,i)
8412 zapas(5,nn,iproc)=ees0m(j,i)
8413 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8414 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8415 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8416 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8417 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8418 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8419 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8420 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8421 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8422 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8423 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8424 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8425 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8426 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8427 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8428 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8429 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8430 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8431 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8432 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8433 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8440 & "Numbers of contacts to be sent to other processors",
8441 & (ncont_sent(i),i=1,ntask_cont_to)
8442 write (iout,*) "Contacts sent"
8443 do ii=1,ntask_cont_to
8445 iproc=itask_cont_to(ii)
8446 write (iout,*) nn," contacts to processor",iproc,
8447 & " of CONT_TO_COMM group"
8449 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8457 CorrelID1=nfgtasks+fg_rank+1
8459 C Receive the numbers of needed contacts from other processors
8460 do ii=1,ntask_cont_from
8461 iproc=itask_cont_from(ii)
8463 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8464 & FG_COMM,req(ireq),IERR)
8466 c write (iout,*) "IRECV ended"
8468 C Send the number of contacts needed by other processors
8469 do ii=1,ntask_cont_to
8470 iproc=itask_cont_to(ii)
8472 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8473 & FG_COMM,req(ireq),IERR)
8475 c write (iout,*) "ISEND ended"
8476 c write (iout,*) "number of requests (nn)",ireq
8479 & call MPI_Waitall(ireq,req,status_array,ierr)
8481 c & "Numbers of contacts to be received from other processors",
8482 c & (ncont_recv(i),i=1,ntask_cont_from)
8486 do ii=1,ntask_cont_from
8487 iproc=itask_cont_from(ii)
8489 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8490 c & " of CONT_TO_COMM group"
8494 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8495 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8496 c write (iout,*) "ireq,req",ireq,req(ireq)
8499 C Send the contacts to processors that need them
8500 do ii=1,ntask_cont_to
8501 iproc=itask_cont_to(ii)
8503 c write (iout,*) nn," contacts to processor",iproc,
8504 c & " of CONT_TO_COMM group"
8507 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8508 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8509 c write (iout,*) "ireq,req",ireq,req(ireq)
8511 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8515 c write (iout,*) "number of requests (contacts)",ireq
8516 c write (iout,*) "req",(req(i),i=1,4)
8519 & call MPI_Waitall(ireq,req,status_array,ierr)
8520 do iii=1,ntask_cont_from
8521 iproc=itask_cont_from(iii)
8524 write (iout,*) "Received",nn," contacts from processor",iproc,
8525 & " of CONT_FROM_COMM group"
8528 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8533 ii=zapas_recv(1,i,iii)
8534 c Flag the received contacts to prevent double-counting
8535 jj=-zapas_recv(2,i,iii)
8536 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8538 nnn=num_cont_hb(ii)+1
8541 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8542 ees0p(nnn,ii)=zapas_recv(4,i,iii)
8543 ees0m(nnn,ii)=zapas_recv(5,i,iii)
8544 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8545 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8546 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8547 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8548 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8549 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8550 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8551 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8552 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8553 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8554 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8555 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8556 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8557 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8558 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8559 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8560 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8561 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8562 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8563 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8564 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8569 write (iout,'(a)') 'Contact function values after receive:'
8571 write (iout,'(2i3,50(1x,i3,f5.2))')
8572 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8573 & j=1,num_cont_hb(i))
8580 write (iout,'(a)') 'Contact function values:'
8582 write (iout,'(2i3,50(1x,i3,f5.2))')
8583 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8584 & j=1,num_cont_hb(i))
8588 C Remove the loop below after debugging !!!
8595 C Calculate the local-electrostatic correlation terms
8596 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8598 num_conti=num_cont_hb(i)
8599 num_conti1=num_cont_hb(i+1)
8606 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8607 c & ' jj=',jj,' kk=',kk
8608 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8609 & .or. j.lt.0 .and. j1.gt.0) .and.
8610 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8611 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8612 C The system gains extra energy.
8613 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8614 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8615 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8617 else if (j1.eq.j) then
8618 C Contacts I-J and I-(J+1) occur simultaneously.
8619 C The system loses extra energy.
8620 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8625 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8626 c & ' jj=',jj,' kk=',kk
8628 C Contacts I-J and (I+1)-J occur simultaneously.
8629 C The system loses extra energy.
8630 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8637 c------------------------------------------------------------------------------
8638 subroutine add_hb_contact(ii,jj,itask)
8639 implicit real*8 (a-h,o-z)
8640 include "DIMENSIONS"
8641 include "COMMON.IOUNITS"
8644 parameter (max_cont=maxconts)
8645 parameter (max_dim=26)
8646 include "COMMON.CONTACTS"
8647 double precision zapas(max_dim,maxconts,max_fg_procs),
8648 & zapas_recv(max_dim,maxconts,max_fg_procs)
8649 common /przechowalnia/ zapas
8650 integer i,j,ii,jj,iproc,itask(4),nn
8651 c write (iout,*) "itask",itask
8654 if (iproc.gt.0) then
8655 do j=1,num_cont_hb(ii)
8657 c write (iout,*) "i",ii," j",jj," jjc",jjc
8659 ncont_sent(iproc)=ncont_sent(iproc)+1
8660 nn=ncont_sent(iproc)
8661 zapas(1,nn,iproc)=ii
8662 zapas(2,nn,iproc)=jjc
8663 zapas(3,nn,iproc)=facont_hb(j,ii)
8664 zapas(4,nn,iproc)=ees0p(j,ii)
8665 zapas(5,nn,iproc)=ees0m(j,ii)
8666 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8667 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8668 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8669 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8670 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8671 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8672 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8673 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8674 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8675 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8676 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8677 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8678 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8679 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8680 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8681 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8682 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8683 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8684 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8685 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8686 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8694 c------------------------------------------------------------------------------
8695 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8697 C This subroutine calculates multi-body contributions to hydrogen-bonding
8698 implicit real*8 (a-h,o-z)
8699 include 'DIMENSIONS'
8700 include 'COMMON.IOUNITS'
8703 parameter (max_cont=maxconts)
8704 parameter (max_dim=70)
8705 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8706 double precision zapas(max_dim,maxconts,max_fg_procs),
8707 & zapas_recv(max_dim,maxconts,max_fg_procs)
8708 common /przechowalnia/ zapas
8709 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8710 & status_array(MPI_STATUS_SIZE,maxconts*2)
8712 include 'COMMON.SETUP'
8713 include 'COMMON.FFIELD'
8714 include 'COMMON.DERIV'
8715 include 'COMMON.LOCAL'
8716 include 'COMMON.INTERACT'
8717 include 'COMMON.CONTACTS'
8718 include 'COMMON.CHAIN'
8719 include 'COMMON.CONTROL'
8720 include 'COMMON.SHIELD'
8721 double precision gx(3),gx1(3)
8722 integer num_cont_hb_old(maxres)
8724 double precision eello4,eello5,eelo6,eello_turn6
8725 external eello4,eello5,eello6,eello_turn6
8726 C Set lprn=.true. for debugging
8731 num_cont_hb_old(i)=num_cont_hb(i)
8735 if (nfgtasks.le.1) goto 30
8737 write (iout,'(a)') 'Contact function values before RECEIVE:'
8739 write (iout,'(2i3,50(1x,i2,f5.2))')
8740 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8741 & j=1,num_cont_hb(i))
8745 do i=1,ntask_cont_from
8748 do i=1,ntask_cont_to
8751 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8753 C Make the list of contacts to send to send to other procesors
8754 do i=iturn3_start,iturn3_end
8755 c write (iout,*) "make contact list turn3",i," num_cont",
8757 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8759 do i=iturn4_start,iturn4_end
8760 c write (iout,*) "make contact list turn4",i," num_cont",
8762 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8766 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8768 do j=1,num_cont_hb(i)
8771 iproc=iint_sent_local(k,jjc,ii)
8772 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8773 if (iproc.ne.0) then
8774 ncont_sent(iproc)=ncont_sent(iproc)+1
8775 nn=ncont_sent(iproc)
8777 zapas(2,nn,iproc)=jjc
8778 zapas(3,nn,iproc)=d_cont(j,i)
8782 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8787 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8795 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8806 & "Numbers of contacts to be sent to other processors",
8807 & (ncont_sent(i),i=1,ntask_cont_to)
8808 write (iout,*) "Contacts sent"
8809 do ii=1,ntask_cont_to
8811 iproc=itask_cont_to(ii)
8812 write (iout,*) nn," contacts to processor",iproc,
8813 & " of CONT_TO_COMM group"
8815 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8823 CorrelID1=nfgtasks+fg_rank+1
8825 C Receive the numbers of needed contacts from other processors
8826 do ii=1,ntask_cont_from
8827 iproc=itask_cont_from(ii)
8829 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8830 & FG_COMM,req(ireq),IERR)
8832 c write (iout,*) "IRECV ended"
8834 C Send the number of contacts needed by other processors
8835 do ii=1,ntask_cont_to
8836 iproc=itask_cont_to(ii)
8838 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8839 & FG_COMM,req(ireq),IERR)
8841 c write (iout,*) "ISEND ended"
8842 c write (iout,*) "number of requests (nn)",ireq
8845 & call MPI_Waitall(ireq,req,status_array,ierr)
8847 c & "Numbers of contacts to be received from other processors",
8848 c & (ncont_recv(i),i=1,ntask_cont_from)
8852 do ii=1,ntask_cont_from
8853 iproc=itask_cont_from(ii)
8855 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8856 c & " of CONT_TO_COMM group"
8860 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8861 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8862 c write (iout,*) "ireq,req",ireq,req(ireq)
8865 C Send the contacts to processors that need them
8866 do ii=1,ntask_cont_to
8867 iproc=itask_cont_to(ii)
8869 c write (iout,*) nn," contacts to processor",iproc,
8870 c & " of CONT_TO_COMM group"
8873 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8874 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8875 c write (iout,*) "ireq,req",ireq,req(ireq)
8877 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8881 c write (iout,*) "number of requests (contacts)",ireq
8882 c write (iout,*) "req",(req(i),i=1,4)
8885 & call MPI_Waitall(ireq,req,status_array,ierr)
8886 do iii=1,ntask_cont_from
8887 iproc=itask_cont_from(iii)
8890 write (iout,*) "Received",nn," contacts from processor",iproc,
8891 & " of CONT_FROM_COMM group"
8894 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8899 ii=zapas_recv(1,i,iii)
8900 c Flag the received contacts to prevent double-counting
8901 jj=-zapas_recv(2,i,iii)
8902 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8904 nnn=num_cont_hb(ii)+1
8907 d_cont(nnn,ii)=zapas_recv(3,i,iii)
8911 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8916 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8924 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8933 write (iout,'(a)') 'Contact function values after receive:'
8935 write (iout,'(2i3,50(1x,i3,5f6.3))')
8936 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8937 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8944 write (iout,'(a)') 'Contact function values:'
8946 write (iout,'(2i3,50(1x,i2,5f6.3))')
8947 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8948 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8954 C Remove the loop below after debugging !!!
8961 C Calculate the dipole-dipole interaction energies
8962 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8963 do i=iatel_s,iatel_e+1
8964 num_conti=num_cont_hb(i)
8973 C Calculate the local-electrostatic correlation terms
8974 c write (iout,*) "gradcorr5 in eello5 before loop"
8976 c write (iout,'(i5,3f10.5)')
8977 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8979 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8980 c write (iout,*) "corr loop i",i
8982 num_conti=num_cont_hb(i)
8983 num_conti1=num_cont_hb(i+1)
8990 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8991 c & ' jj=',jj,' kk=',kk
8992 c if (j1.eq.j+1 .or. j1.eq.j-1) then
8993 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8994 & .or. j.lt.0 .and. j1.gt.0) .and.
8995 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8996 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8997 C The system gains extra energy.
8999 sqd1=dsqrt(d_cont(jj,i))
9000 sqd2=dsqrt(d_cont(kk,i1))
9001 sred_geom = sqd1*sqd2
9002 IF (sred_geom.lt.cutoff_corr) THEN
9003 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9005 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9006 cd & ' jj=',jj,' kk=',kk
9007 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9008 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9010 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9011 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9014 cd write (iout,*) 'sred_geom=',sred_geom,
9015 cd & ' ekont=',ekont,' fprim=',fprimcont,
9016 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9017 cd write (iout,*) "g_contij",g_contij
9018 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9019 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9020 call calc_eello(i,jp,i+1,jp1,jj,kk)
9021 if (wcorr4.gt.0.0d0)
9022 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9023 CC & *fac_shield(i)**2*fac_shield(j)**2
9024 if (energy_dec.and.wcorr4.gt.0.0d0)
9025 1 write (iout,'(a6,4i5,0pf7.3)')
9026 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9027 c write (iout,*) "gradcorr5 before eello5"
9029 c write (iout,'(i5,3f10.5)')
9030 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9032 if (wcorr5.gt.0.0d0)
9033 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9034 c write (iout,*) "gradcorr5 after eello5"
9036 c write (iout,'(i5,3f10.5)')
9037 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9039 if (energy_dec.and.wcorr5.gt.0.0d0)
9040 1 write (iout,'(a6,4i5,0pf7.3)')
9041 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9042 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9043 cd write(2,*)'ijkl',i,jp,i+1,jp1
9044 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9045 & .or. wturn6.eq.0.0d0))then
9046 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9047 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9048 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9049 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9050 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9051 cd & 'ecorr6=',ecorr6
9052 cd write (iout,'(4e15.5)') sred_geom,
9053 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9054 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9055 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9056 else if (wturn6.gt.0.0d0
9057 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9058 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9059 eturn6=eturn6+eello_turn6(i,jj,kk)
9060 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9061 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9062 cd write (2,*) 'multibody_eello:eturn6',eturn6
9071 num_cont_hb(i)=num_cont_hb_old(i)
9073 c write (iout,*) "gradcorr5 in eello5"
9075 c write (iout,'(i5,3f10.5)')
9076 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9080 c------------------------------------------------------------------------------
9081 subroutine add_hb_contact_eello(ii,jj,itask)
9082 implicit real*8 (a-h,o-z)
9083 include "DIMENSIONS"
9084 include "COMMON.IOUNITS"
9087 parameter (max_cont=maxconts)
9088 parameter (max_dim=70)
9089 include "COMMON.CONTACTS"
9090 double precision zapas(max_dim,maxconts,max_fg_procs),
9091 & zapas_recv(max_dim,maxconts,max_fg_procs)
9092 common /przechowalnia/ zapas
9093 integer i,j,ii,jj,iproc,itask(4),nn
9094 c write (iout,*) "itask",itask
9097 if (iproc.gt.0) then
9098 do j=1,num_cont_hb(ii)
9100 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9102 ncont_sent(iproc)=ncont_sent(iproc)+1
9103 nn=ncont_sent(iproc)
9104 zapas(1,nn,iproc)=ii
9105 zapas(2,nn,iproc)=jjc
9106 zapas(3,nn,iproc)=d_cont(j,ii)
9110 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9115 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9123 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9135 c------------------------------------------------------------------------------
9136 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9137 implicit real*8 (a-h,o-z)
9138 include 'DIMENSIONS'
9139 include 'COMMON.IOUNITS'
9140 include 'COMMON.DERIV'
9141 include 'COMMON.INTERACT'
9142 include 'COMMON.CONTACTS'
9143 include 'COMMON.SHIELD'
9144 include 'COMMON.CONTROL'
9145 double precision gx(3),gx1(3)
9148 C print *,"wchodze",fac_shield(i),shield_mode
9156 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9158 C & fac_shield(i)**2*fac_shield(j)**2
9159 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9160 C Following 4 lines for diagnostics.
9165 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9166 c & 'Contacts ',i,j,
9167 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9168 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9170 C Calculate the multi-body contribution to energy.
9171 C ecorr=ecorr+ekont*ees
9172 C Calculate multi-body contributions to the gradient.
9173 coeffpees0pij=coeffp*ees0pij
9174 coeffmees0mij=coeffm*ees0mij
9175 coeffpees0pkl=coeffp*ees0pkl
9176 coeffmees0mkl=coeffm*ees0mkl
9178 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9179 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9180 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9181 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9182 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9183 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9184 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9185 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9186 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9187 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9188 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9189 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9190 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9191 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9192 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9193 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9194 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9195 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9196 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9197 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9198 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9199 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9200 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9201 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9202 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9207 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9208 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9209 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9210 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9215 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9216 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9217 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9218 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9221 c write (iout,*) "ehbcorr",ekont*ees
9222 C print *,ekont,ees,i,k
9224 C now gradient over shielding
9226 if (shield_mode.gt.0) then
9229 C print *,i,j,fac_shield(i),fac_shield(j),
9230 C &fac_shield(k),fac_shield(l)
9231 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9232 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9233 do ilist=1,ishield_list(i)
9234 iresshield=shield_list(ilist,i)
9236 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9238 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9240 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9241 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9245 do ilist=1,ishield_list(j)
9246 iresshield=shield_list(ilist,j)
9248 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9250 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9252 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9253 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9258 do ilist=1,ishield_list(k)
9259 iresshield=shield_list(ilist,k)
9261 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9263 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9265 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9266 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9270 do ilist=1,ishield_list(l)
9271 iresshield=shield_list(ilist,l)
9273 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9275 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9277 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9278 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9282 C print *,gshieldx(m,iresshield)
9284 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9285 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9286 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9287 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9288 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9289 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9290 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9291 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9293 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9294 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9295 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9296 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9297 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9298 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9299 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9300 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9308 C---------------------------------------------------------------------------
9309 subroutine dipole(i,j,jj)
9310 implicit real*8 (a-h,o-z)
9311 include 'DIMENSIONS'
9312 include 'COMMON.IOUNITS'
9313 include 'COMMON.CHAIN'
9314 include 'COMMON.FFIELD'
9315 include 'COMMON.DERIV'
9316 include 'COMMON.INTERACT'
9317 include 'COMMON.CONTACTS'
9318 include 'COMMON.TORSION'
9319 include 'COMMON.VAR'
9320 include 'COMMON.GEO'
9321 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9323 iti1 = itortyp(itype(i+1))
9324 if (j.lt.nres-1) then
9325 itj1 = itype2loc(itype(j+1))
9330 dipi(iii,1)=Ub2(iii,i)
9331 dipderi(iii)=Ub2der(iii,i)
9332 dipi(iii,2)=b1(iii,i+1)
9333 dipj(iii,1)=Ub2(iii,j)
9334 dipderj(iii)=Ub2der(iii,j)
9335 dipj(iii,2)=b1(iii,j+1)
9339 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9342 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9349 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9353 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9358 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9359 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9361 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9363 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9365 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9370 C---------------------------------------------------------------------------
9371 subroutine calc_eello(i,j,k,l,jj,kk)
9373 C This subroutine computes matrices and vectors needed to calculate
9374 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9376 implicit real*8 (a-h,o-z)
9377 include 'DIMENSIONS'
9378 include 'COMMON.IOUNITS'
9379 include 'COMMON.CHAIN'
9380 include 'COMMON.DERIV'
9381 include 'COMMON.INTERACT'
9382 include 'COMMON.CONTACTS'
9383 include 'COMMON.TORSION'
9384 include 'COMMON.VAR'
9385 include 'COMMON.GEO'
9386 include 'COMMON.FFIELD'
9387 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9388 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9391 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9392 cd & ' jj=',jj,' kk=',kk
9393 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9394 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9395 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9398 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9399 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9402 call transpose2(aa1(1,1),aa1t(1,1))
9403 call transpose2(aa2(1,1),aa2t(1,1))
9406 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9407 & aa1tder(1,1,lll,kkk))
9408 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9409 & aa2tder(1,1,lll,kkk))
9413 C parallel orientation of the two CA-CA-CA frames.
9415 iti=itype2loc(itype(i))
9419 itk1=itype2loc(itype(k+1))
9420 itj=itype2loc(itype(j))
9421 if (l.lt.nres-1) then
9422 itl1=itype2loc(itype(l+1))
9426 C A1 kernel(j+1) A2T
9428 cd write (iout,'(3f10.5,5x,3f10.5)')
9429 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9431 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9432 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9433 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9434 C Following matrices are needed only for 6-th order cumulants
9435 IF (wcorr6.gt.0.0d0) THEN
9436 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9437 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9438 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9439 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9440 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9441 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9442 & ADtEAderx(1,1,1,1,1,1))
9444 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9445 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9446 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9447 & ADtEA1derx(1,1,1,1,1,1))
9449 C End 6-th order cumulants
9452 cd write (2,*) 'In calc_eello6'
9454 cd write (2,*) 'iii=',iii
9456 cd write (2,*) 'kkk=',kkk
9458 cd write (2,'(3(2f10.5),5x)')
9459 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9464 call transpose2(EUgder(1,1,k),auxmat(1,1))
9465 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9466 call transpose2(EUg(1,1,k),auxmat(1,1))
9467 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9468 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9472 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9473 & EAEAderx(1,1,lll,kkk,iii,1))
9477 C A1T kernel(i+1) A2
9478 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9479 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9480 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9481 C Following matrices are needed only for 6-th order cumulants
9482 IF (wcorr6.gt.0.0d0) THEN
9483 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9484 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9485 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9486 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9487 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9488 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9489 & ADtEAderx(1,1,1,1,1,2))
9490 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9491 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9492 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9493 & ADtEA1derx(1,1,1,1,1,2))
9495 C End 6-th order cumulants
9496 call transpose2(EUgder(1,1,l),auxmat(1,1))
9497 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9498 call transpose2(EUg(1,1,l),auxmat(1,1))
9499 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9500 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9504 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9505 & EAEAderx(1,1,lll,kkk,iii,2))
9510 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9511 C They are needed only when the fifth- or the sixth-order cumulants are
9513 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9514 call transpose2(AEA(1,1,1),auxmat(1,1))
9515 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9516 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9517 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9518 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9519 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9520 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9521 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9522 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9523 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9524 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9525 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9526 call transpose2(AEA(1,1,2),auxmat(1,1))
9527 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9528 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9529 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9530 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9531 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9532 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9533 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9534 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9535 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9536 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9537 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9538 C Calculate the Cartesian derivatives of the vectors.
9542 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9543 call matvec2(auxmat(1,1),b1(1,i),
9544 & AEAb1derx(1,lll,kkk,iii,1,1))
9545 call matvec2(auxmat(1,1),Ub2(1,i),
9546 & AEAb2derx(1,lll,kkk,iii,1,1))
9547 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9548 & AEAb1derx(1,lll,kkk,iii,2,1))
9549 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9550 & AEAb2derx(1,lll,kkk,iii,2,1))
9551 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9552 call matvec2(auxmat(1,1),b1(1,j),
9553 & AEAb1derx(1,lll,kkk,iii,1,2))
9554 call matvec2(auxmat(1,1),Ub2(1,j),
9555 & AEAb2derx(1,lll,kkk,iii,1,2))
9556 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9557 & AEAb1derx(1,lll,kkk,iii,2,2))
9558 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9559 & AEAb2derx(1,lll,kkk,iii,2,2))
9566 C Antiparallel orientation of the two CA-CA-CA frames.
9568 iti=itype2loc(itype(i))
9572 itk1=itype2loc(itype(k+1))
9573 itl=itype2loc(itype(l))
9574 itj=itype2loc(itype(j))
9575 if (j.lt.nres-1) then
9576 itj1=itype2loc(itype(j+1))
9580 C A2 kernel(j-1)T A1T
9581 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9582 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9583 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9584 C Following matrices are needed only for 6-th order cumulants
9585 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9586 & j.eq.i+4 .and. l.eq.i+3)) THEN
9587 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9588 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9589 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9590 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9591 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9592 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9593 & ADtEAderx(1,1,1,1,1,1))
9594 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9595 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9596 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9597 & ADtEA1derx(1,1,1,1,1,1))
9599 C End 6-th order cumulants
9600 call transpose2(EUgder(1,1,k),auxmat(1,1))
9601 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9602 call transpose2(EUg(1,1,k),auxmat(1,1))
9603 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9604 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9608 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9609 & EAEAderx(1,1,lll,kkk,iii,1))
9613 C A2T kernel(i+1)T A1
9614 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9615 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9616 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9617 C Following matrices are needed only for 6-th order cumulants
9618 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9619 & j.eq.i+4 .and. l.eq.i+3)) THEN
9620 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9621 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9622 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9623 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9624 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9625 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9626 & ADtEAderx(1,1,1,1,1,2))
9627 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9628 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9629 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9630 & ADtEA1derx(1,1,1,1,1,2))
9632 C End 6-th order cumulants
9633 call transpose2(EUgder(1,1,j),auxmat(1,1))
9634 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9635 call transpose2(EUg(1,1,j),auxmat(1,1))
9636 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9637 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9641 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9642 & EAEAderx(1,1,lll,kkk,iii,2))
9647 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9648 C They are needed only when the fifth- or the sixth-order cumulants are
9650 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9651 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9652 call transpose2(AEA(1,1,1),auxmat(1,1))
9653 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9654 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9655 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9656 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9657 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9658 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9659 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9660 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9661 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9662 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9663 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9664 call transpose2(AEA(1,1,2),auxmat(1,1))
9665 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9666 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9667 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9668 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9669 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9670 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9671 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9672 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9673 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9674 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9675 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9676 C Calculate the Cartesian derivatives of the vectors.
9680 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9681 call matvec2(auxmat(1,1),b1(1,i),
9682 & AEAb1derx(1,lll,kkk,iii,1,1))
9683 call matvec2(auxmat(1,1),Ub2(1,i),
9684 & AEAb2derx(1,lll,kkk,iii,1,1))
9685 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9686 & AEAb1derx(1,lll,kkk,iii,2,1))
9687 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9688 & AEAb2derx(1,lll,kkk,iii,2,1))
9689 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9690 call matvec2(auxmat(1,1),b1(1,l),
9691 & AEAb1derx(1,lll,kkk,iii,1,2))
9692 call matvec2(auxmat(1,1),Ub2(1,l),
9693 & AEAb2derx(1,lll,kkk,iii,1,2))
9694 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9695 & AEAb1derx(1,lll,kkk,iii,2,2))
9696 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9697 & AEAb2derx(1,lll,kkk,iii,2,2))
9706 C---------------------------------------------------------------------------
9707 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9708 & KK,KKderg,AKA,AKAderg,AKAderx)
9712 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9713 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9714 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9719 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9721 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9724 cd if (lprn) write (2,*) 'In kernel'
9726 cd if (lprn) write (2,*) 'kkk=',kkk
9728 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9729 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9731 cd write (2,*) 'lll=',lll
9732 cd write (2,*) 'iii=1'
9734 cd write (2,'(3(2f10.5),5x)')
9735 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9738 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9739 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9741 cd write (2,*) 'lll=',lll
9742 cd write (2,*) 'iii=2'
9744 cd write (2,'(3(2f10.5),5x)')
9745 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9752 C---------------------------------------------------------------------------
9753 double precision function eello4(i,j,k,l,jj,kk)
9754 implicit real*8 (a-h,o-z)
9755 include 'DIMENSIONS'
9756 include 'COMMON.IOUNITS'
9757 include 'COMMON.CHAIN'
9758 include 'COMMON.DERIV'
9759 include 'COMMON.INTERACT'
9760 include 'COMMON.CONTACTS'
9761 include 'COMMON.TORSION'
9762 include 'COMMON.VAR'
9763 include 'COMMON.GEO'
9764 double precision pizda(2,2),ggg1(3),ggg2(3)
9765 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9769 cd print *,'eello4:',i,j,k,l,jj,kk
9770 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
9771 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
9772 cold eij=facont_hb(jj,i)
9773 cold ekl=facont_hb(kk,k)
9775 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9776 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9777 gcorr_loc(k-1)=gcorr_loc(k-1)
9778 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9780 gcorr_loc(l-1)=gcorr_loc(l-1)
9781 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9783 gcorr_loc(j-1)=gcorr_loc(j-1)
9784 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9789 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9790 & -EAEAderx(2,2,lll,kkk,iii,1)
9791 cd derx(lll,kkk,iii)=0.0d0
9795 cd gcorr_loc(l-1)=0.0d0
9796 cd gcorr_loc(j-1)=0.0d0
9797 cd gcorr_loc(k-1)=0.0d0
9799 cd write (iout,*)'Contacts have occurred for peptide groups',
9800 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
9801 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9802 if (j.lt.nres-1) then
9809 if (l.lt.nres-1) then
9817 cgrad ggg1(ll)=eel4*g_contij(ll,1)
9818 cgrad ggg2(ll)=eel4*g_contij(ll,2)
9819 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9820 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9821 cgrad ghalf=0.5d0*ggg1(ll)
9822 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9823 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9824 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9825 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9826 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9827 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9828 cgrad ghalf=0.5d0*ggg2(ll)
9829 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9830 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9831 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9832 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9833 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9834 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9838 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9843 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9848 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9853 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9857 cd write (2,*) iii,gcorr_loc(iii)
9860 cd write (2,*) 'ekont',ekont
9861 cd write (iout,*) 'eello4',ekont*eel4
9864 C---------------------------------------------------------------------------
9865 double precision function eello5(i,j,k,l,jj,kk)
9866 implicit real*8 (a-h,o-z)
9867 include 'DIMENSIONS'
9868 include 'COMMON.IOUNITS'
9869 include 'COMMON.CHAIN'
9870 include 'COMMON.DERIV'
9871 include 'COMMON.INTERACT'
9872 include 'COMMON.CONTACTS'
9873 include 'COMMON.TORSION'
9874 include 'COMMON.VAR'
9875 include 'COMMON.GEO'
9876 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9877 double precision ggg1(3),ggg2(3)
9878 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9883 C /l\ / \ \ / \ / \ / C
9884 C / \ / \ \ / \ / \ / C
9885 C j| o |l1 | o | o| o | | o |o C
9886 C \ |/k\| |/ \| / |/ \| |/ \| C
9887 C \i/ \ / \ / / \ / \ C
9889 C (I) (II) (III) (IV) C
9891 C eello5_1 eello5_2 eello5_3 eello5_4 C
9893 C Antiparallel chains C
9896 C /j\ / \ \ / \ / \ / C
9897 C / \ / \ \ / \ / \ / C
9898 C j1| o |l | o | o| o | | o |o C
9899 C \ |/k\| |/ \| / |/ \| |/ \| C
9900 C \i/ \ / \ / / \ / \ C
9902 C (I) (II) (III) (IV) C
9904 C eello5_1 eello5_2 eello5_3 eello5_4 C
9906 C o denotes a local interaction, vertical lines an electrostatic interaction. C
9908 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9909 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9914 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
9916 itk=itype2loc(itype(k))
9917 itl=itype2loc(itype(l))
9918 itj=itype2loc(itype(j))
9923 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9924 cd & eel5_3_num,eel5_4_num)
9928 derx(lll,kkk,iii)=0.0d0
9932 cd eij=facont_hb(jj,i)
9933 cd ekl=facont_hb(kk,k)
9935 cd write (iout,*)'Contacts have occurred for peptide groups',
9936 cd & i,j,' fcont:',eij,' eij',' and ',k,l
9938 C Contribution from the graph I.
9939 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9940 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9941 call transpose2(EUg(1,1,k),auxmat(1,1))
9942 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9943 vv(1)=pizda(1,1)-pizda(2,2)
9944 vv(2)=pizda(1,2)+pizda(2,1)
9945 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9946 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9947 C Explicit gradient in virtual-dihedral angles.
9948 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9949 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9950 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9951 call transpose2(EUgder(1,1,k),auxmat1(1,1))
9952 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9953 vv(1)=pizda(1,1)-pizda(2,2)
9954 vv(2)=pizda(1,2)+pizda(2,1)
9955 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9956 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9957 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9958 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9959 vv(1)=pizda(1,1)-pizda(2,2)
9960 vv(2)=pizda(1,2)+pizda(2,1)
9962 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9963 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9964 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9966 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9967 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9968 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9970 C Cartesian gradient
9974 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9976 vv(1)=pizda(1,1)-pizda(2,2)
9977 vv(2)=pizda(1,2)+pizda(2,1)
9978 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9979 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9980 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9986 C Contribution from graph II
9987 call transpose2(EE(1,1,k),auxmat(1,1))
9988 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9989 vv(1)=pizda(1,1)+pizda(2,2)
9990 vv(2)=pizda(2,1)-pizda(1,2)
9991 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9992 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9993 C Explicit gradient in virtual-dihedral angles.
9994 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9995 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9996 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9997 vv(1)=pizda(1,1)+pizda(2,2)
9998 vv(2)=pizda(2,1)-pizda(1,2)
10000 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10001 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10002 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10004 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10005 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10006 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10008 C Cartesian gradient
10012 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10014 vv(1)=pizda(1,1)+pizda(2,2)
10015 vv(2)=pizda(2,1)-pizda(1,2)
10016 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10017 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10018 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10026 C Parallel orientation
10027 C Contribution from graph III
10028 call transpose2(EUg(1,1,l),auxmat(1,1))
10029 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10030 vv(1)=pizda(1,1)-pizda(2,2)
10031 vv(2)=pizda(1,2)+pizda(2,1)
10032 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10033 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10034 C Explicit gradient in virtual-dihedral angles.
10035 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10036 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10037 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10038 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10039 vv(1)=pizda(1,1)-pizda(2,2)
10040 vv(2)=pizda(1,2)+pizda(2,1)
10041 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10042 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10043 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10044 call transpose2(EUgder(1,1,l),auxmat1(1,1))
10045 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10046 vv(1)=pizda(1,1)-pizda(2,2)
10047 vv(2)=pizda(1,2)+pizda(2,1)
10048 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10049 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10050 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10051 C Cartesian gradient
10055 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10057 vv(1)=pizda(1,1)-pizda(2,2)
10058 vv(2)=pizda(1,2)+pizda(2,1)
10059 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10060 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10061 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10066 C Contribution from graph IV
10068 call transpose2(EE(1,1,l),auxmat(1,1))
10069 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10070 vv(1)=pizda(1,1)+pizda(2,2)
10071 vv(2)=pizda(2,1)-pizda(1,2)
10072 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10073 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10074 C Explicit gradient in virtual-dihedral angles.
10075 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10076 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10077 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10078 vv(1)=pizda(1,1)+pizda(2,2)
10079 vv(2)=pizda(2,1)-pizda(1,2)
10080 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10081 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10082 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10083 C Cartesian gradient
10087 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10089 vv(1)=pizda(1,1)+pizda(2,2)
10090 vv(2)=pizda(2,1)-pizda(1,2)
10091 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10092 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10093 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10098 C Antiparallel orientation
10099 C Contribution from graph III
10101 call transpose2(EUg(1,1,j),auxmat(1,1))
10102 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10103 vv(1)=pizda(1,1)-pizda(2,2)
10104 vv(2)=pizda(1,2)+pizda(2,1)
10105 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10106 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10107 C Explicit gradient in virtual-dihedral angles.
10108 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10109 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10110 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10111 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10112 vv(1)=pizda(1,1)-pizda(2,2)
10113 vv(2)=pizda(1,2)+pizda(2,1)
10114 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10115 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10116 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10117 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10118 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10119 vv(1)=pizda(1,1)-pizda(2,2)
10120 vv(2)=pizda(1,2)+pizda(2,1)
10121 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10122 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10123 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10124 C Cartesian gradient
10128 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10130 vv(1)=pizda(1,1)-pizda(2,2)
10131 vv(2)=pizda(1,2)+pizda(2,1)
10132 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10133 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10134 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10139 C Contribution from graph IV
10141 call transpose2(EE(1,1,j),auxmat(1,1))
10142 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10143 vv(1)=pizda(1,1)+pizda(2,2)
10144 vv(2)=pizda(2,1)-pizda(1,2)
10145 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10146 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10147 C Explicit gradient in virtual-dihedral angles.
10148 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10149 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10150 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10151 vv(1)=pizda(1,1)+pizda(2,2)
10152 vv(2)=pizda(2,1)-pizda(1,2)
10153 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10154 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10155 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10156 C Cartesian gradient
10160 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10162 vv(1)=pizda(1,1)+pizda(2,2)
10163 vv(2)=pizda(2,1)-pizda(1,2)
10164 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10165 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10166 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10172 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10173 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10174 cd write (2,*) 'ijkl',i,j,k,l
10175 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10176 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10178 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10179 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10180 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10181 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10182 if (j.lt.nres-1) then
10189 if (l.lt.nres-1) then
10199 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10200 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10201 C summed up outside the subrouine as for the other subroutines
10202 C handling long-range interactions. The old code is commented out
10203 C with "cgrad" to keep track of changes.
10205 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10206 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10207 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10208 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10209 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10210 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10211 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10212 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10213 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10214 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10216 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10217 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10218 cgrad ghalf=0.5d0*ggg1(ll)
10220 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10221 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10222 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10223 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10224 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10225 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10226 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10227 cgrad ghalf=0.5d0*ggg2(ll)
10229 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10230 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10231 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10232 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10233 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10234 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10239 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10240 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10245 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10246 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10252 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10257 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10261 cd write (2,*) iii,g_corr5_loc(iii)
10264 cd write (2,*) 'ekont',ekont
10265 cd write (iout,*) 'eello5',ekont*eel5
10268 c--------------------------------------------------------------------------
10269 double precision function eello6(i,j,k,l,jj,kk)
10270 implicit real*8 (a-h,o-z)
10271 include 'DIMENSIONS'
10272 include 'COMMON.IOUNITS'
10273 include 'COMMON.CHAIN'
10274 include 'COMMON.DERIV'
10275 include 'COMMON.INTERACT'
10276 include 'COMMON.CONTACTS'
10277 include 'COMMON.TORSION'
10278 include 'COMMON.VAR'
10279 include 'COMMON.GEO'
10280 include 'COMMON.FFIELD'
10281 double precision ggg1(3),ggg2(3)
10282 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10287 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10295 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10296 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10300 derx(lll,kkk,iii)=0.0d0
10304 cd eij=facont_hb(jj,i)
10305 cd ekl=facont_hb(kk,k)
10311 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10312 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10313 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10314 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10315 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10316 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10318 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10319 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10320 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10321 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10322 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10323 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10327 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10329 C If turn contributions are considered, they will be handled separately.
10330 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10331 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10332 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10333 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10334 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10335 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10336 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10338 if (j.lt.nres-1) then
10345 if (l.lt.nres-1) then
10353 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10354 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10355 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10356 cgrad ghalf=0.5d0*ggg1(ll)
10358 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10359 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10360 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10361 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10362 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10363 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10364 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10365 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10366 cgrad ghalf=0.5d0*ggg2(ll)
10367 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10369 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10370 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10371 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10372 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10373 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10374 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10379 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10380 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10385 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10386 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10392 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10397 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10401 cd write (2,*) iii,g_corr6_loc(iii)
10404 cd write (2,*) 'ekont',ekont
10405 cd write (iout,*) 'eello6',ekont*eel6
10408 c--------------------------------------------------------------------------
10409 double precision function eello6_graph1(i,j,k,l,imat,swap)
10410 implicit real*8 (a-h,o-z)
10411 include 'DIMENSIONS'
10412 include 'COMMON.IOUNITS'
10413 include 'COMMON.CHAIN'
10414 include 'COMMON.DERIV'
10415 include 'COMMON.INTERACT'
10416 include 'COMMON.CONTACTS'
10417 include 'COMMON.TORSION'
10418 include 'COMMON.VAR'
10419 include 'COMMON.GEO'
10420 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10423 common /kutas/ lprn
10424 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10426 C Parallel Antiparallel C
10432 C \ j|/k\| / \ |/k\|l / C
10433 C \ / \ / \ / \ / C
10437 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10438 itk=itype2loc(itype(k))
10439 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10440 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10441 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10442 call transpose2(EUgC(1,1,k),auxmat(1,1))
10443 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10444 vv1(1)=pizda1(1,1)-pizda1(2,2)
10445 vv1(2)=pizda1(1,2)+pizda1(2,1)
10446 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10447 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10448 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10449 s5=scalar2(vv(1),Dtobr2(1,i))
10450 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10451 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10452 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10453 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10454 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10455 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10456 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10457 & +scalar2(vv(1),Dtobr2der(1,i)))
10458 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10459 vv1(1)=pizda1(1,1)-pizda1(2,2)
10460 vv1(2)=pizda1(1,2)+pizda1(2,1)
10461 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10462 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10464 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10465 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10466 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10467 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10468 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10470 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10471 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10472 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10473 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10474 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10476 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10477 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10478 vv1(1)=pizda1(1,1)-pizda1(2,2)
10479 vv1(2)=pizda1(1,2)+pizda1(2,1)
10480 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10481 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10482 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10483 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10492 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10493 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10494 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10495 call transpose2(EUgC(1,1,k),auxmat(1,1))
10496 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10498 vv1(1)=pizda1(1,1)-pizda1(2,2)
10499 vv1(2)=pizda1(1,2)+pizda1(2,1)
10500 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10501 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10502 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10503 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10504 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10505 s5=scalar2(vv(1),Dtobr2(1,i))
10506 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10512 c----------------------------------------------------------------------------
10513 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10514 implicit real*8 (a-h,o-z)
10515 include 'DIMENSIONS'
10516 include 'COMMON.IOUNITS'
10517 include 'COMMON.CHAIN'
10518 include 'COMMON.DERIV'
10519 include 'COMMON.INTERACT'
10520 include 'COMMON.CONTACTS'
10521 include 'COMMON.TORSION'
10522 include 'COMMON.VAR'
10523 include 'COMMON.GEO'
10525 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10526 & auxvec1(2),auxvec2(2),auxmat1(2,2)
10528 common /kutas/ lprn
10529 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10531 C Parallel Antiparallel C
10537 C \ j|/k\| \ |/k\|l C
10542 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10543 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10544 C AL 7/4/01 s1 would occur in the sixth-order moment,
10545 C but not in a cluster cumulant
10547 s1=dip(1,jj,i)*dip(1,kk,k)
10549 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10550 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10551 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10552 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10553 call transpose2(EUg(1,1,k),auxmat(1,1))
10554 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10555 vv(1)=pizda(1,1)-pizda(2,2)
10556 vv(2)=pizda(1,2)+pizda(2,1)
10557 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10558 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10560 eello6_graph2=-(s1+s2+s3+s4)
10562 eello6_graph2=-(s2+s3+s4)
10564 c eello6_graph2=-s3
10565 C Derivatives in gamma(i-1)
10568 s1=dipderg(1,jj,i)*dip(1,kk,k)
10570 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10571 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10572 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10573 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10575 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10577 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10579 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10581 C Derivatives in gamma(k-1)
10583 s1=dip(1,jj,i)*dipderg(1,kk,k)
10585 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10586 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10587 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10588 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10589 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10590 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10591 vv(1)=pizda(1,1)-pizda(2,2)
10592 vv(2)=pizda(1,2)+pizda(2,1)
10593 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10595 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10597 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10599 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10600 C Derivatives in gamma(j-1) or gamma(l-1)
10603 s1=dipderg(3,jj,i)*dip(1,kk,k)
10605 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10606 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10607 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10608 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10609 vv(1)=pizda(1,1)-pizda(2,2)
10610 vv(2)=pizda(1,2)+pizda(2,1)
10611 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10614 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10616 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10619 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10620 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10622 C Derivatives in gamma(l-1) or gamma(j-1)
10625 s1=dip(1,jj,i)*dipderg(3,kk,k)
10627 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10628 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10629 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10630 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10631 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10632 vv(1)=pizda(1,1)-pizda(2,2)
10633 vv(2)=pizda(1,2)+pizda(2,1)
10634 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10637 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10639 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10642 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10643 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10645 C Cartesian derivatives.
10647 write (2,*) 'In eello6_graph2'
10649 write (2,*) 'iii=',iii
10651 write (2,*) 'kkk=',kkk
10653 write (2,'(3(2f10.5),5x)')
10654 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10664 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10666 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10669 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10671 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10672 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10674 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10675 call transpose2(EUg(1,1,k),auxmat(1,1))
10676 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10678 vv(1)=pizda(1,1)-pizda(2,2)
10679 vv(2)=pizda(1,2)+pizda(2,1)
10680 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10681 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10683 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10685 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10688 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10690 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10697 c----------------------------------------------------------------------------
10698 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10699 implicit real*8 (a-h,o-z)
10700 include 'DIMENSIONS'
10701 include 'COMMON.IOUNITS'
10702 include 'COMMON.CHAIN'
10703 include 'COMMON.DERIV'
10704 include 'COMMON.INTERACT'
10705 include 'COMMON.CONTACTS'
10706 include 'COMMON.TORSION'
10707 include 'COMMON.VAR'
10708 include 'COMMON.GEO'
10709 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10711 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10713 C Parallel Antiparallel C
10718 C /| o |o o| o |\ C
10719 C j|/k\| / |/k\|l / C
10724 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10726 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10727 C energy moment and not to the cluster cumulant.
10728 iti=itortyp(itype(i))
10729 if (j.lt.nres-1) then
10730 itj1=itype2loc(itype(j+1))
10734 itk=itype2loc(itype(k))
10735 itk1=itype2loc(itype(k+1))
10736 if (l.lt.nres-1) then
10737 itl1=itype2loc(itype(l+1))
10742 s1=dip(4,jj,i)*dip(4,kk,k)
10744 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10745 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10746 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10747 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10748 call transpose2(EE(1,1,k),auxmat(1,1))
10749 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10750 vv(1)=pizda(1,1)+pizda(2,2)
10751 vv(2)=pizda(2,1)-pizda(1,2)
10752 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10753 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10754 cd & "sum",-(s2+s3+s4)
10756 eello6_graph3=-(s1+s2+s3+s4)
10758 eello6_graph3=-(s2+s3+s4)
10760 c eello6_graph3=-s4
10761 C Derivatives in gamma(k-1)
10762 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10763 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10764 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10765 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10766 C Derivatives in gamma(l-1)
10767 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10768 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10769 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10770 vv(1)=pizda(1,1)+pizda(2,2)
10771 vv(2)=pizda(2,1)-pizda(1,2)
10772 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10773 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10774 C Cartesian derivatives.
10780 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10782 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10785 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10787 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10788 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10790 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10791 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10793 vv(1)=pizda(1,1)+pizda(2,2)
10794 vv(2)=pizda(2,1)-pizda(1,2)
10795 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10797 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10799 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10802 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10804 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10806 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10812 c----------------------------------------------------------------------------
10813 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10814 implicit real*8 (a-h,o-z)
10815 include 'DIMENSIONS'
10816 include 'COMMON.IOUNITS'
10817 include 'COMMON.CHAIN'
10818 include 'COMMON.DERIV'
10819 include 'COMMON.INTERACT'
10820 include 'COMMON.CONTACTS'
10821 include 'COMMON.TORSION'
10822 include 'COMMON.VAR'
10823 include 'COMMON.GEO'
10824 include 'COMMON.FFIELD'
10825 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10826 & auxvec1(2),auxmat1(2,2)
10828 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10830 C Parallel Antiparallel C
10835 C /| o |o o| o |\ C
10836 C \ j|/k\| \ |/k\|l C
10841 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10843 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10844 C energy moment and not to the cluster cumulant.
10845 cd write (2,*) 'eello_graph4: wturn6',wturn6
10846 iti=itype2loc(itype(i))
10847 itj=itype2loc(itype(j))
10848 if (j.lt.nres-1) then
10849 itj1=itype2loc(itype(j+1))
10853 itk=itype2loc(itype(k))
10854 if (k.lt.nres-1) then
10855 itk1=itype2loc(itype(k+1))
10859 itl=itype2loc(itype(l))
10860 if (l.lt.nres-1) then
10861 itl1=itype2loc(itype(l+1))
10865 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10866 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10867 cd & ' itl',itl,' itl1',itl1
10869 if (imat.eq.1) then
10870 s1=dip(3,jj,i)*dip(3,kk,k)
10872 s1=dip(2,jj,j)*dip(2,kk,l)
10875 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10876 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10878 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10879 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10881 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10882 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10884 call transpose2(EUg(1,1,k),auxmat(1,1))
10885 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10886 vv(1)=pizda(1,1)-pizda(2,2)
10887 vv(2)=pizda(2,1)+pizda(1,2)
10888 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10889 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10891 eello6_graph4=-(s1+s2+s3+s4)
10893 eello6_graph4=-(s2+s3+s4)
10895 C Derivatives in gamma(i-1)
10898 if (imat.eq.1) then
10899 s1=dipderg(2,jj,i)*dip(3,kk,k)
10901 s1=dipderg(4,jj,j)*dip(2,kk,l)
10904 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10906 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10907 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10909 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10910 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10912 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10913 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10914 cd write (2,*) 'turn6 derivatives'
10916 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10918 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10922 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10924 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10928 C Derivatives in gamma(k-1)
10930 if (imat.eq.1) then
10931 s1=dip(3,jj,i)*dipderg(2,kk,k)
10933 s1=dip(2,jj,j)*dipderg(4,kk,l)
10936 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10937 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10939 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10940 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10942 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10943 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10945 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10946 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10947 vv(1)=pizda(1,1)-pizda(2,2)
10948 vv(2)=pizda(2,1)+pizda(1,2)
10949 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10950 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10952 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10954 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10958 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10960 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10963 C Derivatives in gamma(j-1) or gamma(l-1)
10964 if (l.eq.j+1 .and. l.gt.1) then
10965 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10966 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10967 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10968 vv(1)=pizda(1,1)-pizda(2,2)
10969 vv(2)=pizda(2,1)+pizda(1,2)
10970 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10971 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10972 else if (j.gt.1) then
10973 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10974 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10975 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10976 vv(1)=pizda(1,1)-pizda(2,2)
10977 vv(2)=pizda(2,1)+pizda(1,2)
10978 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10979 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10980 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10982 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10985 C Cartesian derivatives.
10991 if (imat.eq.1) then
10992 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10994 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10997 if (imat.eq.1) then
10998 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11000 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11004 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11006 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11008 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11009 & b1(1,j+1),auxvec(1))
11010 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11012 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11013 & b1(1,l+1),auxvec(1))
11014 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11016 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11018 vv(1)=pizda(1,1)-pizda(2,2)
11019 vv(2)=pizda(2,1)+pizda(1,2)
11020 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11022 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11024 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11027 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11030 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11033 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11035 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11037 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11041 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11043 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11046 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11048 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11056 c----------------------------------------------------------------------------
11057 double precision function eello_turn6(i,jj,kk)
11058 implicit real*8 (a-h,o-z)
11059 include 'DIMENSIONS'
11060 include 'COMMON.IOUNITS'
11061 include 'COMMON.CHAIN'
11062 include 'COMMON.DERIV'
11063 include 'COMMON.INTERACT'
11064 include 'COMMON.CONTACTS'
11065 include 'COMMON.TORSION'
11066 include 'COMMON.VAR'
11067 include 'COMMON.GEO'
11068 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11069 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11071 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11072 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11073 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11074 C the respective energy moment and not to the cluster cumulant.
11083 iti=itype2loc(itype(i))
11084 itk=itype2loc(itype(k))
11085 itk1=itype2loc(itype(k+1))
11086 itl=itype2loc(itype(l))
11087 itj=itype2loc(itype(j))
11088 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11089 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11090 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11095 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11097 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11101 derx_turn(lll,kkk,iii)=0.0d0
11108 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11110 cd write (2,*) 'eello6_5',eello6_5
11112 call transpose2(AEA(1,1,1),auxmat(1,1))
11113 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11114 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11115 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11117 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11118 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11119 s2 = scalar2(b1(1,k),vtemp1(1))
11121 call transpose2(AEA(1,1,2),atemp(1,1))
11122 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11123 call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11124 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11126 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11127 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11128 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11130 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11131 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11132 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11133 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11134 ss13 = scalar2(b1(1,k),vtemp4(1))
11135 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11137 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11143 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11144 C Derivatives in gamma(i+2)
11148 call transpose2(AEA(1,1,1),auxmatd(1,1))
11149 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11150 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11151 call transpose2(AEAderg(1,1,2),atempd(1,1))
11152 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11153 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11155 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11156 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11157 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11163 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11164 C Derivatives in gamma(i+3)
11166 call transpose2(AEA(1,1,1),auxmatd(1,1))
11167 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11168 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11169 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11171 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11172 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11173 s2d = scalar2(b1(1,k),vtemp1d(1))
11175 call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11176 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11178 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11180 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11181 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11182 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11190 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11191 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11193 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11194 & -0.5d0*ekont*(s2d+s12d)
11196 C Derivatives in gamma(i+4)
11197 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11198 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11199 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11201 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11202 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11203 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11211 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11213 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11215 C Derivatives in gamma(i+5)
11217 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11218 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11219 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11221 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11222 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11223 s2d = scalar2(b1(1,k),vtemp1d(1))
11225 call transpose2(AEA(1,1,2),atempd(1,1))
11226 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11227 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11229 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11230 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11232 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11233 ss13d = scalar2(b1(1,k),vtemp4d(1))
11234 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11242 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11243 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11245 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11246 & -0.5d0*ekont*(s2d+s12d)
11248 C Cartesian derivatives
11253 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11254 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11255 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11257 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11258 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11260 s2d = scalar2(b1(1,k),vtemp1d(1))
11262 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11263 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11264 s8d = -(atempd(1,1)+atempd(2,2))*
11265 & scalar2(cc(1,1,itl),vtemp2(1))
11267 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11269 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11270 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11277 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11278 & - 0.5d0*(s1d+s2d)
11280 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11284 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11285 & - 0.5d0*(s8d+s12d)
11287 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11296 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11297 & achuj_tempd(1,1))
11298 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11299 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11300 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11301 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11302 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11304 ss13d = scalar2(b1(1,k),vtemp4d(1))
11305 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11306 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11310 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11311 cd & 16*eel_turn6_num
11313 if (j.lt.nres-1) then
11320 if (l.lt.nres-1) then
11328 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11329 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11330 cgrad ghalf=0.5d0*ggg1(ll)
11332 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11333 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11334 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11335 & +ekont*derx_turn(ll,2,1)
11336 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11337 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11338 & +ekont*derx_turn(ll,4,1)
11339 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11340 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11341 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11342 cgrad ghalf=0.5d0*ggg2(ll)
11344 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11345 & +ekont*derx_turn(ll,2,2)
11346 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11347 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11348 & +ekont*derx_turn(ll,4,2)
11349 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11350 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11351 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11356 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11361 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11367 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11372 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11376 cd write (2,*) iii,g_corr6_loc(iii)
11378 eello_turn6=ekont*eel_turn6
11379 cd write (2,*) 'ekont',ekont
11380 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11384 C-----------------------------------------------------------------------------
11385 double precision function scalar(u,v)
11386 !DIR$ INLINEALWAYS scalar
11388 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11391 double precision u(3),v(3)
11392 cd double precision sc
11400 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11403 crc-------------------------------------------------
11404 SUBROUTINE MATVEC2(A1,V1,V2)
11405 !DIR$ INLINEALWAYS MATVEC2
11407 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11409 implicit real*8 (a-h,o-z)
11410 include 'DIMENSIONS'
11411 DIMENSION A1(2,2),V1(2),V2(2)
11415 c 3 VI=VI+A1(I,K)*V1(K)
11419 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11420 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11425 C---------------------------------------
11426 SUBROUTINE MATMAT2(A1,A2,A3)
11428 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11430 implicit real*8 (a-h,o-z)
11431 include 'DIMENSIONS'
11432 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11433 c DIMENSION AI3(2,2)
11437 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11443 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11444 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11445 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11446 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11454 c-------------------------------------------------------------------------
11455 double precision function scalar2(u,v)
11456 !DIR$ INLINEALWAYS scalar2
11458 double precision u(2),v(2)
11459 double precision sc
11461 scalar2=u(1)*v(1)+u(2)*v(2)
11465 C-----------------------------------------------------------------------------
11467 subroutine transpose2(a,at)
11468 !DIR$ INLINEALWAYS transpose2
11470 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11473 double precision a(2,2),at(2,2)
11480 c--------------------------------------------------------------------------
11481 subroutine transpose(n,a,at)
11484 double precision a(n,n),at(n,n)
11492 C---------------------------------------------------------------------------
11493 subroutine prodmat3(a1,a2,kk,transp,prod)
11494 !DIR$ INLINEALWAYS prodmat3
11496 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11500 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11502 crc double precision auxmat(2,2),prod_(2,2)
11505 crc call transpose2(kk(1,1),auxmat(1,1))
11506 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11507 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11509 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11510 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11511 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11512 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11513 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11514 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11515 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11516 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11519 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11520 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11522 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11523 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11524 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11525 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11526 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11527 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11528 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11529 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11532 c call transpose2(a2(1,1),a2t(1,1))
11535 crc print *,((prod_(i,j),i=1,2),j=1,2)
11536 crc print *,((prod(i,j),i=1,2),j=1,2)
11540 CCC----------------------------------------------
11541 subroutine Eliptransfer(eliptran)
11542 implicit real*8 (a-h,o-z)
11543 include 'DIMENSIONS'
11544 include 'COMMON.GEO'
11545 include 'COMMON.VAR'
11546 include 'COMMON.LOCAL'
11547 include 'COMMON.CHAIN'
11548 include 'COMMON.DERIV'
11549 include 'COMMON.NAMES'
11550 include 'COMMON.INTERACT'
11551 include 'COMMON.IOUNITS'
11552 include 'COMMON.CALC'
11553 include 'COMMON.CONTROL'
11554 include 'COMMON.SPLITELE'
11555 include 'COMMON.SBRIDGE'
11556 C this is done by Adasko
11557 C print *,"wchodze"
11558 C structure of box:
11560 C--bordliptop-- buffore starts
11561 C--bufliptop--- here true lipid starts
11563 C--buflipbot--- lipid ends buffore starts
11564 C--bordlipbot--buffore ends
11566 do i=ilip_start,ilip_end
11568 if (itype(i).eq.ntyp1) cycle
11570 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11571 if (positi.le.0.0) positi=positi+boxzsize
11573 C first for peptide groups
11574 c for each residue check if it is in lipid or lipid water border area
11575 if ((positi.gt.bordlipbot)
11576 &.and.(positi.lt.bordliptop)) then
11577 C the energy transfer exist
11578 if (positi.lt.buflipbot) then
11579 C what fraction I am in
11581 & ((positi-bordlipbot)/lipbufthick)
11582 C lipbufthick is thickenes of lipid buffore
11583 sslip=sscalelip(fracinbuf)
11584 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11585 eliptran=eliptran+sslip*pepliptran
11586 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11587 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11588 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11590 C print *,"doing sccale for lower part"
11591 C print *,i,sslip,fracinbuf,ssgradlip
11592 elseif (positi.gt.bufliptop) then
11593 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11594 sslip=sscalelip(fracinbuf)
11595 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11596 eliptran=eliptran+sslip*pepliptran
11597 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11598 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11599 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11600 C print *, "doing sscalefor top part"
11601 C print *,i,sslip,fracinbuf,ssgradlip
11603 eliptran=eliptran+pepliptran
11604 C print *,"I am in true lipid"
11607 C eliptran=elpitran+0.0 ! I am in water
11610 C print *, "nic nie bylo w lipidzie?"
11611 C now multiply all by the peptide group transfer factor
11612 C eliptran=eliptran*pepliptran
11613 C now the same for side chains
11615 do i=ilip_start,ilip_end
11616 if (itype(i).eq.ntyp1) cycle
11617 positi=(mod(c(3,i+nres),boxzsize))
11618 if (positi.le.0) positi=positi+boxzsize
11619 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11620 c for each residue check if it is in lipid or lipid water border area
11621 C respos=mod(c(3,i+nres),boxzsize)
11622 C print *,positi,bordlipbot,buflipbot
11623 if ((positi.gt.bordlipbot)
11624 & .and.(positi.lt.bordliptop)) then
11625 C the energy transfer exist
11626 if (positi.lt.buflipbot) then
11628 & ((positi-bordlipbot)/lipbufthick)
11629 C lipbufthick is thickenes of lipid buffore
11630 sslip=sscalelip(fracinbuf)
11631 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11632 eliptran=eliptran+sslip*liptranene(itype(i))
11633 gliptranx(3,i)=gliptranx(3,i)
11634 &+ssgradlip*liptranene(itype(i))
11635 gliptranc(3,i-1)= gliptranc(3,i-1)
11636 &+ssgradlip*liptranene(itype(i))
11637 C print *,"doing sccale for lower part"
11638 elseif (positi.gt.bufliptop) then
11640 &((bordliptop-positi)/lipbufthick)
11641 sslip=sscalelip(fracinbuf)
11642 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11643 eliptran=eliptran+sslip*liptranene(itype(i))
11644 gliptranx(3,i)=gliptranx(3,i)
11645 &+ssgradlip*liptranene(itype(i))
11646 gliptranc(3,i-1)= gliptranc(3,i-1)
11647 &+ssgradlip*liptranene(itype(i))
11648 C print *, "doing sscalefor top part",sslip,fracinbuf
11650 eliptran=eliptran+liptranene(itype(i))
11651 C print *,"I am in true lipid"
11653 endif ! if in lipid or buffor
11655 C eliptran=elpitran+0.0 ! I am in water
11659 C---------------------------------------------------------
11660 C AFM soubroutine for constant force
11661 subroutine AFMforce(Eafmforce)
11662 implicit real*8 (a-h,o-z)
11663 include 'DIMENSIONS'
11664 include 'COMMON.GEO'
11665 include 'COMMON.VAR'
11666 include 'COMMON.LOCAL'
11667 include 'COMMON.CHAIN'
11668 include 'COMMON.DERIV'
11669 include 'COMMON.NAMES'
11670 include 'COMMON.INTERACT'
11671 include 'COMMON.IOUNITS'
11672 include 'COMMON.CALC'
11673 include 'COMMON.CONTROL'
11674 include 'COMMON.SPLITELE'
11675 include 'COMMON.SBRIDGE'
11680 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11681 dist=dist+diffafm(i)**2
11684 Eafmforce=-forceAFMconst*(dist-distafminit)
11686 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11687 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11689 C print *,'AFM',Eafmforce
11692 C---------------------------------------------------------
11693 C AFM subroutine with pseudoconstant velocity
11694 subroutine AFMvel(Eafmforce)
11695 implicit real*8 (a-h,o-z)
11696 include 'DIMENSIONS'
11697 include 'COMMON.GEO'
11698 include 'COMMON.VAR'
11699 include 'COMMON.LOCAL'
11700 include 'COMMON.CHAIN'
11701 include 'COMMON.DERIV'
11702 include 'COMMON.NAMES'
11703 include 'COMMON.INTERACT'
11704 include 'COMMON.IOUNITS'
11705 include 'COMMON.CALC'
11706 include 'COMMON.CONTROL'
11707 include 'COMMON.SPLITELE'
11708 include 'COMMON.SBRIDGE'
11710 C Only for check grad COMMENT if not used for checkgrad
11712 C--------------------------------------------------------
11713 C print *,"wchodze"
11717 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11718 dist=dist+diffafm(i)**2
11721 Eafmforce=0.5d0*forceAFMconst
11722 & *(distafminit+totTafm*velAFMconst-dist)**2
11723 C Eafmforce=-forceAFMconst*(dist-distafminit)
11725 gradafm(i,afmend-1)=-forceAFMconst*
11726 &(distafminit+totTafm*velAFMconst-dist)
11728 gradafm(i,afmbeg-1)=forceAFMconst*
11729 &(distafminit+totTafm*velAFMconst-dist)
11732 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11735 C-----------------------------------------------------------
11736 C first for shielding is setting of function of side-chains
11737 subroutine set_shield_fac
11738 implicit real*8 (a-h,o-z)
11739 include 'DIMENSIONS'
11740 include 'COMMON.CHAIN'
11741 include 'COMMON.DERIV'
11742 include 'COMMON.IOUNITS'
11743 include 'COMMON.SHIELD'
11744 include 'COMMON.INTERACT'
11745 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11746 double precision div77_81/0.974996043d0/,
11747 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11749 C the vector between center of side_chain and peptide group
11750 double precision pep_side(3),long,side_calf(3),
11751 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11752 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11753 C the line belowe needs to be changed for FGPROC>1
11755 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11757 Cif there two consequtive dummy atoms there is no peptide group between them
11758 C the line below has to be changed for FGPROC>1
11761 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11765 C first lets set vector conecting the ithe side-chain with kth side-chain
11766 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11767 C pep_side(j)=2.0d0
11768 C and vector conecting the side-chain with its proper calfa
11769 side_calf(j)=c(j,k+nres)-c(j,k)
11770 C side_calf(j)=2.0d0
11771 pept_group(j)=c(j,i)-c(j,i+1)
11772 C lets have their lenght
11773 dist_pep_side=pep_side(j)**2+dist_pep_side
11774 dist_side_calf=dist_side_calf+side_calf(j)**2
11775 dist_pept_group=dist_pept_group+pept_group(j)**2
11777 dist_pep_side=dsqrt(dist_pep_side)
11778 dist_pept_group=dsqrt(dist_pept_group)
11779 dist_side_calf=dsqrt(dist_side_calf)
11781 pep_side_norm(j)=pep_side(j)/dist_pep_side
11782 side_calf_norm(j)=dist_side_calf
11784 C now sscale fraction
11785 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11786 C print *,buff_shield,"buff"
11788 if (sh_frac_dist.le.0.0) cycle
11789 C If we reach here it means that this side chain reaches the shielding sphere
11790 C Lets add him to the list for gradient
11791 ishield_list(i)=ishield_list(i)+1
11792 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11793 C this list is essential otherwise problem would be O3
11794 shield_list(ishield_list(i),i)=k
11795 C Lets have the sscale value
11796 if (sh_frac_dist.gt.1.0) then
11797 scale_fac_dist=1.0d0
11799 sh_frac_dist_grad(j)=0.0d0
11802 scale_fac_dist=-sh_frac_dist*sh_frac_dist
11803 & *(2.0*sh_frac_dist-3.0d0)
11804 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11805 & /dist_pep_side/buff_shield*0.5
11806 C remember for the final gradient multiply sh_frac_dist_grad(j)
11807 C for side_chain by factor -2 !
11809 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11810 C print *,"jestem",scale_fac_dist,fac_help_scale,
11811 C & sh_frac_dist_grad(j)
11814 C if ((i.eq.3).and.(k.eq.2)) then
11815 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11819 C this is what is now we have the distance scaling now volume...
11820 short=short_r_sidechain(itype(k))
11821 long=long_r_sidechain(itype(k))
11822 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11825 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11826 C costhet_fac=0.0d0
11828 costhet_grad(j)=costhet_fac*pep_side(j)
11830 C remember for the final gradient multiply costhet_grad(j)
11831 C for side_chain by factor -2 !
11832 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11833 C pep_side0pept_group is vector multiplication
11834 pep_side0pept_group=0.0
11836 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11838 cosalfa=(pep_side0pept_group/
11839 & (dist_pep_side*dist_side_calf))
11840 fac_alfa_sin=1.0-cosalfa**2
11841 fac_alfa_sin=dsqrt(fac_alfa_sin)
11842 rkprim=fac_alfa_sin*(long-short)+short
11844 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11845 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11848 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11849 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11850 &*(long-short)/fac_alfa_sin*cosalfa/
11851 &((dist_pep_side*dist_side_calf))*
11852 &((side_calf(j))-cosalfa*
11853 &((pep_side(j)/dist_pep_side)*dist_side_calf))
11855 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11856 &*(long-short)/fac_alfa_sin*cosalfa
11857 &/((dist_pep_side*dist_side_calf))*
11859 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11862 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11865 C now the gradient...
11866 C grad_shield is gradient of Calfa for peptide groups
11867 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11869 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11870 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11872 grad_shield(j,i)=grad_shield(j,i)
11873 C gradient po skalowaniu
11874 & +(sh_frac_dist_grad(j)
11875 C gradient po costhet
11876 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11877 &-scale_fac_dist*(cosphi_grad_long(j))
11878 &/(1.0-cosphi) )*div77_81
11880 C grad_shield_side is Cbeta sidechain gradient
11881 grad_shield_side(j,ishield_list(i),i)=
11882 & (sh_frac_dist_grad(j)*-2.0d0
11883 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11884 & +scale_fac_dist*(cosphi_grad_long(j))
11885 & *2.0d0/(1.0-cosphi))
11886 & *div77_81*VofOverlap
11888 grad_shield_loc(j,ishield_list(i),i)=
11889 & scale_fac_dist*cosphi_grad_loc(j)
11890 & *2.0d0/(1.0-cosphi)
11891 & *div77_81*VofOverlap
11893 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11895 fac_shield(i)=VolumeTotal*div77_81+div4_81
11896 C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11900 C--------------------------------------------------------------------------
11901 double precision function tschebyshev(m,n,x,y)
11903 include "DIMENSIONS"
11905 double precision x(n),y,yy(0:maxvar),aux
11906 c Tschebyshev polynomial. Note that the first term is omitted
11907 c m=0: the constant term is included
11908 c m=1: the constant term is not included
11912 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11921 C--------------------------------------------------------------------------
11922 double precision function gradtschebyshev(m,n,x,y)
11924 include "DIMENSIONS"
11926 double precision x(n+1),y,yy(0:maxvar),aux
11927 c Tschebyshev polynomial. Note that the first term is omitted
11928 c m=0: the constant term is included
11929 c m=1: the constant term is not included
11933 yy(i)=2*y*yy(i-1)-yy(i-2)
11937 aux=aux+x(i+1)*yy(i)*(i+1)
11938 C print *, x(i+1),yy(i),i
11940 gradtschebyshev=aux
11943 C------------------------------------------------------------------------
11944 C first for shielding is setting of function of side-chains
11945 subroutine set_shield_fac2
11946 implicit real*8 (a-h,o-z)
11947 include 'DIMENSIONS'
11948 include 'COMMON.CHAIN'
11949 include 'COMMON.DERIV'
11950 include 'COMMON.IOUNITS'
11951 include 'COMMON.SHIELD'
11952 include 'COMMON.INTERACT'
11953 include 'COMMON.LOCAL'
11955 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11956 double precision div77_81/0.974996043d0/,
11957 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11959 C the vector between center of side_chain and peptide group
11960 double precision pep_side(3),long,side_calf(3),
11961 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11962 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11963 C write(2,*) "ivec",ivec_start,ivec_end
11965 fac_shield(i)=0.0d0
11967 grad_shield(j,i)=0.0d0
11970 C the line belowe needs to be changed for FGPROC>1
11971 do i=ivec_start,ivec_end
11973 C if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11975 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11976 Cif there two consequtive dummy atoms there is no peptide group between them
11977 C the line below has to be changed for FGPROC>1
11980 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11984 C first lets set vector conecting the ithe side-chain with kth side-chain
11985 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11986 C pep_side(j)=2.0d0
11987 C and vector conecting the side-chain with its proper calfa
11988 side_calf(j)=c(j,k+nres)-c(j,k)
11989 C side_calf(j)=2.0d0
11990 pept_group(j)=c(j,i)-c(j,i+1)
11991 C lets have their lenght
11992 dist_pep_side=pep_side(j)**2+dist_pep_side
11993 dist_side_calf=dist_side_calf+side_calf(j)**2
11994 dist_pept_group=dist_pept_group+pept_group(j)**2
11996 dist_pep_side=dsqrt(dist_pep_side)
11997 dist_pept_group=dsqrt(dist_pept_group)
11998 dist_side_calf=dsqrt(dist_side_calf)
12000 pep_side_norm(j)=pep_side(j)/dist_pep_side
12001 side_calf_norm(j)=dist_side_calf
12003 C now sscale fraction
12004 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12005 C print *,buff_shield,"buff"
12007 if (sh_frac_dist.le.0.0) cycle
12008 C print *,ishield_list(i),i
12009 C If we reach here it means that this side chain reaches the shielding sphere
12010 C Lets add him to the list for gradient
12011 ishield_list(i)=ishield_list(i)+1
12012 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12013 C this list is essential otherwise problem would be O3
12014 shield_list(ishield_list(i),i)=k
12015 C Lets have the sscale value
12016 if (sh_frac_dist.gt.1.0) then
12017 scale_fac_dist=1.0d0
12019 sh_frac_dist_grad(j)=0.0d0
12022 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12023 & *(2.0d0*sh_frac_dist-3.0d0)
12024 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12025 & /dist_pep_side/buff_shield*0.5d0
12026 C remember for the final gradient multiply sh_frac_dist_grad(j)
12027 C for side_chain by factor -2 !
12029 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12030 C sh_frac_dist_grad(j)=0.0d0
12031 C scale_fac_dist=1.0d0
12032 C print *,"jestem",scale_fac_dist,fac_help_scale,
12033 C & sh_frac_dist_grad(j)
12036 C this is what is now we have the distance scaling now volume...
12037 short=short_r_sidechain(itype(k))
12038 long=long_r_sidechain(itype(k))
12039 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12040 sinthet=short/dist_pep_side*costhet
12044 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12045 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12046 C & -short/dist_pep_side**2/costhet)
12047 C costhet_fac=0.0d0
12049 costhet_grad(j)=costhet_fac*pep_side(j)
12051 C remember for the final gradient multiply costhet_grad(j)
12052 C for side_chain by factor -2 !
12053 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12054 C pep_side0pept_group is vector multiplication
12055 pep_side0pept_group=0.0d0
12057 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12059 cosalfa=(pep_side0pept_group/
12060 & (dist_pep_side*dist_side_calf))
12061 fac_alfa_sin=1.0d0-cosalfa**2
12062 fac_alfa_sin=dsqrt(fac_alfa_sin)
12063 rkprim=fac_alfa_sin*(long-short)+short
12067 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12069 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12070 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12071 & dist_pep_side**2)
12074 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12075 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12076 &*(long-short)/fac_alfa_sin*cosalfa/
12077 &((dist_pep_side*dist_side_calf))*
12078 &((side_calf(j))-cosalfa*
12079 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12080 C cosphi_grad_long(j)=0.0d0
12081 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12082 &*(long-short)/fac_alfa_sin*cosalfa
12083 &/((dist_pep_side*dist_side_calf))*
12085 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12086 C cosphi_grad_loc(j)=0.0d0
12088 C print *,sinphi,sinthet
12089 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12092 C now the gradient...
12094 grad_shield(j,i)=grad_shield(j,i)
12095 C gradient po skalowaniu
12096 & +(sh_frac_dist_grad(j)*VofOverlap
12097 C gradient po costhet
12098 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12099 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12100 & sinphi/sinthet*costhet*costhet_grad(j)
12101 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12103 C grad_shield_side is Cbeta sidechain gradient
12104 grad_shield_side(j,ishield_list(i),i)=
12105 & (sh_frac_dist_grad(j)*-2.0d0
12107 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12108 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12109 & sinphi/sinthet*costhet*costhet_grad(j)
12110 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12113 grad_shield_loc(j,ishield_list(i),i)=
12114 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12115 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12116 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12120 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12122 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12123 C write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
12127 C-----------------------------------------------------------------------
12128 C-----------------------------------------------------------
12129 C This subroutine is to mimic the histone like structure but as well can be
12130 C utilizet to nanostructures (infinit) small modification has to be used to
12131 C make it finite (z gradient at the ends has to be changes as well as the x,y
12132 C gradient has to be modified at the ends
12133 C The energy function is Kihara potential
12134 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12135 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12136 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12137 C simple Kihara potential
12138 subroutine calctube(Etube)
12139 implicit real*8 (a-h,o-z)
12140 include 'DIMENSIONS'
12141 include 'COMMON.GEO'
12142 include 'COMMON.VAR'
12143 include 'COMMON.LOCAL'
12144 include 'COMMON.CHAIN'
12145 include 'COMMON.DERIV'
12146 include 'COMMON.NAMES'
12147 include 'COMMON.INTERACT'
12148 include 'COMMON.IOUNITS'
12149 include 'COMMON.CALC'
12150 include 'COMMON.CONTROL'
12151 include 'COMMON.SPLITELE'
12152 include 'COMMON.SBRIDGE'
12153 double precision tub_r,vectube(3),enetube(maxres*2)
12155 do i=itube_start,itube_end
12157 enetube(i+nres)=0.0d0
12159 C first we calculate the distance from tube center
12160 C first sugare-phosphate group for NARES this would be peptide group
12162 do i=itube_start,itube_end
12163 C lets ommit dummy atoms for now
12164 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12165 C now calculate distance from center of tube and direction vectors
12169 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12170 vectube(1)=vectube(1)+boxxsize*j
12171 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12172 vectube(2)=vectube(2)+boxysize*j
12174 xminact=abs(vectube(1)-tubecenter(1))
12175 yminact=abs(vectube(2)-tubecenter(2))
12176 if (xmin.gt.xminact) then
12180 if (ymin.gt.yminact) then
12187 vectube(1)=vectube(1)-tubecenter(1)
12188 vectube(2)=vectube(2)-tubecenter(2)
12190 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12191 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12193 C as the tube is infinity we do not calculate the Z-vector use of Z
12196 C now calculte the distance
12197 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12198 C now normalize vector
12199 vectube(1)=vectube(1)/tub_r
12200 vectube(2)=vectube(2)/tub_r
12201 C calculte rdiffrence between r and r0
12204 rdiff6=rdiff**6.0d0
12205 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12206 enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12207 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12208 C print *,rdiff,rdiff6,pep_aa_tube
12209 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12210 C now we calculate gradient
12211 fac=(-12.0d0*pep_aa_tube/rdiff6-
12212 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12213 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12216 C now direction of gg_tube vector
12218 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12219 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12222 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12223 C print *,gg_tube(1,0),"TU"
12226 do i=itube_start,itube_end
12227 C Lets not jump over memory as we use many times iti
12229 C lets ommit dummy atoms for now
12231 C in UNRES uncomment the line below as GLY has no side-chain...
12237 vectube(1)=mod((c(1,i+nres)),boxxsize)
12238 vectube(1)=vectube(1)+boxxsize*j
12239 vectube(2)=mod((c(2,i+nres)),boxysize)
12240 vectube(2)=vectube(2)+boxysize*j
12242 xminact=abs(vectube(1)-tubecenter(1))
12243 yminact=abs(vectube(2)-tubecenter(2))
12244 if (xmin.gt.xminact) then
12248 if (ymin.gt.yminact) then
12255 C write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12257 vectube(1)=vectube(1)-tubecenter(1)
12258 vectube(2)=vectube(2)-tubecenter(2)
12260 C as the tube is infinity we do not calculate the Z-vector use of Z
12263 C now calculte the distance
12264 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12265 C now normalize vector
12266 vectube(1)=vectube(1)/tub_r
12267 vectube(2)=vectube(2)/tub_r
12269 C calculte rdiffrence between r and r0
12272 rdiff6=rdiff**6.0d0
12273 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12274 sc_aa_tube=sc_aa_tube_par(iti)
12275 sc_bb_tube=sc_bb_tube_par(iti)
12276 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12277 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12278 C now we calculate gradient
12279 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12280 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12281 C now direction of gg_tube vector
12283 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12284 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12287 do i=itube_start,itube_end
12288 Etube=Etube+enetube(i)+enetube(i+nres)
12290 C print *,"ETUBE", etube
12293 C TO DO 1) add to total energy
12294 C 2) add to gradient summation
12295 C 3) add reading parameters (AND of course oppening of PARAM file)
12296 C 4) add reading the center of tube
12298 C 6) add to zerograd
12300 C-----------------------------------------------------------------------
12301 C-----------------------------------------------------------
12302 C This subroutine is to mimic the histone like structure but as well can be
12303 C utilizet to nanostructures (infinit) small modification has to be used to
12304 C make it finite (z gradient at the ends has to be changes as well as the x,y
12305 C gradient has to be modified at the ends
12306 C The energy function is Kihara potential
12307 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12308 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12309 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12310 C simple Kihara potential
12311 subroutine calctube2(Etube)
12312 implicit real*8 (a-h,o-z)
12313 include 'DIMENSIONS'
12314 include 'COMMON.GEO'
12315 include 'COMMON.VAR'
12316 include 'COMMON.LOCAL'
12317 include 'COMMON.CHAIN'
12318 include 'COMMON.DERIV'
12319 include 'COMMON.NAMES'
12320 include 'COMMON.INTERACT'
12321 include 'COMMON.IOUNITS'
12322 include 'COMMON.CALC'
12323 include 'COMMON.CONTROL'
12324 include 'COMMON.SPLITELE'
12325 include 'COMMON.SBRIDGE'
12326 double precision tub_r,vectube(3),enetube(maxres*2)
12328 do i=itube_start,itube_end
12330 enetube(i+nres)=0.0d0
12332 C first we calculate the distance from tube center
12333 C first sugare-phosphate group for NARES this would be peptide group
12335 do i=itube_start,itube_end
12336 C lets ommit dummy atoms for now
12338 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12339 C now calculate distance from center of tube and direction vectors
12340 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12341 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12342 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12343 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12344 vectube(1)=vectube(1)-tubecenter(1)
12345 vectube(2)=vectube(2)-tubecenter(2)
12347 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12348 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12350 C as the tube is infinity we do not calculate the Z-vector use of Z
12353 C now calculte the distance
12354 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12355 C now normalize vector
12356 vectube(1)=vectube(1)/tub_r
12357 vectube(2)=vectube(2)/tub_r
12358 C calculte rdiffrence between r and r0
12361 rdiff6=rdiff**6.0d0
12362 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12363 enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12364 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12365 C print *,rdiff,rdiff6,pep_aa_tube
12366 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12367 C now we calculate gradient
12368 fac=(-12.0d0*pep_aa_tube/rdiff6-
12369 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12370 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12373 C now direction of gg_tube vector
12375 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12376 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12379 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12380 C print *,gg_tube(1,0),"TU"
12381 do i=itube_start,itube_end
12382 C Lets not jump over memory as we use many times iti
12384 C lets ommit dummy atoms for now
12386 C in UNRES uncomment the line below as GLY has no side-chain...
12389 vectube(1)=c(1,i+nres)
12390 vectube(1)=mod(vectube(1),boxxsize)
12391 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12392 vectube(2)=c(2,i+nres)
12393 vectube(2)=mod(vectube(2),boxysize)
12394 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12396 vectube(1)=vectube(1)-tubecenter(1)
12397 vectube(2)=vectube(2)-tubecenter(2)
12398 C THIS FRAGMENT MAKES TUBE FINITE
12399 positi=(mod(c(3,i+nres),boxzsize))
12400 if (positi.le.0) positi=positi+boxzsize
12401 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12402 c for each residue check if it is in lipid or lipid water border area
12403 C respos=mod(c(3,i+nres),boxzsize)
12404 print *,positi,bordtubebot,buftubebot,bordtubetop
12405 if ((positi.gt.bordtubebot)
12406 & .and.(positi.lt.bordtubetop)) then
12407 C the energy transfer exist
12408 if (positi.lt.buftubebot) then
12410 & ((positi-bordtubebot)/tubebufthick)
12411 C lipbufthick is thickenes of lipid buffore
12412 sstube=sscalelip(fracinbuf)
12413 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12414 print *,ssgradtube, sstube,tubetranene(itype(i))
12415 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12416 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12417 C &+ssgradtube*tubetranene(itype(i))
12418 C gg_tube(3,i-1)= gg_tube(3,i-1)
12419 C &+ssgradtube*tubetranene(itype(i))
12420 C print *,"doing sccale for lower part"
12421 elseif (positi.gt.buftubetop) then
12423 &((bordtubetop-positi)/tubebufthick)
12424 sstube=sscalelip(fracinbuf)
12425 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12426 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12427 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12428 C &+ssgradtube*tubetranene(itype(i))
12429 C gg_tube(3,i-1)= gg_tube(3,i-1)
12430 C &+ssgradtube*tubetranene(itype(i))
12431 C print *, "doing sscalefor top part",sslip,fracinbuf
12435 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12436 C print *,"I am in true lipid"
12442 endif ! if in lipid or buffor
12443 CEND OF FINITE FRAGMENT
12444 C as the tube is infinity we do not calculate the Z-vector use of Z
12447 C now calculte the distance
12448 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12449 C now normalize vector
12450 vectube(1)=vectube(1)/tub_r
12451 vectube(2)=vectube(2)/tub_r
12452 C calculte rdiffrence between r and r0
12455 rdiff6=rdiff**6.0d0
12456 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12457 sc_aa_tube=sc_aa_tube_par(iti)
12458 sc_bb_tube=sc_bb_tube_par(iti)
12459 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)
12460 & *sstube+enetube(i+nres)
12461 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12462 C now we calculate gradient
12463 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12464 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12465 C now direction of gg_tube vector
12467 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12468 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12470 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12471 &+ssgradtube*enetube(i+nres)/sstube
12472 gg_tube(3,i-1)= gg_tube(3,i-1)
12473 &+ssgradtube*enetube(i+nres)/sstube
12476 do i=itube_start,itube_end
12477 Etube=Etube+enetube(i)+enetube(i+nres)
12479 C print *,"ETUBE", etube
12482 C TO DO 1) add to total energy
12483 C 2) add to gradient summation
12484 C 3) add reading parameters (AND of course oppening of PARAM file)
12485 C 4) add reading the center of tube
12487 C 6) add to zerograd
12490 C#-------------------------------------------------------------------------------
12491 C This subroutine is to mimic the histone like structure but as well can be
12492 C utilizet to nanostructures (infinit) small modification has to be used to
12493 C make it finite (z gradient at the ends has to be changes as well as the x,y
12494 C gradient has to be modified at the ends
12495 C The energy function is Kihara potential
12496 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12497 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12498 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12499 C simple Kihara potential
12500 subroutine calcnano(Etube)
12501 implicit real*8 (a-h,o-z)
12502 include 'DIMENSIONS'
12503 include 'COMMON.GEO'
12504 include 'COMMON.VAR'
12505 include 'COMMON.LOCAL'
12506 include 'COMMON.CHAIN'
12507 include 'COMMON.DERIV'
12508 include 'COMMON.NAMES'
12509 include 'COMMON.INTERACT'
12510 include 'COMMON.IOUNITS'
12511 include 'COMMON.CALC'
12512 include 'COMMON.CONTROL'
12513 include 'COMMON.SPLITELE'
12514 include 'COMMON.SBRIDGE'
12515 double precision tub_r,vectube(3),enetube(maxres*2),
12516 & enecavtube(maxres*2)
12518 do i=itube_start,itube_end
12520 enetube(i+nres)=0.0d0
12522 C first we calculate the distance from tube center
12523 C first sugare-phosphate group for NARES this would be peptide group
12525 do i=itube_start,itube_end
12526 C lets ommit dummy atoms for now
12527 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12528 C now calculate distance from center of tube and direction vectors
12534 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12535 vectube(1)=vectube(1)+boxxsize*j
12536 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12537 vectube(2)=vectube(2)+boxysize*j
12538 vectube(3)=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
12539 vectube(3)=vectube(3)+boxzsize*j
12542 xminact=abs(vectube(1)-tubecenter(1))
12543 yminact=abs(vectube(2)-tubecenter(2))
12544 zminact=abs(vectube(3)-tubecenter(3))
12546 if (xmin.gt.xminact) then
12550 if (ymin.gt.yminact) then
12554 if (zmin.gt.zminact) then
12563 vectube(1)=vectube(1)-tubecenter(1)
12564 vectube(2)=vectube(2)-tubecenter(2)
12565 vectube(3)=vectube(3)-tubecenter(3)
12567 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12568 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12569 C as the tube is infinity we do not calculate the Z-vector use of Z
12572 C now calculte the distance
12573 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12574 C now normalize vector
12575 vectube(1)=vectube(1)/tub_r
12576 vectube(2)=vectube(2)/tub_r
12577 vectube(3)=vectube(3)/tub_r
12578 C calculte rdiffrence between r and r0
12581 rdiff6=rdiff**6.0d0
12582 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12583 enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
12584 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12585 C print *,rdiff,rdiff6,pep_aa_tube
12586 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12587 C now we calculate gradient
12588 fac=(-12.0d0*pep_aa_tube/rdiff6-
12589 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12590 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12593 C now direction of gg_tube vector
12595 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12596 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12600 do i=itube_start,itube_end
12602 C Lets not jump over memory as we use many times iti
12604 C lets ommit dummy atoms for now
12606 C in UNRES uncomment the line below as GLY has no side-chain...
12613 vectube(1)=mod((c(1,i+nres)),boxxsize)
12614 vectube(1)=vectube(1)+boxxsize*j
12615 vectube(2)=mod((c(2,i+nres)),boxysize)
12616 vectube(2)=vectube(2)+boxysize*j
12617 vectube(3)=mod((c(3,i+nres)),boxzsize)
12618 vectube(3)=vectube(3)+boxzsize*j
12621 xminact=abs(vectube(1)-tubecenter(1))
12622 yminact=abs(vectube(2)-tubecenter(2))
12623 zminact=abs(vectube(3)-tubecenter(3))
12625 if (xmin.gt.xminact) then
12629 if (ymin.gt.yminact) then
12633 if (zmin.gt.zminact) then
12642 C write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
12644 vectube(1)=vectube(1)-tubecenter(1)
12645 vectube(2)=vectube(2)-tubecenter(2)
12646 vectube(3)=vectube(3)-tubecenter(3)
12647 C now calculte the distance
12648 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12649 C now normalize vector
12650 vectube(1)=vectube(1)/tub_r
12651 vectube(2)=vectube(2)/tub_r
12652 vectube(3)=vectube(3)/tub_r
12654 C calculte rdiffrence between r and r0
12657 rdiff6=rdiff**6.0d0
12658 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12659 sc_aa_tube=sc_aa_tube_par(iti)
12660 sc_bb_tube=sc_bb_tube_par(iti)
12661 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
12662 C enetube(i+nres)=0.0d0
12663 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12664 C now we calculate gradient
12665 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-
12666 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12668 C now direction of gg_tube vector
12669 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
12670 if (acavtub(iti).eq.0.0d0) then
12675 denominator=(1.0+dcavtub(iti)*rdiff6*rdiff6)
12677 & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
12679 C enecavtube(i)=0.0
12680 faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/sqrt(rdiff))
12681 & *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)
12682 & +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)
12683 & /denominator**2.0d0
12688 print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
12689 & enecavtube(i),faccav
12691 & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
12692 print *,"finene=",enetube(i+nres)+enecavtube(i)
12694 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12695 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12698 C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
12699 C do i=itube_start,itube_end
12702 C if (acavtub(iti).eq.0.0) cycle
12706 do i=itube_start,itube_end
12707 Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i)
12709 C print *,"ETUBE", etube
12712 C TO DO 1) add to total energy
12713 C 2) add to gradient summation
12714 C 3) add reading parameters (AND of course oppening of PARAM file)
12715 C 4) add reading the center of tube
12717 C 6) add to zerograd