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)
404 time_enecalc=time_enecalc+MPI_Wtime()-time00
406 c print *,"Processor",myrank," computed Uconstr"
415 energia(2)=evdw2-evdw2_14
432 energia(8)=eello_turn3
433 energia(9)=eello_turn4
440 energia(19)=edihcnstr
442 energia(20)=Uconst+Uconst_back
445 energia(23)=Eafmforce
446 energia(24)=ethetacnstr
448 c Here are the energies showed per procesor if the are more processors
449 c per molecule then we sum it up in sum_energy subroutine
450 c print *," Processor",myrank," calls SUM_ENERGY"
451 call sum_energy(energia,.true.)
452 if (dyn_ss) call dyn_set_nss
453 c print *," Processor",myrank," left SUM_ENERGY"
455 time_sumene=time_sumene+MPI_Wtime()-time00
459 c-------------------------------------------------------------------------------
460 subroutine sum_energy(energia,reduce)
461 implicit real*8 (a-h,o-z)
466 cMS$ATTRIBUTES C :: proc_proc
472 include 'COMMON.SETUP'
473 include 'COMMON.IOUNITS'
474 double precision energia(0:n_ene),enebuff(0:n_ene+1)
475 include 'COMMON.FFIELD'
476 include 'COMMON.DERIV'
477 include 'COMMON.INTERACT'
478 include 'COMMON.SBRIDGE'
479 include 'COMMON.CHAIN'
481 include 'COMMON.CONTROL'
482 include 'COMMON.TIME1'
485 if (nfgtasks.gt.1 .and. reduce) then
487 write (iout,*) "energies before REDUCE"
488 call enerprint(energia)
492 enebuff(i)=energia(i)
495 call MPI_Barrier(FG_COMM,IERR)
496 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
498 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
499 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
501 write (iout,*) "energies after REDUCE"
502 call enerprint(energia)
505 time_Reduce=time_Reduce+MPI_Wtime()-time00
507 if (fg_rank.eq.0) then
511 evdw2=energia(2)+energia(18)
527 eello_turn3=energia(8)
528 eello_turn4=energia(9)
535 edihcnstr=energia(19)
540 Eafmforce=energia(23)
541 ethetacnstr=energia(24)
544 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
545 & +wang*ebe+wtor*etors+wscloc*escloc
546 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
547 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
548 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
549 & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
550 & +ethetacnstr+wtube*Etube
552 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
553 & +wang*ebe+wtor*etors+wscloc*escloc
554 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
555 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
556 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
557 & +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran
559 & +ethetacnstr+wtube*Etube
565 if (isnan(etot).ne.0) energia(0)=1.0d+99
567 if (isnan(etot)) energia(0)=1.0d+99
572 idumm=proc_proc(etot,i)
574 call proc_proc(etot,i)
576 if(i.eq.1)energia(0)=1.0d+99
583 c-------------------------------------------------------------------------------
584 subroutine sum_gradient
585 implicit real*8 (a-h,o-z)
590 cMS$ATTRIBUTES C :: proc_proc
596 double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
597 & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
598 & ,gloc_scbuf(3,-1:maxres)
599 include 'COMMON.SETUP'
600 include 'COMMON.IOUNITS'
601 include 'COMMON.FFIELD'
602 include 'COMMON.DERIV'
603 include 'COMMON.INTERACT'
604 include 'COMMON.SBRIDGE'
605 include 'COMMON.CHAIN'
607 include 'COMMON.CONTROL'
608 include 'COMMON.TIME1'
609 include 'COMMON.MAXGRAD'
610 include 'COMMON.SCCOR'
615 write (iout,*) "sum_gradient gvdwc, gvdwx"
617 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
618 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
623 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
624 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
625 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
628 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
629 C in virtual-bond-vector coordinates
632 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
634 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
635 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
637 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
639 c write (iout,'(i5,3f10.5,2x,f10.5)')
640 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
642 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
644 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
645 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
653 gradbufc(j,i)=wsc*gvdwc(j,i)+
654 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
655 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
656 & wel_loc*gel_loc_long(j,i)+
657 & wcorr*gradcorr_long(j,i)+
658 & wcorr5*gradcorr5_long(j,i)+
659 & wcorr6*gradcorr6_long(j,i)+
660 & wturn6*gcorr6_turn_long(j,i)+
662 & +wliptran*gliptranc(j,i)
664 & +welec*gshieldc(j,i)
665 & +wcorr*gshieldc_ec(j,i)
666 & +wturn3*gshieldc_t3(j,i)
667 & +wturn4*gshieldc_t4(j,i)
668 & +wel_loc*gshieldc_ll(j,i)
669 & +wtube*gg_tube(j,i)
678 gradbufc(j,i)=wsc*gvdwc(j,i)+
679 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
680 & welec*gelc_long(j,i)+
682 & wel_loc*gel_loc_long(j,i)+
683 & wcorr*gradcorr_long(j,i)+
684 & wcorr5*gradcorr5_long(j,i)+
685 & wcorr6*gradcorr6_long(j,i)+
686 & wturn6*gcorr6_turn_long(j,i)+
688 & +wliptran*gliptranc(j,i)
690 & +welec*gshieldc(j,i)
691 & +wcorr*gshieldc_ec(j,i)
692 & +wturn4*gshieldc_t4(j,i)
693 & +wel_loc*gshieldc_ll(j,i)
694 & +wtube*gg_tube(j,i)
702 if (nfgtasks.gt.1) then
705 write (iout,*) "gradbufc before allreduce"
707 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
713 gradbufc_sum(j,i)=gradbufc(j,i)
716 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
717 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
718 c time_reduce=time_reduce+MPI_Wtime()-time00
720 c write (iout,*) "gradbufc_sum after allreduce"
722 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
727 c time_allreduce=time_allreduce+MPI_Wtime()-time00
735 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
736 write (iout,*) (i," jgrad_start",jgrad_start(i),
737 & " jgrad_end ",jgrad_end(i),
738 & i=igrad_start,igrad_end)
741 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
742 c do not parallelize this part.
744 c do i=igrad_start,igrad_end
745 c do j=jgrad_start(i),jgrad_end(i)
747 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
752 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
756 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
760 write (iout,*) "gradbufc after summing"
762 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
769 write (iout,*) "gradbufc"
771 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
777 gradbufc_sum(j,i)=gradbufc(j,i)
782 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
786 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
791 c gradbufc(k,i)=0.0d0
795 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
800 write (iout,*) "gradbufc after summing"
802 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
810 gradbufc(k,nres)=0.0d0
815 C print *,gradbufc(1,13)
816 C print *,welec*gelc(1,13)
817 C print *,wel_loc*gel_loc(1,13)
818 C print *,0.5d0*(wscp*gvdwc_scpp(1,13))
819 C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
820 C print *,wel_loc*gel_loc_long(1,13)
821 C print *,gradafm(1,13),"AFM"
822 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
823 & wel_loc*gel_loc(j,i)+
824 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
825 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
826 & wel_loc*gel_loc_long(j,i)+
827 & wcorr*gradcorr_long(j,i)+
828 & wcorr5*gradcorr5_long(j,i)+
829 & wcorr6*gradcorr6_long(j,i)+
830 & wturn6*gcorr6_turn_long(j,i))+
832 & wcorr*gradcorr(j,i)+
833 & wturn3*gcorr3_turn(j,i)+
834 & wturn4*gcorr4_turn(j,i)+
835 & wcorr5*gradcorr5(j,i)+
836 & wcorr6*gradcorr6(j,i)+
837 & wturn6*gcorr6_turn(j,i)+
838 & wsccor*gsccorc(j,i)
839 & +wscloc*gscloc(j,i)
840 & +wliptran*gliptranc(j,i)
842 & +welec*gshieldc(j,i)
843 & +welec*gshieldc_loc(j,i)
844 & +wcorr*gshieldc_ec(j,i)
845 & +wcorr*gshieldc_loc_ec(j,i)
846 & +wturn3*gshieldc_t3(j,i)
847 & +wturn3*gshieldc_loc_t3(j,i)
848 & +wturn4*gshieldc_t4(j,i)
849 & +wturn4*gshieldc_loc_t4(j,i)
850 & +wel_loc*gshieldc_ll(j,i)
851 & +wel_loc*gshieldc_loc_ll(j,i)
852 & +wtube*gg_tube(j,i)
855 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
856 & wel_loc*gel_loc(j,i)+
857 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
858 & welec*gelc_long(j,i)+
859 & wel_loc*gel_loc_long(j,i)+
860 & wcorr*gcorr_long(j,i)+
861 & wcorr5*gradcorr5_long(j,i)+
862 & wcorr6*gradcorr6_long(j,i)+
863 & wturn6*gcorr6_turn_long(j,i))+
865 & wcorr*gradcorr(j,i)+
866 & wturn3*gcorr3_turn(j,i)+
867 & wturn4*gcorr4_turn(j,i)+
868 & wcorr5*gradcorr5(j,i)+
869 & wcorr6*gradcorr6(j,i)+
870 & wturn6*gcorr6_turn(j,i)+
871 & wsccor*gsccorc(j,i)
872 & +wscloc*gscloc(j,i)
873 & +wliptran*gliptranc(j,i)
875 & +welec*gshieldc(j,i)
876 & +welec*gshieldc_loc(j,i)
877 & +wcorr*gshieldc_ec(j,i)
878 & +wcorr*gshieldc_loc_ec(j,i)
879 & +wturn3*gshieldc_t3(j,i)
880 & +wturn3*gshieldc_loc_t3(j,i)
881 & +wturn4*gshieldc_t4(j,i)
882 & +wturn4*gshieldc_loc_t4(j,i)
883 & +wel_loc*gshieldc_ll(j,i)
884 & +wel_loc*gshieldc_loc_ll(j,i)
885 & +wtube*gg_tube(j,i)
889 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
891 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
892 & wsccor*gsccorx(j,i)
893 & +wscloc*gsclocx(j,i)
894 & +wliptran*gliptranx(j,i)
895 & +welec*gshieldx(j,i)
896 & +wcorr*gshieldx_ec(j,i)
897 & +wturn3*gshieldx_t3(j,i)
898 & +wturn4*gshieldx_t4(j,i)
899 & +wel_loc*gshieldx_ll(j,i)
900 & +wtube*gg_tube_sc(j,i)
907 write (iout,*) "gloc before adding corr"
909 write (iout,*) i,gloc(i,icg)
913 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
914 & +wcorr5*g_corr5_loc(i)
915 & +wcorr6*g_corr6_loc(i)
916 & +wturn4*gel_loc_turn4(i)
917 & +wturn3*gel_loc_turn3(i)
918 & +wturn6*gel_loc_turn6(i)
919 & +wel_loc*gel_loc_loc(i)
922 write (iout,*) "gloc after adding corr"
924 write (iout,*) i,gloc(i,icg)
928 if (nfgtasks.gt.1) then
931 gradbufc(j,i)=gradc(j,i,icg)
932 gradbufx(j,i)=gradx(j,i,icg)
936 glocbuf(i)=gloc(i,icg)
940 write (iout,*) "gloc_sc before reduce"
943 write (iout,*) i,j,gloc_sc(j,i,icg)
950 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
954 call MPI_Barrier(FG_COMM,IERR)
955 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
957 call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
958 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
959 call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
960 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
961 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
962 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
963 time_reduce=time_reduce+MPI_Wtime()-time00
964 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
965 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
966 time_reduce=time_reduce+MPI_Wtime()-time00
969 write (iout,*) "gloc_sc after reduce"
972 write (iout,*) i,j,gloc_sc(j,i,icg)
978 write (iout,*) "gloc after reduce"
980 write (iout,*) i,gloc(i,icg)
985 if (gnorm_check) then
987 c Compute the maximum elements of the gradient
997 gcorr3_turn_max=0.0d0
998 gcorr4_turn_max=0.0d0
1001 gcorr6_turn_max=0.0d0
1011 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1012 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1013 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1014 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1015 & gvdwc_scp_max=gvdwc_scp_norm
1016 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1017 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1018 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1019 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1020 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1021 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1022 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1023 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1024 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1025 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1026 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1027 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1028 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1029 & gcorr3_turn(1,i)))
1030 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1031 & gcorr3_turn_max=gcorr3_turn_norm
1032 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1033 & gcorr4_turn(1,i)))
1034 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1035 & gcorr4_turn_max=gcorr4_turn_norm
1036 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1037 if (gradcorr5_norm.gt.gradcorr5_max)
1038 & gradcorr5_max=gradcorr5_norm
1039 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1040 if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1041 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1042 & gcorr6_turn(1,i)))
1043 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1044 & gcorr6_turn_max=gcorr6_turn_norm
1045 gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1046 if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1047 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1048 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1049 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1050 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1051 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1052 if (gradx_scp_norm.gt.gradx_scp_max)
1053 & gradx_scp_max=gradx_scp_norm
1054 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1055 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1056 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1057 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1058 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1059 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1060 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1061 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1065 open(istat,file=statname,position="append")
1067 open(istat,file=statname,access="append")
1069 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1070 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1071 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1072 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1073 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1074 & gsccorx_max,gsclocx_max
1076 if (gvdwc_max.gt.1.0d4) then
1077 write (iout,*) "gvdwc gvdwx gradb gradbx"
1079 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1080 & gradb(j,i),gradbx(j,i),j=1,3)
1082 call pdbout(0.0d0,'cipiszcze',iout)
1088 write (iout,*) "gradc gradx gloc"
1090 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1091 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1095 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1099 c-------------------------------------------------------------------------------
1100 subroutine rescale_weights(t_bath)
1101 implicit real*8 (a-h,o-z)
1102 include 'DIMENSIONS'
1103 include 'COMMON.IOUNITS'
1104 include 'COMMON.FFIELD'
1105 include 'COMMON.SBRIDGE'
1106 include 'COMMON.CONTROL'
1107 double precision kfac /2.4d0/
1108 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1110 c facT=2*temp0/(t_bath+temp0)
1111 if (rescale_mode.eq.0) then
1117 else if (rescale_mode.eq.1) then
1118 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1119 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1120 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1121 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1122 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1123 else if (rescale_mode.eq.2) then
1129 facT=licznik/dlog(dexp(x)+dexp(-x))
1130 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1131 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1132 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1133 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1135 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1136 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1138 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1142 if (shield_mode.gt.0) then
1143 wscp=weights(2)*fact
1145 wvdwpp=weights(16)*fact
1147 welec=weights(3)*fact
1148 wcorr=weights(4)*fact3
1149 wcorr5=weights(5)*fact4
1150 wcorr6=weights(6)*fact5
1151 wel_loc=weights(7)*fact2
1152 wturn3=weights(8)*fact2
1153 wturn4=weights(9)*fact3
1154 wturn6=weights(10)*fact5
1155 wtor=weights(13)*fact
1156 wtor_d=weights(14)*fact2
1157 wsccor=weights(21)*fact
1161 C------------------------------------------------------------------------
1162 subroutine enerprint(energia)
1163 implicit real*8 (a-h,o-z)
1164 include 'DIMENSIONS'
1165 include 'COMMON.IOUNITS'
1166 include 'COMMON.FFIELD'
1167 include 'COMMON.SBRIDGE'
1169 double precision energia(0:n_ene)
1174 evdw2=energia(2)+energia(18)
1186 eello_turn3=energia(8)
1187 eello_turn4=energia(9)
1188 eello_turn6=energia(10)
1194 edihcnstr=energia(19)
1198 eliptran=energia(22)
1199 Eafmforce=energia(23)
1200 ethetacnstr=energia(24)
1203 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1204 & estr,wbond,ebe,wang,
1205 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1207 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1208 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1209 & ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1212 10 format (/'Virtual-chain energies:'//
1213 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1214 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1215 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1216 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1217 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1218 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1219 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1220 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1221 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1222 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
1223 & ' (SS bridges & dist. cnstr.)'/
1224 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1225 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1226 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1227 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1228 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1229 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1230 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1231 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1232 & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1233 & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1234 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1235 & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1236 & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1237 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1238 & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1239 & 'ETOT= ',1pE16.6,' (total)')
1242 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1243 & estr,wbond,ebe,wang,
1244 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1246 & ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1247 & eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1248 & ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,
1251 10 format (/'Virtual-chain energies:'//
1252 & 'EVDW= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1253 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1254 & 'EES= ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1255 & 'ESTR= ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1256 & 'EBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1257 & 'ESC= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1258 & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1259 & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1260 & 'EHBP= ',1pE16.6,' WEIGHT=',1pD16.6,
1261 & ' (SS bridges & dist. cnstr.)'/
1262 & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1263 & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1264 & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1265 & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1266 & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1267 & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1268 & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1269 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1270 & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1271 & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1272 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1273 & 'UCONST=',1pE16.6,' (Constraint energy)'/
1274 & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
1275 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1276 & 'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/
1277 & 'ETOT= ',1pE16.6,' (total)')
1281 C-----------------------------------------------------------------------
1282 subroutine elj(evdw)
1284 C This subroutine calculates the interaction energy of nonbonded side chains
1285 C assuming the LJ potential of interaction.
1287 implicit real*8 (a-h,o-z)
1288 include 'DIMENSIONS'
1289 parameter (accur=1.0d-10)
1290 include 'COMMON.GEO'
1291 include 'COMMON.VAR'
1292 include 'COMMON.LOCAL'
1293 include 'COMMON.CHAIN'
1294 include 'COMMON.DERIV'
1295 include 'COMMON.INTERACT'
1296 include 'COMMON.TORSION'
1297 include 'COMMON.SBRIDGE'
1298 include 'COMMON.NAMES'
1299 include 'COMMON.IOUNITS'
1300 include 'COMMON.CONTACTS'
1302 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1304 do i=iatsc_s,iatsc_e
1305 itypi=iabs(itype(i))
1306 if (itypi.eq.ntyp1) cycle
1307 itypi1=iabs(itype(i+1))
1314 C Calculate SC interaction energy.
1316 do iint=1,nint_gr(i)
1317 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1318 cd & 'iend=',iend(i,iint)
1319 do j=istart(i,iint),iend(i,iint)
1320 itypj=iabs(itype(j))
1321 if (itypj.eq.ntyp1) cycle
1325 C Change 12/1/95 to calculate four-body interactions
1326 rij=xj*xj+yj*yj+zj*zj
1328 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1329 eps0ij=eps(itypi,itypj)
1331 C have you changed here?
1335 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1336 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1337 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1338 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1339 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1340 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1343 C Calculate the components of the gradient in DC and X
1345 fac=-rrij*(e1+evdwij)
1350 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1351 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1352 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1353 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1357 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1361 C 12/1/95, revised on 5/20/97
1363 C Calculate the contact function. The ith column of the array JCONT will
1364 C contain the numbers of atoms that make contacts with the atom I (of numbers
1365 C greater than I). The arrays FACONT and GACONT will contain the values of
1366 C the contact function and its derivative.
1368 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1369 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1370 C Uncomment next line, if the correlation interactions are contact function only
1371 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1373 sigij=sigma(itypi,itypj)
1374 r0ij=rs0(itypi,itypj)
1376 C Check whether the SC's are not too far to make a contact.
1379 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1380 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1382 if (fcont.gt.0.0D0) then
1383 C If the SC-SC distance if close to sigma, apply spline.
1384 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1385 cAdam & fcont1,fprimcont1)
1386 cAdam fcont1=1.0d0-fcont1
1387 cAdam if (fcont1.gt.0.0d0) then
1388 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1389 cAdam fcont=fcont*fcont1
1391 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1392 cga eps0ij=1.0d0/dsqrt(eps0ij)
1394 cga gg(k)=gg(k)*eps0ij
1396 cga eps0ij=-evdwij*eps0ij
1397 C Uncomment for AL's type of SC correlation interactions.
1398 cadam eps0ij=-evdwij
1399 num_conti=num_conti+1
1400 jcont(num_conti,i)=j
1401 facont(num_conti,i)=fcont*eps0ij
1402 fprimcont=eps0ij*fprimcont/rij
1404 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1405 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1406 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1407 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1408 gacont(1,num_conti,i)=-fprimcont*xj
1409 gacont(2,num_conti,i)=-fprimcont*yj
1410 gacont(3,num_conti,i)=-fprimcont*zj
1411 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1412 cd write (iout,'(2i3,3f10.5)')
1413 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1419 num_cont(i)=num_conti
1423 gvdwc(j,i)=expon*gvdwc(j,i)
1424 gvdwx(j,i)=expon*gvdwx(j,i)
1427 C******************************************************************************
1431 C To save time, the factor of EXPON has been extracted from ALL components
1432 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1435 C******************************************************************************
1438 C-----------------------------------------------------------------------------
1439 subroutine eljk(evdw)
1441 C This subroutine calculates the interaction energy of nonbonded side chains
1442 C assuming the LJK potential of interaction.
1444 implicit real*8 (a-h,o-z)
1445 include 'DIMENSIONS'
1446 include 'COMMON.GEO'
1447 include 'COMMON.VAR'
1448 include 'COMMON.LOCAL'
1449 include 'COMMON.CHAIN'
1450 include 'COMMON.DERIV'
1451 include 'COMMON.INTERACT'
1452 include 'COMMON.IOUNITS'
1453 include 'COMMON.NAMES'
1456 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1458 do i=iatsc_s,iatsc_e
1459 itypi=iabs(itype(i))
1460 if (itypi.eq.ntyp1) cycle
1461 itypi1=iabs(itype(i+1))
1466 C Calculate SC interaction energy.
1468 do iint=1,nint_gr(i)
1469 do j=istart(i,iint),iend(i,iint)
1470 itypj=iabs(itype(j))
1471 if (itypj.eq.ntyp1) cycle
1475 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1476 fac_augm=rrij**expon
1477 e_augm=augm(itypi,itypj)*fac_augm
1478 r_inv_ij=dsqrt(rrij)
1480 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1481 fac=r_shift_inv**expon
1482 C have you changed here?
1486 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1487 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1488 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1489 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1490 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1491 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1492 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1495 C Calculate the components of the gradient in DC and X
1497 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1502 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1503 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1504 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1505 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1509 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1517 gvdwc(j,i)=expon*gvdwc(j,i)
1518 gvdwx(j,i)=expon*gvdwx(j,i)
1523 C-----------------------------------------------------------------------------
1524 subroutine ebp(evdw)
1526 C This subroutine calculates the interaction energy of nonbonded side chains
1527 C assuming the Berne-Pechukas potential of interaction.
1529 implicit real*8 (a-h,o-z)
1530 include 'DIMENSIONS'
1531 include 'COMMON.GEO'
1532 include 'COMMON.VAR'
1533 include 'COMMON.LOCAL'
1534 include 'COMMON.CHAIN'
1535 include 'COMMON.DERIV'
1536 include 'COMMON.NAMES'
1537 include 'COMMON.INTERACT'
1538 include 'COMMON.IOUNITS'
1539 include 'COMMON.CALC'
1540 common /srutu/ icall
1541 c double precision rrsave(maxdim)
1544 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1546 c if (icall.eq.0) then
1552 do i=iatsc_s,iatsc_e
1553 itypi=iabs(itype(i))
1554 if (itypi.eq.ntyp1) cycle
1555 itypi1=iabs(itype(i+1))
1559 dxi=dc_norm(1,nres+i)
1560 dyi=dc_norm(2,nres+i)
1561 dzi=dc_norm(3,nres+i)
1562 c dsci_inv=dsc_inv(itypi)
1563 dsci_inv=vbld_inv(i+nres)
1565 C Calculate SC interaction energy.
1567 do iint=1,nint_gr(i)
1568 do j=istart(i,iint),iend(i,iint)
1570 itypj=iabs(itype(j))
1571 if (itypj.eq.ntyp1) cycle
1572 c dscj_inv=dsc_inv(itypj)
1573 dscj_inv=vbld_inv(j+nres)
1574 chi1=chi(itypi,itypj)
1575 chi2=chi(itypj,itypi)
1582 alf12=0.5D0*(alf1+alf2)
1583 C For diagnostics only!!!
1596 dxj=dc_norm(1,nres+j)
1597 dyj=dc_norm(2,nres+j)
1598 dzj=dc_norm(3,nres+j)
1599 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1600 cd if (icall.eq.0) then
1606 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1608 C Calculate whole angle-dependent part of epsilon and contributions
1609 C to its derivatives
1610 C have you changed here?
1611 fac=(rrij*sigsq)**expon2
1614 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1615 eps2der=evdwij*eps3rt
1616 eps3der=evdwij*eps2rt
1617 evdwij=evdwij*eps2rt*eps3rt
1620 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1622 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1623 cd & restyp(itypi),i,restyp(itypj),j,
1624 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1625 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1626 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1629 C Calculate gradient components.
1630 e1=e1*eps1*eps2rt**2*eps3rt**2
1631 fac=-expon*(e1+evdwij)
1634 C Calculate radial part of the gradient
1638 C Calculate the angular part of the gradient and sum add the contributions
1639 C to the appropriate components of the Cartesian gradient.
1647 C-----------------------------------------------------------------------------
1648 subroutine egb(evdw)
1650 C This subroutine calculates the interaction energy of nonbonded side chains
1651 C assuming the Gay-Berne potential of interaction.
1653 implicit real*8 (a-h,o-z)
1654 include 'DIMENSIONS'
1655 include 'COMMON.GEO'
1656 include 'COMMON.VAR'
1657 include 'COMMON.LOCAL'
1658 include 'COMMON.CHAIN'
1659 include 'COMMON.DERIV'
1660 include 'COMMON.NAMES'
1661 include 'COMMON.INTERACT'
1662 include 'COMMON.IOUNITS'
1663 include 'COMMON.CALC'
1664 include 'COMMON.CONTROL'
1665 include 'COMMON.SPLITELE'
1666 include 'COMMON.SBRIDGE'
1668 integer xshift,yshift,zshift
1671 ccccc energy_dec=.false.
1672 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1675 c if (icall.eq.0) lprn=.false.
1677 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1678 C we have the original box)
1682 do i=iatsc_s,iatsc_e
1683 itypi=iabs(itype(i))
1684 if (itypi.eq.ntyp1) cycle
1685 itypi1=iabs(itype(i+1))
1689 C Return atom into box, boxxsize is size of box in x dimension
1691 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1692 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1693 C Condition for being inside the proper box
1694 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1695 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
1699 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1700 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1701 C Condition for being inside the proper box
1702 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1703 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
1707 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1708 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1709 C Condition for being inside the proper box
1710 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1711 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
1715 if (xi.lt.0) xi=xi+boxxsize
1717 if (yi.lt.0) yi=yi+boxysize
1719 if (zi.lt.0) zi=zi+boxzsize
1720 C define scaling factor for lipids
1722 C if (positi.le.0) positi=positi+boxzsize
1724 C first for peptide groups
1725 c for each residue check if it is in lipid or lipid water border area
1726 if ((zi.gt.bordlipbot)
1727 &.and.(zi.lt.bordliptop)) then
1728 C the energy transfer exist
1729 if (zi.lt.buflipbot) then
1730 C what fraction I am in
1732 & ((zi-bordlipbot)/lipbufthick)
1733 C lipbufthick is thickenes of lipid buffore
1734 sslipi=sscalelip(fracinbuf)
1735 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1736 elseif (zi.gt.bufliptop) then
1737 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1738 sslipi=sscalelip(fracinbuf)
1739 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1749 C xi=xi+xshift*boxxsize
1750 C yi=yi+yshift*boxysize
1751 C zi=zi+zshift*boxzsize
1753 dxi=dc_norm(1,nres+i)
1754 dyi=dc_norm(2,nres+i)
1755 dzi=dc_norm(3,nres+i)
1756 c dsci_inv=dsc_inv(itypi)
1757 dsci_inv=vbld_inv(i+nres)
1758 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1759 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1761 C Calculate SC interaction energy.
1763 do iint=1,nint_gr(i)
1764 do j=istart(i,iint),iend(i,iint)
1765 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1767 c write(iout,*) "PRZED ZWYKLE", evdwij
1768 call dyn_ssbond_ene(i,j,evdwij)
1769 c write(iout,*) "PO ZWYKLE", evdwij
1772 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1773 & 'evdw',i,j,evdwij,' ss'
1774 C triple bond artifac removal
1775 do k=j+1,iend(i,iint)
1776 C search over all next residues
1777 if (dyn_ss_mask(k)) then
1778 C check if they are cysteins
1779 C write(iout,*) 'k=',k
1781 c write(iout,*) "PRZED TRI", evdwij
1782 evdwij_przed_tri=evdwij
1783 call triple_ssbond_ene(i,j,k,evdwij)
1784 c if(evdwij_przed_tri.ne.evdwij) then
1785 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1788 c write(iout,*) "PO TRI", evdwij
1789 C call the energy function that removes the artifical triple disulfide
1790 C bond the soubroutine is located in ssMD.F
1792 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1793 & 'evdw',i,j,evdwij,'tss'
1794 endif!dyn_ss_mask(k)
1798 itypj=iabs(itype(j))
1799 if (itypj.eq.ntyp1) cycle
1800 c dscj_inv=dsc_inv(itypj)
1801 dscj_inv=vbld_inv(j+nres)
1802 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1803 c & 1.0d0/vbld(j+nres)
1804 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1805 sig0ij=sigma(itypi,itypj)
1806 chi1=chi(itypi,itypj)
1807 chi2=chi(itypj,itypi)
1814 alf12=0.5D0*(alf1+alf2)
1815 C For diagnostics only!!!
1828 C Return atom J into box the original box
1830 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1831 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1832 C Condition for being inside the proper box
1833 c if ((xj.gt.((0.5d0)*boxxsize)).or.
1834 c & (xj.lt.((-0.5d0)*boxxsize))) then
1838 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1839 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1840 C Condition for being inside the proper box
1841 c if ((yj.gt.((0.5d0)*boxysize)).or.
1842 c & (yj.lt.((-0.5d0)*boxysize))) then
1846 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1847 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1848 C Condition for being inside the proper box
1849 c if ((zj.gt.((0.5d0)*boxzsize)).or.
1850 c & (zj.lt.((-0.5d0)*boxzsize))) then
1854 if (xj.lt.0) xj=xj+boxxsize
1856 if (yj.lt.0) yj=yj+boxysize
1858 if (zj.lt.0) zj=zj+boxzsize
1859 if ((zj.gt.bordlipbot)
1860 &.and.(zj.lt.bordliptop)) then
1861 C the energy transfer exist
1862 if (zj.lt.buflipbot) then
1863 C what fraction I am in
1865 & ((zj-bordlipbot)/lipbufthick)
1866 C lipbufthick is thickenes of lipid buffore
1867 sslipj=sscalelip(fracinbuf)
1868 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1869 elseif (zj.gt.bufliptop) then
1870 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1871 sslipj=sscalelip(fracinbuf)
1872 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1881 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1882 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1883 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1884 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1885 C write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1886 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1887 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1888 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1889 C print *,sslipi,sslipj,bordlipbot,zi,zj
1890 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1898 xj=xj_safe+xshift*boxxsize
1899 yj=yj_safe+yshift*boxysize
1900 zj=zj_safe+zshift*boxzsize
1901 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1902 if(dist_temp.lt.dist_init) then
1912 if (subchap.eq.1) then
1921 dxj=dc_norm(1,nres+j)
1922 dyj=dc_norm(2,nres+j)
1923 dzj=dc_norm(3,nres+j)
1927 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1928 c write (iout,*) "j",j," dc_norm",
1929 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1930 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1932 sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1933 sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1935 c write (iout,'(a7,4f8.3)')
1936 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1937 if (sss.gt.0.0d0) then
1938 C Calculate angle-dependent terms of energy and contributions to their
1942 sig=sig0ij*dsqrt(sigsq)
1943 rij_shift=1.0D0/rij-sig+sig0ij
1944 c for diagnostics; uncomment
1945 c rij_shift=1.2*sig0ij
1946 C I hate to put IF's in the loops, but here don't have another choice!!!!
1947 if (rij_shift.le.0.0D0) then
1949 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1950 cd & restyp(itypi),i,restyp(itypj),j,
1951 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1955 c---------------------------------------------------------------
1956 rij_shift=1.0D0/rij_shift
1957 fac=rij_shift**expon
1958 C here to start with
1963 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1964 eps2der=evdwij*eps3rt
1965 eps3der=evdwij*eps2rt
1966 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1967 C &((sslipi+sslipj)/2.0d0+
1968 C &(2.0d0-sslipi-sslipj)/2.0d0)
1969 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1970 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1971 evdwij=evdwij*eps2rt*eps3rt
1972 evdw=evdw+evdwij*sss
1974 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1976 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1977 & restyp(itypi),i,restyp(itypj),j,
1978 & epsi,sigm,chi1,chi2,chip1,chip2,
1979 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1980 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1984 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1987 C Calculate gradient components.
1988 e1=e1*eps1*eps2rt**2*eps3rt**2
1989 fac=-expon*(e1+evdwij)*rij_shift
1992 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
1993 c & evdwij,fac,sigma(itypi,itypj),expon
1994 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1996 C Calculate the radial part of the gradient
1997 gg_lipi(3)=eps1*(eps2rt*eps2rt)
1998 &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1999 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2000 &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2001 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2002 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2008 C Calculate angular part of the gradient.
2018 c write (iout,*) "Number of loop steps in EGB:",ind
2019 cccc energy_dec=.false.
2022 C-----------------------------------------------------------------------------
2023 subroutine egbv(evdw)
2025 C This subroutine calculates the interaction energy of nonbonded side chains
2026 C assuming the Gay-Berne-Vorobjev potential of interaction.
2028 implicit real*8 (a-h,o-z)
2029 include 'DIMENSIONS'
2030 include 'COMMON.GEO'
2031 include 'COMMON.VAR'
2032 include 'COMMON.LOCAL'
2033 include 'COMMON.CHAIN'
2034 include 'COMMON.DERIV'
2035 include 'COMMON.NAMES'
2036 include 'COMMON.INTERACT'
2037 include 'COMMON.IOUNITS'
2038 include 'COMMON.CALC'
2039 common /srutu/ icall
2042 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2045 c if (icall.eq.0) lprn=.true.
2047 do i=iatsc_s,iatsc_e
2048 itypi=iabs(itype(i))
2049 if (itypi.eq.ntyp1) cycle
2050 itypi1=iabs(itype(i+1))
2055 if (xi.lt.0) xi=xi+boxxsize
2057 if (yi.lt.0) yi=yi+boxysize
2059 if (zi.lt.0) zi=zi+boxzsize
2060 C define scaling factor for lipids
2062 C if (positi.le.0) positi=positi+boxzsize
2064 C first for peptide groups
2065 c for each residue check if it is in lipid or lipid water border area
2066 if ((zi.gt.bordlipbot)
2067 &.and.(zi.lt.bordliptop)) then
2068 C the energy transfer exist
2069 if (zi.lt.buflipbot) then
2070 C what fraction I am in
2072 & ((zi-bordlipbot)/lipbufthick)
2073 C lipbufthick is thickenes of lipid buffore
2074 sslipi=sscalelip(fracinbuf)
2075 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2076 elseif (zi.gt.bufliptop) then
2077 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2078 sslipi=sscalelip(fracinbuf)
2079 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2089 dxi=dc_norm(1,nres+i)
2090 dyi=dc_norm(2,nres+i)
2091 dzi=dc_norm(3,nres+i)
2092 c dsci_inv=dsc_inv(itypi)
2093 dsci_inv=vbld_inv(i+nres)
2095 C Calculate SC interaction energy.
2097 do iint=1,nint_gr(i)
2098 do j=istart(i,iint),iend(i,iint)
2100 itypj=iabs(itype(j))
2101 if (itypj.eq.ntyp1) cycle
2102 c dscj_inv=dsc_inv(itypj)
2103 dscj_inv=vbld_inv(j+nres)
2104 sig0ij=sigma(itypi,itypj)
2105 r0ij=r0(itypi,itypj)
2106 chi1=chi(itypi,itypj)
2107 chi2=chi(itypj,itypi)
2114 alf12=0.5D0*(alf1+alf2)
2115 C For diagnostics only!!!
2129 if (xj.lt.0) xj=xj+boxxsize
2131 if (yj.lt.0) yj=yj+boxysize
2133 if (zj.lt.0) zj=zj+boxzsize
2134 if ((zj.gt.bordlipbot)
2135 &.and.(zj.lt.bordliptop)) then
2136 C the energy transfer exist
2137 if (zj.lt.buflipbot) then
2138 C what fraction I am in
2140 & ((zj-bordlipbot)/lipbufthick)
2141 C lipbufthick is thickenes of lipid buffore
2142 sslipj=sscalelip(fracinbuf)
2143 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2144 elseif (zj.gt.bufliptop) then
2145 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2146 sslipj=sscalelip(fracinbuf)
2147 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2156 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2157 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2158 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2159 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2160 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2161 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2162 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2163 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2171 xj=xj_safe+xshift*boxxsize
2172 yj=yj_safe+yshift*boxysize
2173 zj=zj_safe+zshift*boxzsize
2174 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2175 if(dist_temp.lt.dist_init) then
2185 if (subchap.eq.1) then
2194 dxj=dc_norm(1,nres+j)
2195 dyj=dc_norm(2,nres+j)
2196 dzj=dc_norm(3,nres+j)
2197 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2199 C Calculate angle-dependent terms of energy and contributions to their
2203 sig=sig0ij*dsqrt(sigsq)
2204 rij_shift=1.0D0/rij-sig+r0ij
2205 C I hate to put IF's in the loops, but here don't have another choice!!!!
2206 if (rij_shift.le.0.0D0) then
2211 c---------------------------------------------------------------
2212 rij_shift=1.0D0/rij_shift
2213 fac=rij_shift**expon
2216 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2217 eps2der=evdwij*eps3rt
2218 eps3der=evdwij*eps2rt
2219 fac_augm=rrij**expon
2220 e_augm=augm(itypi,itypj)*fac_augm
2221 evdwij=evdwij*eps2rt*eps3rt
2222 evdw=evdw+evdwij+e_augm
2224 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2226 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2227 & restyp(itypi),i,restyp(itypj),j,
2228 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2229 & chi1,chi2,chip1,chip2,
2230 & eps1,eps2rt**2,eps3rt**2,
2231 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2234 C Calculate gradient components.
2235 e1=e1*eps1*eps2rt**2*eps3rt**2
2236 fac=-expon*(e1+evdwij)*rij_shift
2238 fac=rij*fac-2*expon*rrij*e_augm
2239 fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2240 C Calculate the radial part of the gradient
2244 C Calculate angular part of the gradient.
2250 C-----------------------------------------------------------------------------
2251 subroutine sc_angular
2252 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2253 C om12. Called by ebp, egb, and egbv.
2255 include 'COMMON.CALC'
2256 include 'COMMON.IOUNITS'
2260 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2261 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2262 om12=dxi*dxj+dyi*dyj+dzi*dzj
2264 C Calculate eps1(om12) and its derivative in om12
2265 faceps1=1.0D0-om12*chiom12
2266 faceps1_inv=1.0D0/faceps1
2267 eps1=dsqrt(faceps1_inv)
2268 C Following variable is eps1*deps1/dom12
2269 eps1_om12=faceps1_inv*chiom12
2274 c write (iout,*) "om12",om12," eps1",eps1
2275 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2280 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2281 sigsq=1.0D0-facsig*faceps1_inv
2282 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2283 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2284 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2290 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2291 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2293 C Calculate eps2 and its derivatives in om1, om2, and om12.
2296 chipom12=chip12*om12
2297 facp=1.0D0-om12*chipom12
2299 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2300 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2301 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2302 C Following variable is the square root of eps2
2303 eps2rt=1.0D0-facp1*facp_inv
2304 C Following three variables are the derivatives of the square root of eps
2305 C in om1, om2, and om12.
2306 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2307 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2308 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2309 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2310 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2311 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2312 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2313 c & " eps2rt_om12",eps2rt_om12
2314 C Calculate whole angle-dependent part of epsilon and contributions
2315 C to its derivatives
2318 C----------------------------------------------------------------------------
2320 implicit real*8 (a-h,o-z)
2321 include 'DIMENSIONS'
2322 include 'COMMON.CHAIN'
2323 include 'COMMON.DERIV'
2324 include 'COMMON.CALC'
2325 include 'COMMON.IOUNITS'
2326 double precision dcosom1(3),dcosom2(3)
2327 cc print *,'sss=',sss
2328 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2329 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2330 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2331 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2335 c eom12=evdwij*eps1_om12
2337 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2338 c & " sigder",sigder
2339 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2340 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2342 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2343 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2346 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2348 c write (iout,*) "gg",(gg(k),k=1,3)
2350 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2351 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2352 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2353 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2354 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2355 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2356 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2357 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2358 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2359 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2362 C Calculate the components of the gradient in DC and X
2366 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2370 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2371 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2375 C-----------------------------------------------------------------------
2376 subroutine e_softsphere(evdw)
2378 C This subroutine calculates the interaction energy of nonbonded side chains
2379 C assuming the LJ potential of interaction.
2381 implicit real*8 (a-h,o-z)
2382 include 'DIMENSIONS'
2383 parameter (accur=1.0d-10)
2384 include 'COMMON.GEO'
2385 include 'COMMON.VAR'
2386 include 'COMMON.LOCAL'
2387 include 'COMMON.CHAIN'
2388 include 'COMMON.DERIV'
2389 include 'COMMON.INTERACT'
2390 include 'COMMON.TORSION'
2391 include 'COMMON.SBRIDGE'
2392 include 'COMMON.NAMES'
2393 include 'COMMON.IOUNITS'
2394 include 'COMMON.CONTACTS'
2396 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2398 do i=iatsc_s,iatsc_e
2399 itypi=iabs(itype(i))
2400 if (itypi.eq.ntyp1) cycle
2401 itypi1=iabs(itype(i+1))
2406 C Calculate SC interaction energy.
2408 do iint=1,nint_gr(i)
2409 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2410 cd & 'iend=',iend(i,iint)
2411 do j=istart(i,iint),iend(i,iint)
2412 itypj=iabs(itype(j))
2413 if (itypj.eq.ntyp1) cycle
2417 rij=xj*xj+yj*yj+zj*zj
2418 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2419 r0ij=r0(itypi,itypj)
2421 c print *,i,j,r0ij,dsqrt(rij)
2422 if (rij.lt.r0ijsq) then
2423 evdwij=0.25d0*(rij-r0ijsq)**2
2431 C Calculate the components of the gradient in DC and X
2437 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2438 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2439 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2440 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2444 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2452 C--------------------------------------------------------------------------
2453 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2456 C Soft-sphere potential of p-p interaction
2458 implicit real*8 (a-h,o-z)
2459 include 'DIMENSIONS'
2460 include 'COMMON.CONTROL'
2461 include 'COMMON.IOUNITS'
2462 include 'COMMON.GEO'
2463 include 'COMMON.VAR'
2464 include 'COMMON.LOCAL'
2465 include 'COMMON.CHAIN'
2466 include 'COMMON.DERIV'
2467 include 'COMMON.INTERACT'
2468 include 'COMMON.CONTACTS'
2469 include 'COMMON.TORSION'
2470 include 'COMMON.VECTORS'
2471 include 'COMMON.FFIELD'
2473 C write(iout,*) 'In EELEC_soft_sphere'
2480 do i=iatel_s,iatel_e
2481 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2485 xmedi=c(1,i)+0.5d0*dxi
2486 ymedi=c(2,i)+0.5d0*dyi
2487 zmedi=c(3,i)+0.5d0*dzi
2488 xmedi=mod(xmedi,boxxsize)
2489 if (xmedi.lt.0) xmedi=xmedi+boxxsize
2490 ymedi=mod(ymedi,boxysize)
2491 if (ymedi.lt.0) ymedi=ymedi+boxysize
2492 zmedi=mod(zmedi,boxzsize)
2493 if (zmedi.lt.0) zmedi=zmedi+boxzsize
2495 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2496 do j=ielstart(i),ielend(i)
2497 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2501 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2502 r0ij=rpp(iteli,itelj)
2511 if (xj.lt.0) xj=xj+boxxsize
2513 if (yj.lt.0) yj=yj+boxysize
2515 if (zj.lt.0) zj=zj+boxzsize
2516 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2524 xj=xj_safe+xshift*boxxsize
2525 yj=yj_safe+yshift*boxysize
2526 zj=zj_safe+zshift*boxzsize
2527 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2528 if(dist_temp.lt.dist_init) then
2538 if (isubchap.eq.1) then
2547 rij=xj*xj+yj*yj+zj*zj
2548 sss=sscale(sqrt(rij))
2549 sssgrad=sscagrad(sqrt(rij))
2550 if (rij.lt.r0ijsq) then
2551 evdw1ij=0.25d0*(rij-r0ijsq)**2
2557 evdw1=evdw1+evdw1ij*sss
2559 C Calculate contributions to the Cartesian gradient.
2561 ggg(1)=fac*xj*sssgrad
2562 ggg(2)=fac*yj*sssgrad
2563 ggg(3)=fac*zj*sssgrad
2565 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2566 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2569 * Loop over residues i+1 thru j-1.
2573 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2578 cgrad do i=nnt,nct-1
2580 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2582 cgrad do j=i+1,nct-1
2584 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2590 c------------------------------------------------------------------------------
2591 subroutine vec_and_deriv
2592 implicit real*8 (a-h,o-z)
2593 include 'DIMENSIONS'
2597 include 'COMMON.IOUNITS'
2598 include 'COMMON.GEO'
2599 include 'COMMON.VAR'
2600 include 'COMMON.LOCAL'
2601 include 'COMMON.CHAIN'
2602 include 'COMMON.VECTORS'
2603 include 'COMMON.SETUP'
2604 include 'COMMON.TIME1'
2605 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2606 C Compute the local reference systems. For reference system (i), the
2607 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2608 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2610 do i=ivec_start,ivec_end
2614 if (i.eq.nres-1) then
2615 C Case of the last full residue
2616 C Compute the Z-axis
2617 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2618 costh=dcos(pi-theta(nres))
2619 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2623 C Compute the derivatives of uz
2625 uzder(2,1,1)=-dc_norm(3,i-1)
2626 uzder(3,1,1)= dc_norm(2,i-1)
2627 uzder(1,2,1)= dc_norm(3,i-1)
2629 uzder(3,2,1)=-dc_norm(1,i-1)
2630 uzder(1,3,1)=-dc_norm(2,i-1)
2631 uzder(2,3,1)= dc_norm(1,i-1)
2634 uzder(2,1,2)= dc_norm(3,i)
2635 uzder(3,1,2)=-dc_norm(2,i)
2636 uzder(1,2,2)=-dc_norm(3,i)
2638 uzder(3,2,2)= dc_norm(1,i)
2639 uzder(1,3,2)= dc_norm(2,i)
2640 uzder(2,3,2)=-dc_norm(1,i)
2642 C Compute the Y-axis
2645 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2647 C Compute the derivatives of uy
2650 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2651 & -dc_norm(k,i)*dc_norm(j,i-1)
2652 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2654 uyder(j,j,1)=uyder(j,j,1)-costh
2655 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2660 uygrad(l,k,j,i)=uyder(l,k,j)
2661 uzgrad(l,k,j,i)=uzder(l,k,j)
2665 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2666 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2667 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2668 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2671 C Compute the Z-axis
2672 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2673 costh=dcos(pi-theta(i+2))
2674 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2678 C Compute the derivatives of uz
2680 uzder(2,1,1)=-dc_norm(3,i+1)
2681 uzder(3,1,1)= dc_norm(2,i+1)
2682 uzder(1,2,1)= dc_norm(3,i+1)
2684 uzder(3,2,1)=-dc_norm(1,i+1)
2685 uzder(1,3,1)=-dc_norm(2,i+1)
2686 uzder(2,3,1)= dc_norm(1,i+1)
2689 uzder(2,1,2)= dc_norm(3,i)
2690 uzder(3,1,2)=-dc_norm(2,i)
2691 uzder(1,2,2)=-dc_norm(3,i)
2693 uzder(3,2,2)= dc_norm(1,i)
2694 uzder(1,3,2)= dc_norm(2,i)
2695 uzder(2,3,2)=-dc_norm(1,i)
2697 C Compute the Y-axis
2700 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2702 C Compute the derivatives of uy
2705 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2706 & -dc_norm(k,i)*dc_norm(j,i+1)
2707 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2709 uyder(j,j,1)=uyder(j,j,1)-costh
2710 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2715 uygrad(l,k,j,i)=uyder(l,k,j)
2716 uzgrad(l,k,j,i)=uzder(l,k,j)
2720 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2721 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2722 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2723 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2727 vbld_inv_temp(1)=vbld_inv(i+1)
2728 if (i.lt.nres-1) then
2729 vbld_inv_temp(2)=vbld_inv(i+2)
2731 vbld_inv_temp(2)=vbld_inv(i)
2736 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2737 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2742 #if defined(PARVEC) && defined(MPI)
2743 if (nfgtasks1.gt.1) then
2745 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2746 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2747 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2748 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2749 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2751 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2752 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2754 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2755 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2756 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2757 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2758 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2759 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2760 time_gather=time_gather+MPI_Wtime()-time00
2762 c if (fg_rank.eq.0) then
2763 c write (iout,*) "Arrays UY and UZ"
2765 c write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2772 C-----------------------------------------------------------------------------
2773 subroutine check_vecgrad
2774 implicit real*8 (a-h,o-z)
2775 include 'DIMENSIONS'
2776 include 'COMMON.IOUNITS'
2777 include 'COMMON.GEO'
2778 include 'COMMON.VAR'
2779 include 'COMMON.LOCAL'
2780 include 'COMMON.CHAIN'
2781 include 'COMMON.VECTORS'
2782 dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2783 dimension uyt(3,maxres),uzt(3,maxres)
2784 dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2785 double precision delta /1.0d-7/
2788 crc write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2789 crc write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2790 crc write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2791 cd write(iout,'(2i5,2(3f10.5,5x))') i,1,
2792 cd & (dc_norm(if90,i),if90=1,3)
2793 cd write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2794 cd write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2795 cd write(iout,'(a)')
2801 uygradt(l,k,j,i)=uygrad(l,k,j,i)
2802 uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2815 cd write (iout,*) 'i=',i
2817 erij(k)=dc_norm(k,i)
2821 dc_norm(k,i)=erij(k)
2823 dc_norm(j,i)=dc_norm(j,i)+delta
2824 c fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2826 c dc_norm(k,i)=dc_norm(k,i)/fac
2828 c write (iout,*) (dc_norm(k,i),k=1,3)
2829 c write (iout,*) (erij(k),k=1,3)
2832 uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2833 uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2834 uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2835 uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2837 c write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2838 c & j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2839 c & (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2842 dc_norm(k,i)=erij(k)
2845 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2846 cd & k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2847 cd & (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2848 cd write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2849 cd & k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2850 cd & (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2851 cd write (iout,'(a)')
2856 C--------------------------------------------------------------------------
2857 subroutine set_matrices
2858 implicit real*8 (a-h,o-z)
2859 include 'DIMENSIONS'
2862 include "COMMON.SETUP"
2864 integer status(MPI_STATUS_SIZE)
2866 include 'COMMON.IOUNITS'
2867 include 'COMMON.GEO'
2868 include 'COMMON.VAR'
2869 include 'COMMON.LOCAL'
2870 include 'COMMON.CHAIN'
2871 include 'COMMON.DERIV'
2872 include 'COMMON.INTERACT'
2873 include 'COMMON.CONTACTS'
2874 include 'COMMON.TORSION'
2875 include 'COMMON.VECTORS'
2876 include 'COMMON.FFIELD'
2877 double precision auxvec(2),auxmat(2,2)
2879 C Compute the virtual-bond-torsional-angle dependent quantities needed
2880 C to calculate the el-loc multibody terms of various order.
2882 c write(iout,*) 'nphi=',nphi,nres
2884 do i=ivec_start+2,ivec_end+2
2889 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2890 iti = itype2loc(itype(i-2))
2894 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2895 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2896 iti1 = itype2loc(itype(i-1))
2901 b1(1,i-2)=bnew1(1,1,iti)*dsin(theta(i-1)/2.0d0)
2902 & +bnew1(2,1,iti)*dsin(theta(i-1))
2903 & +bnew1(3,1,iti)*dcos(theta(i-1)/2.0d0)
2904 gtb1(1,i-2)=bnew1(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2905 & +bnew1(2,1,iti)*dcos(theta(i-1))
2906 & -bnew1(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2907 c & +bnew1(3,1,iti)*sin(alpha(i))*cos(beta(i))
2908 c &*(cos(theta(i)/2.0)
2909 b2(1,i-2)=bnew2(1,1,iti)*dsin(theta(i-1)/2.0d0)
2910 & +bnew2(2,1,iti)*dsin(theta(i-1))
2911 & +bnew2(3,1,iti)*dcos(theta(i-1)/2.0d0)
2912 c & +bnew2(3,1,iti)*sin(alpha(i))*cos(beta(i))
2913 c &*(cos(theta(i)/2.0)
2914 gtb2(1,i-2)=bnew2(1,1,iti)*dcos(theta(i-1)/2.0d0)/2.0d0
2915 & +bnew2(2,1,iti)*dcos(theta(i-1))
2916 & -bnew2(3,1,iti)*dsin(theta(i-1)/2.0d0)/2.0d0
2917 c if (ggb1(1,i).eq.0.0d0) then
2918 c write(iout,*) 'i=',i,ggb1(1,i),
2919 c &bnew1(1,1,iti)*cos(theta(i)/2.0)/2.0,
2920 c &bnew1(2,1,iti)*cos(theta(i)),
2921 c &bnew1(3,1,iti)*sin(theta(i)/2.0)/2.0
2923 b1(2,i-2)=bnew1(1,2,iti)
2925 b2(2,i-2)=bnew2(1,2,iti)
2927 EE(1,1,i-2)=eenew(1,iti)*dcos(theta(i-1))
2928 EE(1,2,i-2)=eeold(1,2,iti)
2929 EE(2,1,i-2)=eeold(2,1,iti)
2930 EE(2,2,i-2)=eeold(2,2,iti)
2931 gtEE(1,1,i-2)=-eenew(1,iti)*dsin(theta(i-1))
2936 c EE(1,2,iti)=0.5d0*eenew(1,iti)
2937 c EE(2,1,iti)=0.5d0*eenew(1,iti)
2938 c b1(2,iti)=bnew1(1,2,iti)*sin(alpha(i))*sin(beta(i))
2939 c b2(2,iti)=bnew2(1,2,iti)*sin(alpha(i))*sin(beta(i))
2940 b1tilde(1,i-2)=b1(1,i-2)
2941 b1tilde(2,i-2)=-b1(2,i-2)
2942 b2tilde(1,i-2)=b2(1,i-2)
2943 b2tilde(2,i-2)=-b2(2,i-2)
2944 c write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2945 c write(iout,*) 'b1=',b1(1,i-2)
2946 c write (iout,*) 'theta=', theta(i-1)
2949 if (i.gt. nnt+2 .and. i.lt.nct+2) then
2950 iti = itype2loc(itype(i-2))
2954 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2955 if (i.gt. nnt+1 .and. i.lt.nct+1) then
2956 iti1 = itype2loc(itype(i-1))
2964 b1tilde(1,i-2)=b1(1,i-2)
2965 b1tilde(2,i-2)=-b1(2,i-2)
2966 b2tilde(1,i-2)=b2(1,i-2)
2967 b2tilde(2,i-2)=-b2(2,i-2)
2968 EE(1,2,i-2)=eeold(1,2,iti)
2969 EE(2,1,i-2)=eeold(2,1,iti)
2970 EE(2,2,i-2)=eeold(2,2,iti)
2971 EE(1,1,i-2)=eeold(1,1,iti)
2975 do i=ivec_start+2,ivec_end+2
2979 if (i .lt. nres+1) then
3016 if (i .gt. 3 .and. i .lt. nres+1) then
3017 obrot_der(1,i-2)=-sin1
3018 obrot_der(2,i-2)= cos1
3019 Ugder(1,1,i-2)= sin1
3020 Ugder(1,2,i-2)=-cos1
3021 Ugder(2,1,i-2)=-cos1
3022 Ugder(2,2,i-2)=-sin1
3025 obrot2_der(1,i-2)=-dwasin2
3026 obrot2_der(2,i-2)= dwacos2
3027 Ug2der(1,1,i-2)= dwasin2
3028 Ug2der(1,2,i-2)=-dwacos2
3029 Ug2der(2,1,i-2)=-dwacos2
3030 Ug2der(2,2,i-2)=-dwasin2
3032 obrot_der(1,i-2)=0.0d0
3033 obrot_der(2,i-2)=0.0d0
3034 Ugder(1,1,i-2)=0.0d0
3035 Ugder(1,2,i-2)=0.0d0
3036 Ugder(2,1,i-2)=0.0d0
3037 Ugder(2,2,i-2)=0.0d0
3038 obrot2_der(1,i-2)=0.0d0
3039 obrot2_der(2,i-2)=0.0d0
3040 Ug2der(1,1,i-2)=0.0d0
3041 Ug2der(1,2,i-2)=0.0d0
3042 Ug2der(2,1,i-2)=0.0d0
3043 Ug2der(2,2,i-2)=0.0d0
3045 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3046 if (i.gt. nnt+2 .and. i.lt.nct+2) then
3047 iti = itype2loc(itype(i-2))
3051 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3052 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3053 iti1 = itype2loc(itype(i-1))
3057 cd write (iout,*) '*******i',i,' iti1',iti
3058 cd write (iout,*) 'b1',b1(:,iti)
3059 cd write (iout,*) 'b2',b2(:,iti)
3060 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3061 c if (i .gt. iatel_s+2) then
3062 if (i .gt. nnt+2) then
3063 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3065 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3066 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3068 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3069 c & EE(1,2,iti),EE(2,2,i)
3070 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3071 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3072 c write(iout,*) "Macierz EUG",
3073 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3075 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3077 call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
3078 call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
3079 call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3080 call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
3081 call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
3092 DtUg2(l,k,i-2)=0.0d0
3096 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3097 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3099 muder(k,i-2)=Ub2der(k,i-2)
3101 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3102 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3103 if (itype(i-1).le.ntyp) then
3104 iti1 = itype2loc(itype(i-1))
3112 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3115 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3116 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3117 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3118 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3119 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3120 & ((ee(l,k,i-2),l=1,2),k=1,2),eenew(1,itype2loc(iti))
3122 cd write (iout,*) 'mu1',mu1(:,i-2)
3123 cd write (iout,*) 'mu2',mu2(:,i-2)
3124 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3126 call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3127 call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
3128 call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3129 call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
3130 call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3131 C Vectors and matrices dependent on a single virtual-bond dihedral.
3132 call matvec2(DD(1,1,iti),b1tilde(1,i-1),auxvec(1))
3133 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3134 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3135 call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
3136 call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
3137 call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3138 call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3139 call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3140 call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3143 C Matrices dependent on two consecutive virtual-bond dihedrals.
3144 C The order of matrices is from left to right.
3145 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3147 c do i=max0(ivec_start,2),ivec_end
3149 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3150 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3151 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3152 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3153 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3154 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3155 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3156 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3159 #if defined(MPI) && defined(PARMAT)
3161 c if (fg_rank.eq.0) then
3162 write (iout,*) "Arrays UG and UGDER before GATHER"
3164 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3165 & ((ug(l,k,i),l=1,2),k=1,2),
3166 & ((ugder(l,k,i),l=1,2),k=1,2)
3168 write (iout,*) "Arrays UG2 and UG2DER"
3170 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3171 & ((ug2(l,k,i),l=1,2),k=1,2),
3172 & ((ug2der(l,k,i),l=1,2),k=1,2)
3174 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3176 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3177 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3178 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3180 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3182 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3183 & costab(i),sintab(i),costab2(i),sintab2(i)
3185 write (iout,*) "Array MUDER"
3187 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3191 if (nfgtasks.gt.1) then
3193 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3194 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3195 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3197 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3198 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3200 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3201 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3203 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3204 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3206 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3207 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3209 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3210 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3212 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3213 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3215 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3216 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3217 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3218 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3219 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3220 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3221 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3222 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3223 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3224 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3225 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3226 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3227 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3229 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3230 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3232 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3233 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3235 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3236 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3238 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3239 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3241 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3242 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3244 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3245 & ivec_count(fg_rank1),
3246 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3248 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3249 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3251 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3252 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3254 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3255 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3257 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3258 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3260 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3261 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3263 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3264 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3266 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3267 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3269 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3270 & ivec_count(fg_rank1),
3271 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3273 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3274 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3276 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3277 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3279 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3280 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3282 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3283 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3285 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3286 & ivec_count(fg_rank1),
3287 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3289 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3290 & ivec_count(fg_rank1),
3291 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3293 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3294 & ivec_count(fg_rank1),
3295 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3296 & MPI_MAT2,FG_COMM1,IERR)
3297 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3298 & ivec_count(fg_rank1),
3299 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3300 & MPI_MAT2,FG_COMM1,IERR)
3303 c Passes matrix info through the ring
3306 if (irecv.lt.0) irecv=nfgtasks1-1
3309 if (inext.ge.nfgtasks1) inext=0
3311 c write (iout,*) "isend",isend," irecv",irecv
3313 lensend=lentyp(isend)
3314 lenrecv=lentyp(irecv)
3315 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3316 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3317 c & MPI_ROTAT1(lensend),inext,2200+isend,
3318 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3319 c & iprev,2200+irecv,FG_COMM,status,IERR)
3320 c write (iout,*) "Gather ROTAT1"
3322 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3323 c & MPI_ROTAT2(lensend),inext,3300+isend,
3324 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3325 c & iprev,3300+irecv,FG_COMM,status,IERR)
3326 c write (iout,*) "Gather ROTAT2"
3328 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3329 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3330 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3331 & iprev,4400+irecv,FG_COMM,status,IERR)
3332 c write (iout,*) "Gather ROTAT_OLD"
3334 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3335 & MPI_PRECOMP11(lensend),inext,5500+isend,
3336 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3337 & iprev,5500+irecv,FG_COMM,status,IERR)
3338 c write (iout,*) "Gather PRECOMP11"
3340 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3341 & MPI_PRECOMP12(lensend),inext,6600+isend,
3342 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3343 & iprev,6600+irecv,FG_COMM,status,IERR)
3344 c write (iout,*) "Gather PRECOMP12"
3346 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3348 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3349 & MPI_ROTAT2(lensend),inext,7700+isend,
3350 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3351 & iprev,7700+irecv,FG_COMM,status,IERR)
3352 c write (iout,*) "Gather PRECOMP21"
3354 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3355 & MPI_PRECOMP22(lensend),inext,8800+isend,
3356 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3357 & iprev,8800+irecv,FG_COMM,status,IERR)
3358 c write (iout,*) "Gather PRECOMP22"
3360 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3361 & MPI_PRECOMP23(lensend),inext,9900+isend,
3362 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3363 & MPI_PRECOMP23(lenrecv),
3364 & iprev,9900+irecv,FG_COMM,status,IERR)
3365 c write (iout,*) "Gather PRECOMP23"
3370 if (irecv.lt.0) irecv=nfgtasks1-1
3373 time_gather=time_gather+MPI_Wtime()-time00
3376 c if (fg_rank.eq.0) then
3377 write (iout,*) "Arrays UG and UGDER"
3379 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3380 & ((ug(l,k,i),l=1,2),k=1,2),
3381 & ((ugder(l,k,i),l=1,2),k=1,2)
3383 write (iout,*) "Arrays UG2 and UG2DER"
3385 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3386 & ((ug2(l,k,i),l=1,2),k=1,2),
3387 & ((ug2der(l,k,i),l=1,2),k=1,2)
3389 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3391 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3392 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3393 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3395 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3397 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3398 & costab(i),sintab(i),costab2(i),sintab2(i)
3400 write (iout,*) "Array MUDER"
3402 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3408 cd iti = itype2loc(itype(i))
3411 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3412 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3417 C--------------------------------------------------------------------------
3418 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3420 C This subroutine calculates the average interaction energy and its gradient
3421 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3422 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3423 C The potential depends both on the distance of peptide-group centers and on
3424 C the orientation of the CA-CA virtual bonds.
3426 implicit real*8 (a-h,o-z)
3430 include 'DIMENSIONS'
3431 include 'COMMON.CONTROL'
3432 include 'COMMON.SETUP'
3433 include 'COMMON.IOUNITS'
3434 include 'COMMON.GEO'
3435 include 'COMMON.VAR'
3436 include 'COMMON.LOCAL'
3437 include 'COMMON.CHAIN'
3438 include 'COMMON.DERIV'
3439 include 'COMMON.INTERACT'
3440 include 'COMMON.CONTACTS'
3441 include 'COMMON.TORSION'
3442 include 'COMMON.VECTORS'
3443 include 'COMMON.FFIELD'
3444 include 'COMMON.TIME1'
3445 include 'COMMON.SPLITELE'
3446 include 'COMMON.SHIELD'
3447 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3448 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3449 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3450 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3451 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3452 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3454 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3456 double precision scal_el /1.0d0/
3458 double precision scal_el /0.5d0/
3461 C 13-go grudnia roku pamietnego...
3462 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3463 & 0.0d0,1.0d0,0.0d0,
3464 & 0.0d0,0.0d0,1.0d0/
3465 cd write(iout,*) 'In EELEC'
3467 cd write(iout,*) 'Type',i
3468 cd write(iout,*) 'B1',B1(:,i)
3469 cd write(iout,*) 'B2',B2(:,i)
3470 cd write(iout,*) 'CC',CC(:,:,i)
3471 cd write(iout,*) 'DD',DD(:,:,i)
3472 cd write(iout,*) 'EE',EE(:,:,i)
3474 cd call check_vecgrad
3476 if (icheckgrad.eq.1) then
3478 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3480 dc_norm(k,i)=dc(k,i)*fac
3482 c write (iout,*) 'i',i,' fac',fac
3485 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3486 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3487 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3488 c call vec_and_deriv
3494 time_mat=time_mat+MPI_Wtime()-time01
3498 cd write (iout,*) 'i=',i
3500 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3503 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3504 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3517 cd print '(a)','Enter EELEC'
3518 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3520 gel_loc_loc(i)=0.0d0
3525 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3527 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3529 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3530 do i=iturn3_start,iturn3_end
3532 C write(iout,*) "tu jest i",i
3533 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3534 C changes suggested by Ana to avoid out of bounds
3535 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3536 c & .or.((i+4).gt.nres)
3537 c & .or.((i-1).le.0)
3538 C end of changes by Ana
3539 & .or. itype(i+2).eq.ntyp1
3540 & .or. itype(i+3).eq.ntyp1) cycle
3541 C Adam: Instructions below will switch off existing interactions
3543 c if(itype(i-1).eq.ntyp1)cycle
3545 c if(i.LT.nres-3)then
3546 c if (itype(i+4).eq.ntyp1) cycle
3551 dx_normi=dc_norm(1,i)
3552 dy_normi=dc_norm(2,i)
3553 dz_normi=dc_norm(3,i)
3554 xmedi=c(1,i)+0.5d0*dxi
3555 ymedi=c(2,i)+0.5d0*dyi
3556 zmedi=c(3,i)+0.5d0*dzi
3557 xmedi=mod(xmedi,boxxsize)
3558 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3559 ymedi=mod(ymedi,boxysize)
3560 if (ymedi.lt.0) ymedi=ymedi+boxysize
3561 zmedi=mod(zmedi,boxzsize)
3562 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3563 zmedi2=mod(zmedi,boxzsize)
3564 if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3565 if ((zmedi2.gt.bordlipbot)
3566 &.and.(zmedi2.lt.bordliptop)) then
3567 C the energy transfer exist
3568 if (zmedi2.lt.buflipbot) then
3569 C what fraction I am in
3571 & ((zmedi2-bordlipbot)/lipbufthick)
3572 C lipbufthick is thickenes of lipid buffore
3573 sslipi=sscalelip(fracinbuf)
3574 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3575 elseif (zmedi2.gt.bufliptop) then
3576 fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3577 sslipi=sscalelip(fracinbuf)
3578 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3588 call eelecij(i,i+2,ees,evdw1,eel_loc)
3589 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3590 num_cont_hb(i)=num_conti
3592 do i=iturn4_start,iturn4_end
3594 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3595 C changes suggested by Ana to avoid out of bounds
3596 c & .or.((i+5).gt.nres)
3597 c & .or.((i-1).le.0)
3598 C end of changes suggested by Ana
3599 & .or. itype(i+3).eq.ntyp1
3600 & .or. itype(i+4).eq.ntyp1
3601 c & .or. itype(i+5).eq.ntyp1
3602 c & .or. itype(i).eq.ntyp1
3603 c & .or. itype(i-1).eq.ntyp1
3608 dx_normi=dc_norm(1,i)
3609 dy_normi=dc_norm(2,i)
3610 dz_normi=dc_norm(3,i)
3611 xmedi=c(1,i)+0.5d0*dxi
3612 ymedi=c(2,i)+0.5d0*dyi
3613 zmedi=c(3,i)+0.5d0*dzi
3614 C Return atom into box, boxxsize is size of box in x dimension
3616 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3617 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3618 C Condition for being inside the proper box
3619 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3620 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3624 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3625 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3626 C Condition for being inside the proper box
3627 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3628 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3632 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3633 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3634 C Condition for being inside the proper box
3635 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3636 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3639 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3640 ymedi=mod(ymedi,boxysize)
3641 if (ymedi.lt.0) ymedi=ymedi+boxysize
3642 zmedi=mod(zmedi,boxzsize)
3643 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3644 zmedi2=mod(zmedi,boxzsize)
3645 if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3646 if ((zmedi2.gt.bordlipbot)
3647 &.and.(zmedi2.lt.bordliptop)) then
3648 C the energy transfer exist
3649 if (zmedi2.lt.buflipbot) then
3650 C what fraction I am in
3652 & ((zmedi2-bordlipbot)/lipbufthick)
3653 C lipbufthick is thickenes of lipid buffore
3654 sslipi=sscalelip(fracinbuf)
3655 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3656 elseif (zmedi2.gt.bufliptop) then
3657 fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3658 sslipi=sscalelip(fracinbuf)
3659 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3668 num_conti=num_cont_hb(i)
3669 c write(iout,*) "JESTEM W PETLI"
3670 call eelecij(i,i+3,ees,evdw1,eel_loc)
3671 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3672 & call eturn4(i,eello_turn4)
3673 num_cont_hb(i)=num_conti
3675 C Loop over all neighbouring boxes
3680 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3683 do i=iatel_s,iatel_e
3686 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3687 C changes suggested by Ana to avoid out of bounds
3688 c & .or.((i+2).gt.nres)
3689 c & .or.((i-1).le.0)
3690 C end of changes by Ana
3691 c & .or. itype(i+2).eq.ntyp1
3692 c & .or. itype(i-1).eq.ntyp1
3697 dx_normi=dc_norm(1,i)
3698 dy_normi=dc_norm(2,i)
3699 dz_normi=dc_norm(3,i)
3700 xmedi=c(1,i)+0.5d0*dxi
3701 ymedi=c(2,i)+0.5d0*dyi
3702 zmedi=c(3,i)+0.5d0*dzi
3703 xmedi=mod(xmedi,boxxsize)
3704 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3705 ymedi=mod(ymedi,boxysize)
3706 if (ymedi.lt.0) ymedi=ymedi+boxysize
3707 zmedi=mod(zmedi,boxzsize)
3708 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3709 if ((zmedi.gt.bordlipbot)
3710 &.and.(zmedi.lt.bordliptop)) then
3711 C the energy transfer exist
3712 if (zmedi.lt.buflipbot) then
3713 C what fraction I am in
3715 & ((zmedi-bordlipbot)/lipbufthick)
3716 C lipbufthick is thickenes of lipid buffore
3717 sslipi=sscalelip(fracinbuf)
3718 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3719 elseif (zmedi.gt.bufliptop) then
3720 fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3721 sslipi=sscalelip(fracinbuf)
3722 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3731 C print *,sslipi,"TU?!"
3732 C xmedi=xmedi+xshift*boxxsize
3733 C ymedi=ymedi+yshift*boxysize
3734 C zmedi=zmedi+zshift*boxzsize
3736 C Return tom into box, boxxsize is size of box in x dimension
3738 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3739 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3740 C Condition for being inside the proper box
3741 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3742 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3746 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3747 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3748 C Condition for being inside the proper box
3749 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3750 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3754 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3755 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3756 cC Condition for being inside the proper box
3757 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3758 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3762 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3763 num_conti=num_cont_hb(i)
3765 do j=ielstart(i),ielend(i)
3767 C write (iout,*) i,j
3769 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3770 C changes suggested by Ana to avoid out of bounds
3771 c & .or.((j+2).gt.nres)
3772 c & .or.((j-1).le.0)
3773 C end of changes by Ana
3774 c & .or.itype(j+2).eq.ntyp1
3775 c & .or.itype(j-1).eq.ntyp1
3777 call eelecij(i,j,ees,evdw1,eel_loc)
3779 num_cont_hb(i)=num_conti
3785 c write (iout,*) "Number of loop steps in EELEC:",ind
3787 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3788 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3790 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3791 ccc eel_loc=eel_loc+eello_turn3
3792 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3795 C-------------------------------------------------------------------------------
3796 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3797 implicit real*8 (a-h,o-z)
3798 include 'DIMENSIONS'
3802 include 'COMMON.CONTROL'
3803 include 'COMMON.IOUNITS'
3804 include 'COMMON.GEO'
3805 include 'COMMON.VAR'
3806 include 'COMMON.LOCAL'
3807 include 'COMMON.CHAIN'
3808 include 'COMMON.DERIV'
3809 include 'COMMON.INTERACT'
3810 include 'COMMON.CONTACTS'
3811 include 'COMMON.TORSION'
3812 include 'COMMON.VECTORS'
3813 include 'COMMON.FFIELD'
3814 include 'COMMON.TIME1'
3815 include 'COMMON.SPLITELE'
3816 include 'COMMON.SHIELD'
3817 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3818 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3819 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3820 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3821 & gmuij2(4),gmuji2(4)
3822 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3823 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3825 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3827 double precision scal_el /1.0d0/
3829 double precision scal_el /0.5d0/
3832 C 13-go grudnia roku pamietnego...
3833 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3834 & 0.0d0,1.0d0,0.0d0,
3835 & 0.0d0,0.0d0,1.0d0/
3836 integer xshift,yshift,zshift
3837 c time00=MPI_Wtime()
3838 cd write (iout,*) "eelecij",i,j
3842 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3843 aaa=app(iteli,itelj)
3844 bbb=bpp(iteli,itelj)
3845 ael6i=ael6(iteli,itelj)
3846 ael3i=ael3(iteli,itelj)
3850 dx_normj=dc_norm(1,j)
3851 dy_normj=dc_norm(2,j)
3852 dz_normj=dc_norm(3,j)
3853 C xj=c(1,j)+0.5D0*dxj-xmedi
3854 C yj=c(2,j)+0.5D0*dyj-ymedi
3855 C zj=c(3,j)+0.5D0*dzj-zmedi
3860 if (xj.lt.0) xj=xj+boxxsize
3862 if (yj.lt.0) yj=yj+boxysize
3864 if (zj.lt.0) zj=zj+boxzsize
3865 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3866 if ((zj.gt.bordlipbot)
3867 &.and.(zj.lt.bordliptop)) then
3868 C the energy transfer exist
3869 if (zj.lt.buflipbot) then
3870 C what fraction I am in
3872 & ((zj-bordlipbot)/lipbufthick)
3873 C lipbufthick is thickenes of lipid buffore
3874 sslipj=sscalelip(fracinbuf)
3875 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3876 elseif (zj.gt.bufliptop) then
3877 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3878 sslipj=sscalelip(fracinbuf)
3879 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3888 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3896 xj=xj_safe+xshift*boxxsize
3897 yj=yj_safe+yshift*boxysize
3898 zj=zj_safe+zshift*boxzsize
3899 dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3900 if(dist_temp.lt.dist_init) then
3910 if (isubchap.eq.1) then
3919 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3921 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3922 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3923 C Condition for being inside the proper box
3924 c if ((xj.gt.((0.5d0)*boxxsize)).or.
3925 c & (xj.lt.((-0.5d0)*boxxsize))) then
3929 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3930 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3931 C Condition for being inside the proper box
3932 c if ((yj.gt.((0.5d0)*boxysize)).or.
3933 c & (yj.lt.((-0.5d0)*boxysize))) then
3937 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3938 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3939 C Condition for being inside the proper box
3940 c if ((zj.gt.((0.5d0)*boxzsize)).or.
3941 c & (zj.lt.((-0.5d0)*boxzsize))) then
3944 C endif !endPBC condintion
3948 rij=xj*xj+yj*yj+zj*zj
3950 sss=sscale(sqrt(rij))
3951 sssgrad=sscagrad(sqrt(rij))
3952 c if (sss.gt.0.0d0) then
3958 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3959 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3960 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3961 fac=cosa-3.0D0*cosb*cosg
3963 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3964 if (j.eq.i+2) ev1=scal_el*ev1
3969 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3973 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3974 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3975 if (shield_mode.gt.0) then
3978 el1=el1*fac_shield(i)**2*fac_shield(j)**2
3979 el2=el2*fac_shield(i)**2*fac_shield(j)**2
3982 C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3983 C & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3989 &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3990 C print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3992 evdw1=evdw1+evdwij*sss
3993 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3994 C print *,sslipi,sslipj,lipscale**2,
3995 C & (sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3996 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3997 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3998 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
3999 cd & xmedi,ymedi,zmedi,xj,yj,zj
4001 if (energy_dec) then
4002 write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
4004 &,iteli,itelj,aaa,evdw1
4006 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4007 &fac_shield(i),fac_shield(j)
4011 C Calculate contributions to the Cartesian gradient.
4014 facvdw=-6*rrmij*(ev1+evdwij)*sss
4015 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4016 facel=-3*rrmij*(el1+eesij)
4017 &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4024 * Radial derivatives. First process both termini of the fragment (i,j)
4029 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4030 & (shield_mode.gt.0)) then
4032 do ilist=1,ishield_list(i)
4033 iresshield=shield_list(ilist,i)
4035 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4037 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4039 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4040 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4041 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4042 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4043 C if (iresshield.gt.i) then
4044 C do ishi=i+1,iresshield-1
4045 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4046 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4050 C do ishi=iresshield,i
4051 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4052 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4058 do ilist=1,ishield_list(j)
4059 iresshield=shield_list(ilist,j)
4061 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4063 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4065 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4066 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4068 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4069 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4070 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4071 C if (iresshield.gt.j) then
4072 C do ishi=j+1,iresshield-1
4073 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4074 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4078 C do ishi=iresshield,j
4079 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4080 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4087 gshieldc(k,i)=gshieldc(k,i)+
4088 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4089 gshieldc(k,j)=gshieldc(k,j)+
4090 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4091 gshieldc(k,i-1)=gshieldc(k,i-1)+
4092 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4093 gshieldc(k,j-1)=gshieldc(k,j-1)+
4094 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4099 c ghalf=0.5D0*ggg(k)
4100 c gelc(k,i)=gelc(k,i)+ghalf
4101 c gelc(k,j)=gelc(k,j)+ghalf
4103 c 9/28/08 AL Gradient compotents will be summed only at the end
4104 C print *,"before", gelc_long(1,i), gelc_long(1,j)
4106 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4107 C & +grad_shield(k,j)*eesij/fac_shield(j)
4108 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4109 C & +grad_shield(k,i)*eesij/fac_shield(i)
4110 C gelc_long(k,i-1)=gelc_long(k,i-1)
4111 C & +grad_shield(k,i)*eesij/fac_shield(i)
4112 C gelc_long(k,j-1)=gelc_long(k,j-1)
4113 C & +grad_shield(k,j)*eesij/fac_shield(j)
4115 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4116 C Lipidic part for lipscale
4117 gelc_long(3,j)=gelc_long(3,j)+
4118 & ssgradlipj*eesij/2.0d0*lipscale**2
4120 gelc_long(3,i)=gelc_long(3,i)+
4121 & ssgradlipi*eesij/2.0d0*lipscale**2
4124 * Loop over residues i+1 thru j-1.
4128 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4131 if (sss.gt.0.0) then
4132 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4133 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4135 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4136 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4138 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4139 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4146 c ghalf=0.5D0*ggg(k)
4147 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4148 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4150 c 9/28/08 AL Gradient compotents will be summed only at the end
4152 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4153 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4155 C Lipidic part for scaling weight
4156 gvdwpp(3,j)=gvdwpp(3,j)+
4157 & sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4158 gvdwpp(3,i)=gvdwpp(3,i)+
4159 & sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4162 * Loop over residues i+1 thru j-1.
4166 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4171 facvdw=(ev1+evdwij)*sss
4172 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4175 fac=-3*rrmij*(facvdw+facvdw+facel)
4180 * Radial derivatives. First process both termini of the fragment (i,j)
4183 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4185 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4187 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4189 c ghalf=0.5D0*ggg(k)
4190 c gelc(k,i)=gelc(k,i)+ghalf
4191 c gelc(k,j)=gelc(k,j)+ghalf
4193 c 9/28/08 AL Gradient compotents will be summed only at the end
4195 gelc_long(k,j)=gelc(k,j)+ggg(k)
4196 gelc_long(k,i)=gelc(k,i)-ggg(k)
4199 * Loop over residues i+1 thru j-1.
4203 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4206 c 9/28/08 AL Gradient compotents will be summed only at the end
4207 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4208 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4210 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4211 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4213 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4214 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4216 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4217 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4219 gvdwpp(3,j)=gvdwpp(3,j)+
4220 & sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4221 gvdwpp(3,i)=gvdwpp(3,i)+
4222 & sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4228 ecosa=2.0D0*fac3*fac1+fac4
4231 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4232 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4234 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4235 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4237 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4238 cd & (dcosg(k),k=1,3)
4240 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4241 & fac_shield(i)**2*fac_shield(j)**2
4242 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4245 c ghalf=0.5D0*ggg(k)
4246 c gelc(k,i)=gelc(k,i)+ghalf
4247 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4248 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4249 c gelc(k,j)=gelc(k,j)+ghalf
4250 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4251 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4255 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4258 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4261 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4262 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4263 & *fac_shield(i)**2*fac_shield(j)**2
4264 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4266 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4267 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4268 & *fac_shield(i)**2*fac_shield(j)**2
4269 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4270 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4271 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4273 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4277 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4278 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4279 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4281 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4282 C energy of a peptide unit is assumed in the form of a second-order
4283 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4284 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4285 C are computed for EVERY pair of non-contiguous peptide groups.
4288 if (j.lt.nres-1) then
4300 muij(kkk)=mu(k,i)*mu(l,j)
4301 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4303 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4304 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4305 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4306 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4307 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4308 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4312 cd write (iout,*) 'EELEC: i',i,' j',j
4313 cd write (iout,*) 'j',j,' j1',j1,' j2',j2
4314 cd write(iout,*) 'muij',muij
4315 ury=scalar(uy(1,i),erij)
4316 urz=scalar(uz(1,i),erij)
4317 vry=scalar(uy(1,j),erij)
4318 vrz=scalar(uz(1,j),erij)
4319 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4320 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4321 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4322 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4323 fac=dsqrt(-ael6i)*r3ij
4328 cd write (iout,'(4i5,4f10.5)')
4329 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4330 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4331 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4332 cd & uy(:,j),uz(:,j)
4333 cd write (iout,'(4f10.5)')
4334 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4335 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4336 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4337 cd write (iout,'(9f10.5/)')
4338 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4339 C Derivatives of the elements of A in virtual-bond vectors
4340 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4342 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4343 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4344 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4345 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4346 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4347 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4348 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4349 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4350 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4351 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4352 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4353 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4355 C Compute radial contributions to the gradient
4373 C Add the contributions coming from er
4376 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4377 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4378 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4379 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4382 C Derivatives in DC(i)
4383 cgrad ghalf1=0.5d0*agg(k,1)
4384 cgrad ghalf2=0.5d0*agg(k,2)
4385 cgrad ghalf3=0.5d0*agg(k,3)
4386 cgrad ghalf4=0.5d0*agg(k,4)
4387 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4388 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4389 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4390 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4391 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4392 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4393 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4394 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4395 C Derivatives in DC(i+1)
4396 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4397 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4398 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4399 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4400 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4401 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4402 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4403 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4404 C Derivatives in DC(j)
4405 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4406 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4407 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4408 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4409 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4410 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4411 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4412 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4413 C Derivatives in DC(j+1) or DC(nres-1)
4414 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4415 & -3.0d0*vryg(k,3)*ury)
4416 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4417 & -3.0d0*vrzg(k,3)*ury)
4418 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4419 & -3.0d0*vryg(k,3)*urz)
4420 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4421 & -3.0d0*vrzg(k,3)*urz)
4422 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4424 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4437 aggi(k,l)=-aggi(k,l)
4438 aggi1(k,l)=-aggi1(k,l)
4439 aggj(k,l)=-aggj(k,l)
4440 aggj1(k,l)=-aggj1(k,l)
4443 if (j.lt.nres-1) then
4449 aggi(k,l)=-aggi(k,l)
4450 aggi1(k,l)=-aggi1(k,l)
4451 aggj(k,l)=-aggj(k,l)
4452 aggj1(k,l)=-aggj1(k,l)
4463 aggi(k,l)=-aggi(k,l)
4464 aggi1(k,l)=-aggi1(k,l)
4465 aggj(k,l)=-aggj(k,l)
4466 aggj1(k,l)=-aggj1(k,l)
4471 IF (wel_loc.gt.0.0d0) THEN
4472 C Contribution to the local-electrostatic energy coming from the i-j pair
4473 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4475 if (shield_mode.eq.0) then
4482 eel_loc_ij=eel_loc_ij
4483 & *fac_shield(i)*fac_shield(j)
4484 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4486 C Now derivative over eel_loc
4487 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4488 & (shield_mode.gt.0)) then
4491 do ilist=1,ishield_list(i)
4492 iresshield=shield_list(ilist,i)
4494 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4497 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4499 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4500 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4504 do ilist=1,ishield_list(j)
4505 iresshield=shield_list(ilist,j)
4507 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4510 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4512 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4513 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4520 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4521 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4522 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4523 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4524 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4525 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4526 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4527 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4532 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4533 c & ' eel_loc_ij',eel_loc_ij
4534 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4535 C Calculate patrial derivative for theta angle
4537 geel_loc_ij=(a22*gmuij1(1)
4541 & *fac_shield(i)*fac_shield(j)
4542 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4544 c write(iout,*) "derivative over thatai"
4545 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4547 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4548 & geel_loc_ij*wel_loc
4549 c write(iout,*) "derivative over thatai-1"
4550 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4557 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4558 & geel_loc_ij*wel_loc
4559 & *fac_shield(i)*fac_shield(j)
4560 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4563 c Derivative over j residue
4564 geel_loc_ji=a22*gmuji1(1)
4568 c write(iout,*) "derivative over thataj"
4569 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4572 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4573 & geel_loc_ji*wel_loc
4574 & *fac_shield(i)*fac_shield(j)
4575 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4582 c write(iout,*) "derivative over thataj-1"
4583 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4585 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4586 & geel_loc_ji*wel_loc
4587 & *fac_shield(i)*fac_shield(j)
4588 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4591 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4593 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4594 & 'eelloc',i,j,eel_loc_ij
4595 c if (eel_loc_ij.ne.0)
4596 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4597 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4599 eel_loc=eel_loc+eel_loc_ij
4600 C Partial derivatives in virtual-bond dihedral angles gamma
4602 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4603 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4604 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4605 & *fac_shield(i)*fac_shield(j)
4606 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4608 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4609 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4610 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4611 & *fac_shield(i)*fac_shield(j)
4612 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4614 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4616 ggg(l)=(agg(l,1)*muij(1)+
4617 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4618 & *fac_shield(i)*fac_shield(j)
4619 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4621 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4622 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4623 cgrad ghalf=0.5d0*ggg(l)
4624 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4625 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4627 gel_loc_long(3,j)=gel_loc_long(3,j)+
4628 & ssgradlipj*eel_loc_ij/2.0d0*lipscale/
4629 & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4631 gel_loc_long(3,i)=gel_loc_long(3,i)+
4632 & ssgradlipi*eel_loc_ij/2.0d0*lipscale/
4633 & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4637 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4640 C Remaining derivatives of eello
4642 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4643 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4644 & *fac_shield(i)*fac_shield(j)
4645 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4647 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4648 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4649 & *fac_shield(i)*fac_shield(j)
4650 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4652 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4653 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4654 & *fac_shield(i)*fac_shield(j)
4655 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4657 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4658 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4659 & *fac_shield(i)*fac_shield(j)
4660 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4664 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4665 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4666 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4667 & .and. num_conti.le.maxconts) then
4668 c write (iout,*) i,j," entered corr"
4670 C Calculate the contact function. The ith column of the array JCONT will
4671 C contain the numbers of atoms that make contacts with the atom I (of numbers
4672 C greater than I). The arrays FACONT and GACONT will contain the values of
4673 C the contact function and its derivative.
4674 c r0ij=1.02D0*rpp(iteli,itelj)
4675 c r0ij=1.11D0*rpp(iteli,itelj)
4676 r0ij=2.20D0*rpp(iteli,itelj)
4677 c r0ij=1.55D0*rpp(iteli,itelj)
4678 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4679 if (fcont.gt.0.0D0) then
4680 num_conti=num_conti+1
4681 if (num_conti.gt.maxconts) then
4682 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4683 & ' will skip next contacts for this conf.'
4685 jcont_hb(num_conti,i)=j
4686 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4687 cd & " jcont_hb",jcont_hb(num_conti,i)
4688 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4689 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4690 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4692 d_cont(num_conti,i)=rij
4693 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4694 C --- Electrostatic-interaction matrix ---
4695 a_chuj(1,1,num_conti,i)=a22
4696 a_chuj(1,2,num_conti,i)=a23
4697 a_chuj(2,1,num_conti,i)=a32
4698 a_chuj(2,2,num_conti,i)=a33
4699 C --- Gradient of rij
4701 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4708 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4709 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4710 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4711 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4712 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4717 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4718 C Calculate contact energies
4720 wij=cosa-3.0D0*cosb*cosg
4723 c fac3=dsqrt(-ael6i)/r0ij**3
4724 fac3=dsqrt(-ael6i)*r3ij
4725 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4726 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4727 if (ees0tmp.gt.0) then
4728 ees0pij=dsqrt(ees0tmp)
4732 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4733 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4734 if (ees0tmp.gt.0) then
4735 ees0mij=dsqrt(ees0tmp)
4740 if (shield_mode.eq.0) then
4744 ees0plist(num_conti,i)=j
4745 C fac_shield(i)=0.4d0
4746 C fac_shield(j)=0.6d0
4748 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4749 & *fac_shield(i)*fac_shield(j)
4750 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4751 & *fac_shield(i)*fac_shield(j)
4752 C Diagnostics. Comment out or remove after debugging!
4753 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4754 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4755 c ees0m(num_conti,i)=0.0D0
4757 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4758 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4759 C Angular derivatives of the contact function
4760 ees0pij1=fac3/ees0pij
4761 ees0mij1=fac3/ees0mij
4762 fac3p=-3.0D0*fac3*rrmij
4763 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4764 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4766 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4767 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4768 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4769 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4770 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4771 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4772 ecosap=ecosa1+ecosa2
4773 ecosbp=ecosb1+ecosb2
4774 ecosgp=ecosg1+ecosg2
4775 ecosam=ecosa1-ecosa2
4776 ecosbm=ecosb1-ecosb2
4777 ecosgm=ecosg1-ecosg2
4786 facont_hb(num_conti,i)=fcont
4787 fprimcont=fprimcont/rij
4788 cd facont_hb(num_conti,i)=1.0D0
4789 C Following line is for diagnostics.
4792 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4793 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4796 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4797 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4799 gggp(1)=gggp(1)+ees0pijp*xj
4800 gggp(2)=gggp(2)+ees0pijp*yj
4801 gggp(3)=gggp(3)+ees0pijp*zj
4802 gggm(1)=gggm(1)+ees0mijp*xj
4803 gggm(2)=gggm(2)+ees0mijp*yj
4804 gggm(3)=gggm(3)+ees0mijp*zj
4805 C Derivatives due to the contact function
4806 gacont_hbr(1,num_conti,i)=fprimcont*xj
4807 gacont_hbr(2,num_conti,i)=fprimcont*yj
4808 gacont_hbr(3,num_conti,i)=fprimcont*zj
4811 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4812 c following the change of gradient-summation algorithm.
4814 cgrad ghalfp=0.5D0*gggp(k)
4815 cgrad ghalfm=0.5D0*gggm(k)
4816 gacontp_hb1(k,num_conti,i)=!ghalfp
4817 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4818 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4819 & *fac_shield(i)*fac_shield(j)
4821 gacontp_hb2(k,num_conti,i)=!ghalfp
4822 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4823 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4824 & *fac_shield(i)*fac_shield(j)
4826 gacontp_hb3(k,num_conti,i)=gggp(k)
4827 & *fac_shield(i)*fac_shield(j)
4829 gacontm_hb1(k,num_conti,i)=!ghalfm
4830 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4831 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4832 & *fac_shield(i)*fac_shield(j)
4834 gacontm_hb2(k,num_conti,i)=!ghalfm
4835 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4836 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4837 & *fac_shield(i)*fac_shield(j)
4839 gacontm_hb3(k,num_conti,i)=gggm(k)
4840 & *fac_shield(i)*fac_shield(j)
4843 C Diagnostics. Comment out or remove after debugging!
4845 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4846 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4847 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4848 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4849 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4850 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4853 endif ! num_conti.le.maxconts
4856 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4859 ghalf=0.5d0*agg(l,k)
4860 aggi(l,k)=aggi(l,k)+ghalf
4861 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4862 aggj(l,k)=aggj(l,k)+ghalf
4865 if (j.eq.nres-1 .and. i.lt.j-2) then
4868 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4873 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4876 C-----------------------------------------------------------------------------
4877 subroutine eturn3(i,eello_turn3)
4878 C Third- and fourth-order contributions from turns
4879 implicit real*8 (a-h,o-z)
4880 include 'DIMENSIONS'
4881 include 'COMMON.IOUNITS'
4882 include 'COMMON.GEO'
4883 include 'COMMON.VAR'
4884 include 'COMMON.LOCAL'
4885 include 'COMMON.CHAIN'
4886 include 'COMMON.DERIV'
4887 include 'COMMON.INTERACT'
4888 include 'COMMON.CONTACTS'
4889 include 'COMMON.TORSION'
4890 include 'COMMON.VECTORS'
4891 include 'COMMON.FFIELD'
4892 include 'COMMON.CONTROL'
4893 include 'COMMON.SHIELD'
4895 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4896 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4897 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4898 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4899 & auxgmat2(2,2),auxgmatt2(2,2)
4900 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4901 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4902 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4903 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4906 C xj=(c(1,j)+c(1,j+1))/2.0d0
4907 C yj=(c(2,j)+c(2,j+1))/2.0d0
4908 zj=(c(3,j)+c(3,j+1))/2.0d0
4909 C xj=mod(xj,boxxsize)
4910 C if (xj.lt.0) xj=xj+boxxsize
4911 C yj=mod(yj,boxysize)
4912 C if (yj.lt.0) yj=yj+boxysize
4914 if (zj.lt.0) zj=zj+boxzsize
4915 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4916 if ((zj.gt.bordlipbot)
4917 &.and.(zj.lt.bordliptop)) then
4918 C the energy transfer exist
4919 if (zj.lt.buflipbot) then
4920 C what fraction I am in
4922 & ((zj-bordlipbot)/lipbufthick)
4923 C lipbufthick is thickenes of lipid buffore
4924 sslipj=sscalelip(fracinbuf)
4925 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4926 elseif (zj.gt.bufliptop) then
4927 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4928 sslipj=sscalelip(fracinbuf)
4929 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4941 C write (iout,*) "eturn3",i,j,j1,j2
4946 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4948 C Third-order contributions
4955 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4956 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4957 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4958 c auxalary matices for theta gradient
4959 c auxalary matrix for i+1 and constant i+2
4960 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4961 c auxalary matrix for i+2 and constant i+1
4962 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4963 call transpose2(auxmat(1,1),auxmat1(1,1))
4964 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4965 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4966 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4967 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4968 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4969 if (shield_mode.eq.0) then
4977 C & write(iout,*) i,j,fac_shield(i),fac_shield(j)
4978 eello_turn3=eello_turn3+
4979 C & 1.0*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4980 &0.5d0*(pizda(1,1)+pizda(2,2))
4981 & *fac_shield(i)*fac_shield(j)
4982 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4984 &0.5d0*(pizda(1,1)+pizda(2,2))
4985 & *fac_shield(i)*fac_shield(j)
4987 C Derivatives in theta
4988 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4989 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4990 & *fac_shield(i)*fac_shield(j)
4991 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4993 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4994 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4995 & *fac_shield(i)*fac_shield(j)
4996 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5000 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5001 C Derivatives in shield mode
5002 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5003 & (shield_mode.gt.0)) then
5006 do ilist=1,ishield_list(i)
5007 iresshield=shield_list(ilist,i)
5009 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5011 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5013 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5014 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5018 do ilist=1,ishield_list(j)
5019 iresshield=shield_list(ilist,j)
5021 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5023 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5025 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5026 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5033 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5034 & grad_shield(k,i)*eello_t3/fac_shield(i)
5035 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5036 & grad_shield(k,j)*eello_t3/fac_shield(j)
5037 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5038 & grad_shield(k,i)*eello_t3/fac_shield(i)
5039 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5040 & grad_shield(k,j)*eello_t3/fac_shield(j)
5044 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5045 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
5046 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
5047 cd & ' eello_turn3_num',4*eello_turn3_num
5048 C Derivatives in gamma(i)
5049 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5050 call transpose2(auxmat2(1,1),auxmat3(1,1))
5051 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5052 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5053 & *fac_shield(i)*fac_shield(j)
5054 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5056 C Derivatives in gamma(i+1)
5057 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5058 call transpose2(auxmat2(1,1),auxmat3(1,1))
5059 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5060 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5061 & +0.5d0*(pizda(1,1)+pizda(2,2))
5062 & *fac_shield(i)*fac_shield(j)
5063 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5065 C Cartesian derivatives
5067 c ghalf1=0.5d0*agg(l,1)
5068 c ghalf2=0.5d0*agg(l,2)
5069 c ghalf3=0.5d0*agg(l,3)
5070 c ghalf4=0.5d0*agg(l,4)
5071 a_temp(1,1)=aggi(l,1)!+ghalf1
5072 a_temp(1,2)=aggi(l,2)!+ghalf2
5073 a_temp(2,1)=aggi(l,3)!+ghalf3
5074 a_temp(2,2)=aggi(l,4)!+ghalf4
5075 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5076 gcorr3_turn(l,i)=gcorr3_turn(l,i)
5077 & +0.5d0*(pizda(1,1)+pizda(2,2))
5078 & *fac_shield(i)*fac_shield(j)
5079 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5081 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5082 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5083 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5084 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5085 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5086 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5087 & +0.5d0*(pizda(1,1)+pizda(2,2))
5088 & *fac_shield(i)*fac_shield(j)
5089 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5090 a_temp(1,1)=aggj(l,1)!+ghalf1
5091 a_temp(1,2)=aggj(l,2)!+ghalf2
5092 a_temp(2,1)=aggj(l,3)!+ghalf3
5093 a_temp(2,2)=aggj(l,4)!+ghalf4
5094 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5095 gcorr3_turn(l,j)=gcorr3_turn(l,j)
5096 & +0.5d0*(pizda(1,1)+pizda(2,2))
5097 & *fac_shield(i)*fac_shield(j)
5098 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5100 a_temp(1,1)=aggj1(l,1)
5101 a_temp(1,2)=aggj1(l,2)
5102 a_temp(2,1)=aggj1(l,3)
5103 a_temp(2,2)=aggj1(l,4)
5104 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5105 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5106 & +0.5d0*(pizda(1,1)+pizda(2,2))
5107 & *fac_shield(i)*fac_shield(j)
5108 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5110 gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5111 & ssgradlipi*eello_t3/4.0d0*lipscale
5112 gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5113 & ssgradlipj*eello_t3/4.0d0*lipscale
5114 gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5115 & ssgradlipi*eello_t3/4.0d0*lipscale
5116 gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5117 & ssgradlipj*eello_t3/4.0d0*lipscale
5119 C print *,ssgradlipi,ssgradlipj,eello_t3,sslipi,sslipj
5122 C-------------------------------------------------------------------------------
5123 subroutine eturn4(i,eello_turn4)
5124 C Third- and fourth-order contributions from turns
5125 implicit real*8 (a-h,o-z)
5126 include 'DIMENSIONS'
5127 include 'COMMON.IOUNITS'
5128 include 'COMMON.GEO'
5129 include 'COMMON.VAR'
5130 include 'COMMON.LOCAL'
5131 include 'COMMON.CHAIN'
5132 include 'COMMON.DERIV'
5133 include 'COMMON.INTERACT'
5134 include 'COMMON.CONTACTS'
5135 include 'COMMON.TORSION'
5136 include 'COMMON.VECTORS'
5137 include 'COMMON.FFIELD'
5138 include 'COMMON.CONTROL'
5139 include 'COMMON.SHIELD'
5141 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5142 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5143 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5144 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5145 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
5146 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5147 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5148 double precision agg(3,4),aggi(3,4),aggi1(3,4),
5149 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5150 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5151 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5154 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5156 C Fourth-order contributions
5164 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5165 cd call checkint_turn4(i,a_temp,eello_turn4_num)
5166 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5167 c write(iout,*)"WCHODZE W PROGRAM"
5168 zj=(c(3,j)+c(3,j+1))/2.0d0
5169 C xj=mod(xj,boxxsize)
5170 C if (xj.lt.0) xj=xj+boxxsize
5171 C yj=mod(yj,boxysize)
5172 C if (yj.lt.0) yj=yj+boxysize
5174 if (zj.lt.0) zj=zj+boxzsize
5175 C if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
5176 if ((zj.gt.bordlipbot)
5177 &.and.(zj.lt.bordliptop)) then
5178 C the energy transfer exist
5179 if (zj.lt.buflipbot) then
5180 C what fraction I am in
5182 & ((zj-bordlipbot)/lipbufthick)
5183 C lipbufthick is thickenes of lipid buffore
5184 sslipj=sscalelip(fracinbuf)
5185 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5186 elseif (zj.gt.bufliptop) then
5187 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5188 sslipj=sscalelip(fracinbuf)
5189 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5203 iti1=itype2loc(itype(i+1))
5204 iti2=itype2loc(itype(i+2))
5205 iti3=itype2loc(itype(i+3))
5206 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5207 call transpose2(EUg(1,1,i+1),e1t(1,1))
5208 call transpose2(Eug(1,1,i+2),e2t(1,1))
5209 call transpose2(Eug(1,1,i+3),e3t(1,1))
5210 C Ematrix derivative in theta
5211 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5212 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5213 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5214 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5215 c eta1 in derivative theta
5216 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5217 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5218 c auxgvec is derivative of Ub2 so i+3 theta
5219 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5220 c auxalary matrix of E i+1
5221 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5224 s1=scalar2(b1(1,i+2),auxvec(1))
5225 c derivative of theta i+2 with constant i+3
5226 gs23=scalar2(gtb1(1,i+2),auxvec(1))
5227 c derivative of theta i+2 with constant i+2
5228 gs32=scalar2(b1(1,i+2),auxgvec(1))
5229 c derivative of E matix in theta of i+1
5230 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5232 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5233 c ea31 in derivative theta
5234 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5235 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5236 c auxilary matrix auxgvec of Ub2 with constant E matirx
5237 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5238 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5239 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5243 s2=scalar2(b1(1,i+1),auxvec(1))
5244 c derivative of theta i+1 with constant i+3
5245 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5246 c derivative of theta i+2 with constant i+1
5247 gs21=scalar2(b1(1,i+1),auxgvec(1))
5248 c derivative of theta i+3 with constant i+1
5249 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5250 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5252 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5253 c two derivatives over diffetent matrices
5254 c gtae3e2 is derivative over i+3
5255 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5256 c ae3gte2 is derivative over i+2
5257 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5258 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5259 c three possible derivative over theta E matices
5261 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5263 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5265 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5266 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5268 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5269 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5270 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5271 if (shield_mode.eq.0) then
5278 eello_turn4=eello_turn4-(s1+s2+s3)
5279 & *fac_shield(i)*fac_shield(j)
5280 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5282 eello_t4=-(s1+s2+s3)
5283 & *fac_shield(i)*fac_shield(j)
5284 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5285 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5286 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5287 C Now derivative over shield:
5288 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5289 & (shield_mode.gt.0)) then
5292 do ilist=1,ishield_list(i)
5293 iresshield=shield_list(ilist,i)
5295 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5297 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5299 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5300 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5304 do ilist=1,ishield_list(j)
5305 iresshield=shield_list(ilist,j)
5307 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5309 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5311 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5312 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5319 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5320 & grad_shield(k,i)*eello_t4/fac_shield(i)
5321 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5322 & grad_shield(k,j)*eello_t4/fac_shield(j)
5323 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5324 & grad_shield(k,i)*eello_t4/fac_shield(i)
5325 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5326 & grad_shield(k,j)*eello_t4/fac_shield(j)
5335 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5336 cd & ' eello_turn4_num',8*eello_turn4_num
5338 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5339 & -(gs13+gsE13+gsEE1)*wturn4
5340 & *fac_shield(i)*fac_shield(j)
5341 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5343 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5344 & -(gs23+gs21+gsEE2)*wturn4
5345 & *fac_shield(i)*fac_shield(j)
5346 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5348 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5349 & -(gs32+gsE31+gsEE3)*wturn4
5350 & *fac_shield(i)*fac_shield(j)
5351 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5353 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5356 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5357 & 'eturn4',i,j,-(s1+s2+s3)
5358 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5359 c & ' eello_turn4_num',8*eello_turn4_num
5360 C Derivatives in gamma(i)
5361 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5362 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5363 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5364 s1=scalar2(b1(1,i+2),auxvec(1))
5365 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5366 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5367 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5368 & *fac_shield(i)*fac_shield(j)
5369 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5371 C Derivatives in gamma(i+1)
5372 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5373 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5374 s2=scalar2(b1(1,i+1),auxvec(1))
5375 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5376 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5377 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5378 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5379 & *fac_shield(i)*fac_shield(j)
5380 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5382 C Derivatives in gamma(i+2)
5383 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5384 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5385 s1=scalar2(b1(1,i+2),auxvec(1))
5386 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5387 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5388 s2=scalar2(b1(1,i+1),auxvec(1))
5389 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5390 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5391 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5392 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5393 & *fac_shield(i)*fac_shield(j)
5394 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5396 C Cartesian derivatives
5397 C Derivatives of this turn contributions in DC(i+2)
5398 if (j.lt.nres-1) then
5400 a_temp(1,1)=agg(l,1)
5401 a_temp(1,2)=agg(l,2)
5402 a_temp(2,1)=agg(l,3)
5403 a_temp(2,2)=agg(l,4)
5404 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5405 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5406 s1=scalar2(b1(1,i+2),auxvec(1))
5407 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5408 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5409 s2=scalar2(b1(1,i+1),auxvec(1))
5410 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5411 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5412 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5414 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5415 & *fac_shield(i)*fac_shield(j)
5416 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5420 C Remaining derivatives of this turn contribution
5422 a_temp(1,1)=aggi(l,1)
5423 a_temp(1,2)=aggi(l,2)
5424 a_temp(2,1)=aggi(l,3)
5425 a_temp(2,2)=aggi(l,4)
5426 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5427 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5428 s1=scalar2(b1(1,i+2),auxvec(1))
5429 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5430 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5431 s2=scalar2(b1(1,i+1),auxvec(1))
5432 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5433 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5434 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5435 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5436 & *fac_shield(i)*fac_shield(j)
5437 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5439 a_temp(1,1)=aggi1(l,1)
5440 a_temp(1,2)=aggi1(l,2)
5441 a_temp(2,1)=aggi1(l,3)
5442 a_temp(2,2)=aggi1(l,4)
5443 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5444 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5445 s1=scalar2(b1(1,i+2),auxvec(1))
5446 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5447 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5448 s2=scalar2(b1(1,i+1),auxvec(1))
5449 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5450 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5451 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5452 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5453 & *fac_shield(i)*fac_shield(j)
5454 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5456 a_temp(1,1)=aggj(l,1)
5457 a_temp(1,2)=aggj(l,2)
5458 a_temp(2,1)=aggj(l,3)
5459 a_temp(2,2)=aggj(l,4)
5460 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5461 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5462 s1=scalar2(b1(1,i+2),auxvec(1))
5463 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5464 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5465 s2=scalar2(b1(1,i+1),auxvec(1))
5466 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5467 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5468 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5469 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5470 & *fac_shield(i)*fac_shield(j)
5471 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5473 a_temp(1,1)=aggj1(l,1)
5474 a_temp(1,2)=aggj1(l,2)
5475 a_temp(2,1)=aggj1(l,3)
5476 a_temp(2,2)=aggj1(l,4)
5477 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5478 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5479 s1=scalar2(b1(1,i+2),auxvec(1))
5480 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5481 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5482 s2=scalar2(b1(1,i+1),auxvec(1))
5483 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5484 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5485 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5486 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5487 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5488 & *fac_shield(i)*fac_shield(j)
5489 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5491 gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5492 & ssgradlipi*eello_t4/4.0d0*lipscale
5493 gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5494 & ssgradlipj*eello_t4/4.0d0*lipscale
5495 gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5496 & ssgradlipi*eello_t4/4.0d0*lipscale
5497 gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5498 & ssgradlipj*eello_t4/4.0d0*lipscale
5501 C-----------------------------------------------------------------------------
5502 subroutine vecpr(u,v,w)
5503 implicit real*8(a-h,o-z)
5504 dimension u(3),v(3),w(3)
5505 w(1)=u(2)*v(3)-u(3)*v(2)
5506 w(2)=-u(1)*v(3)+u(3)*v(1)
5507 w(3)=u(1)*v(2)-u(2)*v(1)
5510 C-----------------------------------------------------------------------------
5511 subroutine unormderiv(u,ugrad,unorm,ungrad)
5512 C This subroutine computes the derivatives of a normalized vector u, given
5513 C the derivatives computed without normalization conditions, ugrad. Returns
5516 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5517 double precision vec(3)
5518 double precision scalar
5520 c write (2,*) 'ugrad',ugrad
5523 vec(i)=scalar(ugrad(1,i),u(1))
5525 c write (2,*) 'vec',vec
5528 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5531 c write (2,*) 'ungrad',ungrad
5534 C-----------------------------------------------------------------------------
5535 subroutine escp_soft_sphere(evdw2,evdw2_14)
5537 C This subroutine calculates the excluded-volume interaction energy between
5538 C peptide-group centers and side chains and its gradient in virtual-bond and
5539 C side-chain vectors.
5541 implicit real*8 (a-h,o-z)
5542 include 'DIMENSIONS'
5543 include 'COMMON.GEO'
5544 include 'COMMON.VAR'
5545 include 'COMMON.LOCAL'
5546 include 'COMMON.CHAIN'
5547 include 'COMMON.DERIV'
5548 include 'COMMON.INTERACT'
5549 include 'COMMON.FFIELD'
5550 include 'COMMON.IOUNITS'
5551 include 'COMMON.CONTROL'
5556 cd print '(a)','Enter ESCP'
5557 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5561 do i=iatscp_s,iatscp_e
5562 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5564 xi=0.5D0*(c(1,i)+c(1,i+1))
5565 yi=0.5D0*(c(2,i)+c(2,i+1))
5566 zi=0.5D0*(c(3,i)+c(3,i+1))
5567 C Return atom into box, boxxsize is size of box in x dimension
5569 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5570 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5571 C Condition for being inside the proper box
5572 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5573 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5577 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5578 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5579 C Condition for being inside the proper box
5580 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5581 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5585 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5586 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5587 cC Condition for being inside the proper box
5588 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5589 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5593 if (xi.lt.0) xi=xi+boxxsize
5595 if (yi.lt.0) yi=yi+boxysize
5597 if (zi.lt.0) zi=zi+boxzsize
5598 C xi=xi+xshift*boxxsize
5599 C yi=yi+yshift*boxysize
5600 C zi=zi+zshift*boxzsize
5601 do iint=1,nscp_gr(i)
5603 do j=iscpstart(i,iint),iscpend(i,iint)
5604 if (itype(j).eq.ntyp1) cycle
5605 itypj=iabs(itype(j))
5606 C Uncomment following three lines for SC-p interactions
5610 C Uncomment following three lines for Ca-p interactions
5615 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5616 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5617 C Condition for being inside the proper box
5618 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5619 c & (xj.lt.((-0.5d0)*boxxsize))) then
5623 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5624 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5625 cC Condition for being inside the proper box
5626 c if ((yj.gt.((0.5d0)*boxysize)).or.
5627 c & (yj.lt.((-0.5d0)*boxysize))) then
5631 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5632 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5633 C Condition for being inside the proper box
5634 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5635 c & (zj.lt.((-0.5d0)*boxzsize))) then
5638 if (xj.lt.0) xj=xj+boxxsize
5640 if (yj.lt.0) yj=yj+boxysize
5642 if (zj.lt.0) zj=zj+boxzsize
5643 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5651 xj=xj_safe+xshift*boxxsize
5652 yj=yj_safe+yshift*boxysize
5653 zj=zj_safe+zshift*boxzsize
5654 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5655 if(dist_temp.lt.dist_init) then
5665 if (subchap.eq.1) then
5678 rij=xj*xj+yj*yj+zj*zj
5682 if (rij.lt.r0ijsq) then
5683 evdwij=0.25d0*(rij-r0ijsq)**2
5691 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5696 cgrad if (j.lt.i) then
5697 cd write (iout,*) 'j<i'
5698 C Uncomment following three lines for SC-p interactions
5700 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5703 cd write (iout,*) 'j>i'
5705 cgrad ggg(k)=-ggg(k)
5706 C Uncomment following line for SC-p interactions
5707 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5711 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5713 cgrad kstart=min0(i+1,j)
5714 cgrad kend=max0(i-1,j-1)
5715 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5716 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5717 cgrad do k=kstart,kend
5719 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5723 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5724 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5735 C-----------------------------------------------------------------------------
5736 subroutine escp(evdw2,evdw2_14)
5738 C This subroutine calculates the excluded-volume interaction energy between
5739 C peptide-group centers and side chains and its gradient in virtual-bond and
5740 C side-chain vectors.
5742 implicit real*8 (a-h,o-z)
5743 include 'DIMENSIONS'
5744 include 'COMMON.GEO'
5745 include 'COMMON.VAR'
5746 include 'COMMON.LOCAL'
5747 include 'COMMON.CHAIN'
5748 include 'COMMON.DERIV'
5749 include 'COMMON.INTERACT'
5750 include 'COMMON.FFIELD'
5751 include 'COMMON.IOUNITS'
5752 include 'COMMON.CONTROL'
5753 include 'COMMON.SPLITELE'
5757 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5758 cd print '(a)','Enter ESCP'
5759 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5763 do i=iatscp_s,iatscp_e
5764 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5766 xi=0.5D0*(c(1,i)+c(1,i+1))
5767 yi=0.5D0*(c(2,i)+c(2,i+1))
5768 zi=0.5D0*(c(3,i)+c(3,i+1))
5770 if (xi.lt.0) xi=xi+boxxsize
5772 if (yi.lt.0) yi=yi+boxysize
5774 if (zi.lt.0) zi=zi+boxzsize
5775 c xi=xi+xshift*boxxsize
5776 c yi=yi+yshift*boxysize
5777 c zi=zi+zshift*boxzsize
5778 c print *,xi,yi,zi,'polozenie i'
5779 C Return atom into box, boxxsize is size of box in x dimension
5781 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5782 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5783 C Condition for being inside the proper box
5784 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5785 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5789 c print *,xi,boxxsize,"pierwszy"
5791 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5792 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5793 C Condition for being inside the proper box
5794 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5795 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5799 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5800 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5801 C Condition for being inside the proper box
5802 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5803 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5806 do iint=1,nscp_gr(i)
5808 do j=iscpstart(i,iint),iscpend(i,iint)
5809 itypj=iabs(itype(j))
5810 if (itypj.eq.ntyp1) cycle
5811 C Uncomment following three lines for SC-p interactions
5815 C Uncomment following three lines for Ca-p interactions
5820 if (xj.lt.0) xj=xj+boxxsize
5822 if (yj.lt.0) yj=yj+boxysize
5824 if (zj.lt.0) zj=zj+boxzsize
5826 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5827 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5828 C Condition for being inside the proper box
5829 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5830 c & (xj.lt.((-0.5d0)*boxxsize))) then
5834 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5835 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5836 cC Condition for being inside the proper box
5837 c if ((yj.gt.((0.5d0)*boxysize)).or.
5838 c & (yj.lt.((-0.5d0)*boxysize))) then
5842 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5843 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5844 C Condition for being inside the proper box
5845 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5846 c & (zj.lt.((-0.5d0)*boxzsize))) then
5849 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5850 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5858 xj=xj_safe+xshift*boxxsize
5859 yj=yj_safe+yshift*boxysize
5860 zj=zj_safe+zshift*boxzsize
5861 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5862 if(dist_temp.lt.dist_init) then
5872 if (subchap.eq.1) then
5881 c print *,xj,yj,zj,'polozenie j'
5882 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5884 sss=sscale(1.0d0/(dsqrt(rrij)))
5885 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5886 c if (sss.eq.0) print *,'czasem jest OK'
5887 if (sss.le.0.0d0) cycle
5888 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5890 e1=fac*fac*aad(itypj,iteli)
5891 e2=fac*bad(itypj,iteli)
5892 if (iabs(j-i) .le. 2) then
5895 evdw2_14=evdw2_14+(e1+e2)*sss
5898 evdw2=evdw2+evdwij*sss
5899 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5900 & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5903 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5905 fac=-(evdwij+e1)*rrij*sss
5906 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5910 cgrad if (j.lt.i) then
5911 cd write (iout,*) 'j<i'
5912 C Uncomment following three lines for SC-p interactions
5914 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5917 cd write (iout,*) 'j>i'
5919 cgrad ggg(k)=-ggg(k)
5920 C Uncomment following line for SC-p interactions
5921 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5922 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5926 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5928 cgrad kstart=min0(i+1,j)
5929 cgrad kend=max0(i-1,j-1)
5930 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5931 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5932 cgrad do k=kstart,kend
5934 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5938 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5939 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5941 c endif !endif for sscale cutoff
5951 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5952 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5953 gradx_scp(j,i)=expon*gradx_scp(j,i)
5956 C******************************************************************************
5960 C To save time the factor EXPON has been extracted from ALL components
5961 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5964 C******************************************************************************
5967 C--------------------------------------------------------------------------
5968 subroutine edis(ehpb)
5970 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5972 implicit real*8 (a-h,o-z)
5973 include 'DIMENSIONS'
5974 include 'COMMON.SBRIDGE'
5975 include 'COMMON.CHAIN'
5976 include 'COMMON.DERIV'
5977 include 'COMMON.VAR'
5978 include 'COMMON.INTERACT'
5979 include 'COMMON.IOUNITS'
5980 include 'COMMON.CONTROL'
5986 C write (iout,*) ,"link_end",link_end,constr_dist
5987 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5988 cd write(iout,*)'link_start=',link_start,' link_end=',link_end
5989 if (link_end.eq.0) return
5990 do i=link_start,link_end
5991 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5992 C CA-CA distance used in regularization of structure.
5995 C iii and jjj point to the residues for which the distance is assigned.
5996 if (ii.gt.nres) then
6003 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6004 c & dhpb(i),dhpb1(i),forcon(i)
6005 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6006 C distance and angle dependent SS bond potential.
6007 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6008 C & iabs(itype(jjj)).eq.1) then
6009 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6010 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6011 if (.not.dyn_ss .and. i.le.nss) then
6012 C 15/02/13 CC dynamic SSbond - additional check
6013 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6014 & iabs(itype(jjj)).eq.1) then
6015 call ssbond_ene(iii,jjj,eij)
6018 cd write (iout,*) "eij",eij
6019 cd & ' waga=',waga,' fac=',fac
6020 else if (ii.gt.nres .and. jj.gt.nres) then
6021 c Restraints from contact prediction
6023 if (constr_dist.eq.11) then
6024 ehpb=ehpb+fordepth(i)**4.0d0
6025 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6026 fac=fordepth(i)**4.0d0
6027 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6028 if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6029 & ehpb,fordepth(i),dd
6031 if (dhpb1(i).gt.0.0d0) then
6032 ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6033 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6034 c write (iout,*) "beta nmr",
6035 c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6039 C Get the force constant corresponding to this distance.
6041 C Calculate the contribution to energy.
6042 ehpb=ehpb+waga*rdis*rdis
6043 c write (iout,*) "beta reg",dd,waga*rdis*rdis
6045 C Evaluate gradient.
6051 ggg(j)=fac*(c(j,jj)-c(j,ii))
6054 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6055 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6058 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6059 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6062 C Calculate the distance between the two points and its difference from the
6065 if (constr_dist.eq.11) then
6066 ehpb=ehpb+fordepth(i)**4.0d0
6067 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6068 fac=fordepth(i)**4.0d0
6069 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6070 if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6071 & ehpb,fordepth(i),dd
6073 if (dhpb1(i).gt.0.0d0) then
6074 ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6075 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6076 c write (iout,*) "alph nmr",
6077 c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6080 C Get the force constant corresponding to this distance.
6082 C Calculate the contribution to energy.
6083 ehpb=ehpb+waga*rdis*rdis
6084 c write (iout,*) "alpha reg",dd,waga*rdis*rdis
6086 C Evaluate gradient.
6092 ggg(j)=fac*(c(j,jj)-c(j,ii))
6094 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6095 C If this is a SC-SC distance, we need to calculate the contributions to the
6096 C Cartesian gradient in the SC vectors (ghpbx).
6099 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6100 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6103 cgrad do j=iii,jjj-1
6105 cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k)
6109 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6110 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6114 if (constr_dist.ne.11) ehpb=0.5D0*ehpb
6117 C--------------------------------------------------------------------------
6118 subroutine ssbond_ene(i,j,eij)
6120 C Calculate the distance and angle dependent SS-bond potential energy
6121 C using a free-energy function derived based on RHF/6-31G** ab initio
6122 C calculations of diethyl disulfide.
6124 C A. Liwo and U. Kozlowska, 11/24/03
6126 implicit real*8 (a-h,o-z)
6127 include 'DIMENSIONS'
6128 include 'COMMON.SBRIDGE'
6129 include 'COMMON.CHAIN'
6130 include 'COMMON.DERIV'
6131 include 'COMMON.LOCAL'
6132 include 'COMMON.INTERACT'
6133 include 'COMMON.VAR'
6134 include 'COMMON.IOUNITS'
6135 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6136 itypi=iabs(itype(i))
6140 dxi=dc_norm(1,nres+i)
6141 dyi=dc_norm(2,nres+i)
6142 dzi=dc_norm(3,nres+i)
6143 c dsci_inv=dsc_inv(itypi)
6144 dsci_inv=vbld_inv(nres+i)
6145 itypj=iabs(itype(j))
6146 c dscj_inv=dsc_inv(itypj)
6147 dscj_inv=vbld_inv(nres+j)
6151 dxj=dc_norm(1,nres+j)
6152 dyj=dc_norm(2,nres+j)
6153 dzj=dc_norm(3,nres+j)
6154 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6159 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6160 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6161 om12=dxi*dxj+dyi*dyj+dzi*dzj
6163 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6164 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6170 deltat12=om2-om1+2.0d0
6172 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6173 & +akct*deltad*deltat12
6174 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6175 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6176 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6177 c & " deltat12",deltat12," eij",eij
6178 ed=2*akcm*deltad+akct*deltat12
6180 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6181 eom1=-2*akth*deltat1-pom1-om2*pom2
6182 eom2= 2*akth*deltat2+pom1-om1*pom2
6185 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6186 ghpbx(k,i)=ghpbx(k,i)-ggk
6187 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6188 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6189 ghpbx(k,j)=ghpbx(k,j)+ggk
6190 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6191 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6192 ghpbc(k,i)=ghpbc(k,i)-ggk
6193 ghpbc(k,j)=ghpbc(k,j)+ggk
6196 C Calculate the components of the gradient in DC and X
6200 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
6205 C--------------------------------------------------------------------------
6206 subroutine ebond(estr)
6208 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6210 implicit real*8 (a-h,o-z)
6211 include 'DIMENSIONS'
6212 include 'COMMON.LOCAL'
6213 include 'COMMON.GEO'
6214 include 'COMMON.INTERACT'
6215 include 'COMMON.DERIV'
6216 include 'COMMON.VAR'
6217 include 'COMMON.CHAIN'
6218 include 'COMMON.IOUNITS'
6219 include 'COMMON.NAMES'
6220 include 'COMMON.FFIELD'
6221 include 'COMMON.CONTROL'
6222 include 'COMMON.SETUP'
6223 double precision u(3),ud(3)
6226 do i=ibondp_start,ibondp_end
6227 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6228 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6230 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6231 c & *dc(j,i-1)/vbld(i)
6233 c if (energy_dec) write(iout,*)
6234 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6236 C Checking if it involves dummy (NH3+ or COO-) group
6237 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6238 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
6239 diff = vbld(i)-vbldpDUM
6240 if (energy_dec) write(iout,*) "dum_bond",i,diff
6242 C NO vbldp0 is the equlibrium lenght of spring for peptide group
6243 diff = vbld(i)-vbldp0
6245 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6246 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6249 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6251 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6255 estr=0.5d0*AKP*estr+estr1
6257 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6259 do i=ibond_start,ibond_end
6261 if (iti.ne.10 .and. iti.ne.ntyp1) then
6264 diff=vbld(i+nres)-vbldsc0(1,iti)
6265 if (energy_dec) write (iout,*)
6266 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6267 & AKSC(1,iti),AKSC(1,iti)*diff*diff
6268 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6270 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6274 diff=vbld(i+nres)-vbldsc0(j,iti)
6275 ud(j)=aksc(j,iti)*diff
6276 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6290 uprod2=uprod2*u(k)*u(k)
6294 usumsqder=usumsqder+ud(j)*uprod2
6296 estr=estr+uprod/usum
6298 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6306 C--------------------------------------------------------------------------
6307 subroutine ebend(etheta,ethetacnstr)
6309 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6310 C angles gamma and its derivatives in consecutive thetas and gammas.
6312 implicit real*8 (a-h,o-z)
6313 include 'DIMENSIONS'
6314 include 'COMMON.LOCAL'
6315 include 'COMMON.GEO'
6316 include 'COMMON.INTERACT'
6317 include 'COMMON.DERIV'
6318 include 'COMMON.VAR'
6319 include 'COMMON.CHAIN'
6320 include 'COMMON.IOUNITS'
6321 include 'COMMON.NAMES'
6322 include 'COMMON.FFIELD'
6323 include 'COMMON.CONTROL'
6324 include 'COMMON.TORCNSTR'
6325 common /calcthet/ term1,term2,termm,diffak,ratak,
6326 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6327 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6328 double precision y(2),z(2)
6330 c time11=dexp(-2*time)
6333 c write (*,'(a,i2)') 'EBEND ICG=',icg
6334 do i=ithet_start,ithet_end
6335 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6336 & .or.itype(i).eq.ntyp1) cycle
6337 C Zero the energy function and its derivative at 0 or pi.
6338 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6340 ichir1=isign(1,itype(i-2))
6341 ichir2=isign(1,itype(i))
6342 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6343 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6344 if (itype(i-1).eq.10) then
6345 itype1=isign(10,itype(i-2))
6346 ichir11=isign(1,itype(i-2))
6347 ichir12=isign(1,itype(i-2))
6348 itype2=isign(10,itype(i))
6349 ichir21=isign(1,itype(i))
6350 ichir22=isign(1,itype(i))
6353 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6356 if (phii.ne.phii) phii=150.0
6366 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6369 if (phii1.ne.phii1) phii1=150.0
6381 C Calculate the "mean" value of theta from the part of the distribution
6382 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6383 C In following comments this theta will be referred to as t_c.
6384 thet_pred_mean=0.0d0
6386 athetk=athet(k,it,ichir1,ichir2)
6387 bthetk=bthet(k,it,ichir1,ichir2)
6389 athetk=athet(k,itype1,ichir11,ichir12)
6390 bthetk=bthet(k,itype2,ichir21,ichir22)
6392 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6393 c write(iout,*) 'chuj tu', y(k),z(k)
6395 dthett=thet_pred_mean*ssd
6396 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6397 C Derivatives of the "mean" values in gamma1 and gamma2.
6398 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6399 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6400 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6401 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6403 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6404 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6405 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6406 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6408 if (theta(i).gt.pi-delta) then
6409 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6411 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6412 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6413 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6415 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6417 else if (theta(i).lt.delta) then
6418 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6419 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6420 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6422 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6423 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6426 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6429 etheta=etheta+ethetai
6430 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6431 & 'ebend',i,ethetai,theta(i),itype(i)
6432 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6433 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6434 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6437 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
6438 do i=ithetaconstr_start,ithetaconstr_end
6439 itheta=itheta_constr(i)
6440 thetiii=theta(itheta)
6441 difi=pinorm(thetiii-theta_constr0(i))
6442 if (difi.gt.theta_drange(i)) then
6443 difi=difi-theta_drange(i)
6444 ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6445 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6446 & +for_thet_constr(i)*difi**3
6447 else if (difi.lt.-drange(i)) then
6449 ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6450 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6451 & +for_thet_constr(i)*difi**3
6455 if (energy_dec) then
6456 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6457 & i,itheta,rad2deg*thetiii,
6458 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
6459 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6460 & gloc(itheta+nphi-2,icg)
6464 C Ufff.... We've done all this!!!
6467 C---------------------------------------------------------------------------
6468 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6470 implicit real*8 (a-h,o-z)
6471 include 'DIMENSIONS'
6472 include 'COMMON.LOCAL'
6473 include 'COMMON.IOUNITS'
6474 common /calcthet/ term1,term2,termm,diffak,ratak,
6475 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6476 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6477 C Calculate the contributions to both Gaussian lobes.
6478 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6479 C The "polynomial part" of the "standard deviation" of this part of
6480 C the distributioni.
6481 ccc write (iout,*) thetai,thet_pred_mean
6484 sig=sig*thet_pred_mean+polthet(j,it)
6486 C Derivative of the "interior part" of the "standard deviation of the"
6487 C gamma-dependent Gaussian lobe in t_c.
6488 sigtc=3*polthet(3,it)
6490 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6493 C Set the parameters of both Gaussian lobes of the distribution.
6494 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6495 fac=sig*sig+sigc0(it)
6498 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6499 sigsqtc=-4.0D0*sigcsq*sigtc
6500 c print *,i,sig,sigtc,sigsqtc
6501 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6502 sigtc=-sigtc/(fac*fac)
6503 C Following variable is sigma(t_c)**(-2)
6504 sigcsq=sigcsq*sigcsq
6506 sig0inv=1.0D0/sig0i**2
6507 delthec=thetai-thet_pred_mean
6508 delthe0=thetai-theta0i
6509 term1=-0.5D0*sigcsq*delthec*delthec
6510 term2=-0.5D0*sig0inv*delthe0*delthe0
6511 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6512 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6513 C NaNs in taking the logarithm. We extract the largest exponent which is added
6514 C to the energy (this being the log of the distribution) at the end of energy
6515 C term evaluation for this virtual-bond angle.
6516 if (term1.gt.term2) then
6518 term2=dexp(term2-termm)
6522 term1=dexp(term1-termm)
6525 C The ratio between the gamma-independent and gamma-dependent lobes of
6526 C the distribution is a Gaussian function of thet_pred_mean too.
6527 diffak=gthet(2,it)-thet_pred_mean
6528 ratak=diffak/gthet(3,it)**2
6529 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6530 C Let's differentiate it in thet_pred_mean NOW.
6532 C Now put together the distribution terms to make complete distribution.
6533 termexp=term1+ak*term2
6534 termpre=sigc+ak*sig0i
6535 C Contribution of the bending energy from this theta is just the -log of
6536 C the sum of the contributions from the two lobes and the pre-exponential
6537 C factor. Simple enough, isn't it?
6538 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6539 C write (iout,*) 'termexp',termexp,termm,termpre,i
6540 C NOW the derivatives!!!
6541 C 6/6/97 Take into account the deformation.
6542 E_theta=(delthec*sigcsq*term1
6543 & +ak*delthe0*sig0inv*term2)/termexp
6544 E_tc=((sigtc+aktc*sig0i)/termpre
6545 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6546 & aktc*term2)/termexp)
6549 c-----------------------------------------------------------------------------
6550 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6551 implicit real*8 (a-h,o-z)
6552 include 'DIMENSIONS'
6553 include 'COMMON.LOCAL'
6554 include 'COMMON.IOUNITS'
6555 common /calcthet/ term1,term2,termm,diffak,ratak,
6556 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6557 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6558 delthec=thetai-thet_pred_mean
6559 delthe0=thetai-theta0i
6560 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6561 t3 = thetai-thet_pred_mean
6565 t14 = t12+t6*sigsqtc
6567 t21 = thetai-theta0i
6573 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6574 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6575 & *(-t12*t9-ak*sig0inv*t27)
6579 C--------------------------------------------------------------------------
6580 subroutine ebend(etheta,ethetacnstr)
6582 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6583 C angles gamma and its derivatives in consecutive thetas and gammas.
6584 C ab initio-derived potentials from
6585 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6587 implicit real*8 (a-h,o-z)
6588 include 'DIMENSIONS'
6589 include 'COMMON.LOCAL'
6590 include 'COMMON.GEO'
6591 include 'COMMON.INTERACT'
6592 include 'COMMON.DERIV'
6593 include 'COMMON.VAR'
6594 include 'COMMON.CHAIN'
6595 include 'COMMON.IOUNITS'
6596 include 'COMMON.NAMES'
6597 include 'COMMON.FFIELD'
6598 include 'COMMON.CONTROL'
6599 include 'COMMON.TORCNSTR'
6600 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6601 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6602 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6603 & sinph1ph2(maxdouble,maxdouble)
6604 logical lprn /.false./, lprn1 /.false./
6606 do i=ithet_start,ithet_end
6607 c print *,i,itype(i-1),itype(i),itype(i-2)
6608 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6609 & .or.itype(i).eq.ntyp1) cycle
6610 C print *,i,theta(i)
6611 if (iabs(itype(i+1)).eq.20) iblock=2
6612 if (iabs(itype(i+1)).ne.20) iblock=1
6616 theti2=0.5d0*theta(i)
6617 ityp2=ithetyp((itype(i-1)))
6619 coskt(k)=dcos(k*theti2)
6620 sinkt(k)=dsin(k*theti2)
6623 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6626 if (phii.ne.phii) phii=150.0
6630 ityp1=ithetyp((itype(i-2)))
6631 C propagation of chirality for glycine type
6633 cosph1(k)=dcos(k*phii)
6634 sinph1(k)=dsin(k*phii)
6639 ityp1=ithetyp((itype(i-2)))
6644 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6647 if (phii1.ne.phii1) phii1=150.0
6652 ityp3=ithetyp((itype(i)))
6654 cosph2(k)=dcos(k*phii1)
6655 sinph2(k)=dsin(k*phii1)
6659 ityp3=ithetyp((itype(i)))
6665 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6668 ccl=cosph1(l)*cosph2(k-l)
6669 ssl=sinph1(l)*sinph2(k-l)
6670 scl=sinph1(l)*cosph2(k-l)
6671 csl=cosph1(l)*sinph2(k-l)
6672 cosph1ph2(l,k)=ccl-ssl
6673 cosph1ph2(k,l)=ccl+ssl
6674 sinph1ph2(l,k)=scl+csl
6675 sinph1ph2(k,l)=scl-csl
6679 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6680 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6681 write (iout,*) "coskt and sinkt"
6683 write (iout,*) k,coskt(k),sinkt(k)
6687 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6688 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6691 & write (iout,*) "k",k,"
6692 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6693 & " ethetai",ethetai
6696 write (iout,*) "cosph and sinph"
6698 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6700 write (iout,*) "cosph1ph2 and sinph2ph2"
6703 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6704 & sinph1ph2(l,k),sinph1ph2(k,l)
6707 write(iout,*) "ethetai",ethetai
6712 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6713 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6714 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6715 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6716 ethetai=ethetai+sinkt(m)*aux
6717 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6718 dephii=dephii+k*sinkt(m)*(
6719 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6720 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6721 dephii1=dephii1+k*sinkt(m)*(
6722 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6723 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6725 & write (iout,*) "m",m," k",k," bbthet",
6726 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6727 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6728 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6729 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6730 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6733 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6734 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6735 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6736 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6738 & write(iout,*) "ethetai",ethetai
6739 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6743 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6744 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6745 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6746 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6747 ethetai=ethetai+sinkt(m)*aux
6748 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6749 dephii=dephii+l*sinkt(m)*(
6750 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6751 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6752 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6753 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6754 dephii1=dephii1+(k-l)*sinkt(m)*(
6755 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6756 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6757 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6758 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6760 write (iout,*) "m",m," k",k," l",l," ffthet",
6761 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6762 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6763 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6764 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6765 & " ethetai",ethetai
6766 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6767 & cosph1ph2(k,l)*sinkt(m),
6768 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6777 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6778 & i,theta(i)*rad2deg,phii*rad2deg,
6779 & phii1*rad2deg,ethetai
6781 etheta=etheta+ethetai
6782 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6783 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6784 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6788 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
6789 do i=ithetaconstr_start,ithetaconstr_end
6790 itheta=itheta_constr(i)
6791 thetiii=theta(itheta)
6792 difi=pinorm(thetiii-theta_constr0(i))
6793 if (difi.gt.theta_drange(i)) then
6794 difi=difi-theta_drange(i)
6795 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6796 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6797 & +for_thet_constr(i)*difi**3
6798 else if (difi.lt.-drange(i)) then
6800 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6801 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6802 & +for_thet_constr(i)*difi**3
6806 if (energy_dec) then
6807 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6808 & i,itheta,rad2deg*thetiii,
6809 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
6810 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6811 & gloc(itheta+nphi-2,icg)
6819 c-----------------------------------------------------------------------------
6820 subroutine esc(escloc)
6821 C Calculate the local energy of a side chain and its derivatives in the
6822 C corresponding virtual-bond valence angles THETA and the spherical angles
6824 implicit real*8 (a-h,o-z)
6825 include 'DIMENSIONS'
6826 include 'COMMON.GEO'
6827 include 'COMMON.LOCAL'
6828 include 'COMMON.VAR'
6829 include 'COMMON.INTERACT'
6830 include 'COMMON.DERIV'
6831 include 'COMMON.CHAIN'
6832 include 'COMMON.IOUNITS'
6833 include 'COMMON.NAMES'
6834 include 'COMMON.FFIELD'
6835 include 'COMMON.CONTROL'
6836 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6837 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6838 common /sccalc/ time11,time12,time112,theti,it,nlobit
6841 c write (iout,'(a)') 'ESC'
6842 do i=loc_start,loc_end
6844 if (it.eq.ntyp1) cycle
6845 if (it.eq.10) goto 1
6846 nlobit=nlob(iabs(it))
6847 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6848 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6849 theti=theta(i+1)-pipol
6854 if (x(2).gt.pi-delta) then
6858 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6860 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6861 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6863 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6864 & ddersc0(1),dersc(1))
6865 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6866 & ddersc0(3),dersc(3))
6868 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6870 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6871 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6872 & dersc0(2),esclocbi,dersc02)
6873 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6875 call splinthet(x(2),0.5d0*delta,ss,ssd)
6880 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6882 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6883 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6885 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6887 c write (iout,*) escloci
6888 else if (x(2).lt.delta) then
6892 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6894 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6895 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6897 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6898 & ddersc0(1),dersc(1))
6899 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6900 & ddersc0(3),dersc(3))
6902 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6904 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6905 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6906 & dersc0(2),esclocbi,dersc02)
6907 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6912 call splinthet(x(2),0.5d0*delta,ss,ssd)
6914 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6916 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6917 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6919 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6920 c write (iout,*) escloci
6922 call enesc(x,escloci,dersc,ddummy,.false.)
6925 escloc=escloc+escloci
6926 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6927 & 'escloc',i,escloci
6928 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6930 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6932 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6933 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6938 C---------------------------------------------------------------------------
6939 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6940 implicit real*8 (a-h,o-z)
6941 include 'DIMENSIONS'
6942 include 'COMMON.GEO'
6943 include 'COMMON.LOCAL'
6944 include 'COMMON.IOUNITS'
6945 common /sccalc/ time11,time12,time112,theti,it,nlobit
6946 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6947 double precision contr(maxlob,-1:1)
6949 c write (iout,*) 'it=',it,' nlobit=',nlobit
6953 if (mixed) ddersc(j)=0.0d0
6957 C Because of periodicity of the dependence of the SC energy in omega we have
6958 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6959 C To avoid underflows, first compute & store the exponents.
6967 z(k)=x(k)-censc(k,j,it)
6972 Axk=Axk+gaussc(l,k,j,it)*z(l)
6978 expfac=expfac+Ax(k,j,iii)*z(k)
6986 C As in the case of ebend, we want to avoid underflows in exponentiation and
6987 C subsequent NaNs and INFs in energy calculation.
6988 C Find the largest exponent
6992 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6996 cd print *,'it=',it,' emin=',emin
6998 C Compute the contribution to SC energy and derivatives
7003 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7004 if(adexp.ne.adexp) adexp=1.0
7007 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7009 cd print *,'j=',j,' expfac=',expfac
7010 escloc_i=escloc_i+expfac
7012 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7016 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7017 & +gaussc(k,2,j,it))*expfac
7024 dersc(1)=dersc(1)/cos(theti)**2
7025 ddersc(1)=ddersc(1)/cos(theti)**2
7028 escloci=-(dlog(escloc_i)-emin)
7030 dersc(j)=dersc(j)/escloc_i
7034 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7039 C------------------------------------------------------------------------------
7040 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7041 implicit real*8 (a-h,o-z)
7042 include 'DIMENSIONS'
7043 include 'COMMON.GEO'
7044 include 'COMMON.LOCAL'
7045 include 'COMMON.IOUNITS'
7046 common /sccalc/ time11,time12,time112,theti,it,nlobit
7047 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7048 double precision contr(maxlob)
7059 z(k)=x(k)-censc(k,j,it)
7065 Axk=Axk+gaussc(l,k,j,it)*z(l)
7071 expfac=expfac+Ax(k,j)*z(k)
7076 C As in the case of ebend, we want to avoid underflows in exponentiation and
7077 C subsequent NaNs and INFs in energy calculation.
7078 C Find the largest exponent
7081 if (emin.gt.contr(j)) emin=contr(j)
7085 C Compute the contribution to SC energy and derivatives
7089 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7090 escloc_i=escloc_i+expfac
7092 dersc(k)=dersc(k)+Ax(k,j)*expfac
7094 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7095 & +gaussc(1,2,j,it))*expfac
7099 dersc(1)=dersc(1)/cos(theti)**2
7100 dersc12=dersc12/cos(theti)**2
7101 escloci=-(dlog(escloc_i)-emin)
7103 dersc(j)=dersc(j)/escloc_i
7105 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7109 c----------------------------------------------------------------------------------
7110 subroutine esc(escloc)
7111 C Calculate the local energy of a side chain and its derivatives in the
7112 C corresponding virtual-bond valence angles THETA and the spherical angles
7113 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7114 C added by Urszula Kozlowska. 07/11/2007
7116 implicit real*8 (a-h,o-z)
7117 include 'DIMENSIONS'
7118 include 'COMMON.GEO'
7119 include 'COMMON.LOCAL'
7120 include 'COMMON.VAR'
7121 include 'COMMON.SCROT'
7122 include 'COMMON.INTERACT'
7123 include 'COMMON.DERIV'
7124 include 'COMMON.CHAIN'
7125 include 'COMMON.IOUNITS'
7126 include 'COMMON.NAMES'
7127 include 'COMMON.FFIELD'
7128 include 'COMMON.CONTROL'
7129 include 'COMMON.VECTORS'
7130 double precision x_prime(3),y_prime(3),z_prime(3)
7131 & , sumene,dsc_i,dp2_i,x(65),
7132 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7133 & de_dxx,de_dyy,de_dzz,de_dt
7134 double precision s1_t,s1_6_t,s2_t,s2_6_t
7136 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7137 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7138 & dt_dCi(3),dt_dCi1(3)
7139 common /sccalc/ time11,time12,time112,theti,it,nlobit
7142 do i=loc_start,loc_end
7143 if (itype(i).eq.ntyp1) cycle
7144 costtab(i+1) =dcos(theta(i+1))
7145 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7146 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7147 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7148 cosfac2=0.5d0/(1.0d0+costtab(i+1))
7149 cosfac=dsqrt(cosfac2)
7150 sinfac2=0.5d0/(1.0d0-costtab(i+1))
7151 sinfac=dsqrt(sinfac2)
7153 if (it.eq.10) goto 1
7155 C Compute the axes of tghe local cartesian coordinates system; store in
7156 c x_prime, y_prime and z_prime
7163 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7164 C & dc_norm(3,i+nres)
7166 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7167 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7170 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7173 c write (2,*) "x_prime",(x_prime(j),j=1,3)
7174 c write (2,*) "y_prime",(y_prime(j),j=1,3)
7175 c write (2,*) "z_prime",(z_prime(j),j=1,3)
7176 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7177 c & " xy",scalar(x_prime(1),y_prime(1)),
7178 c & " xz",scalar(x_prime(1),z_prime(1)),
7179 c & " yy",scalar(y_prime(1),y_prime(1)),
7180 c & " yz",scalar(y_prime(1),z_prime(1)),
7181 c & " zz",scalar(z_prime(1),z_prime(1))
7183 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7184 C to local coordinate system. Store in xx, yy, zz.
7190 xx = xx + x_prime(j)*dc_norm(j,i+nres)
7191 yy = yy + y_prime(j)*dc_norm(j,i+nres)
7192 zz = zz + z_prime(j)*dc_norm(j,i+nres)
7199 C Compute the energy of the ith side cbain
7201 c write (2,*) "xx",xx," yy",yy," zz",zz
7204 x(j) = sc_parmin(j,it)
7207 Cc diagnostics - remove later
7209 yy1 = dsin(alph(2))*dcos(omeg(2))
7210 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7211 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7212 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7214 C," --- ", xx_w,yy_w,zz_w
7217 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7218 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7220 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7221 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7223 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7224 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7225 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7226 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7227 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7229 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7230 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7231 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7232 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7233 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7235 dsc_i = 0.743d0+x(61)
7237 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7238 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7239 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7240 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7241 s1=(1+x(63))/(0.1d0 + dscp1)
7242 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7243 s2=(1+x(65))/(0.1d0 + dscp2)
7244 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7245 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7246 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7247 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7249 c & dscp1,dscp2,sumene
7250 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7251 escloc = escloc + sumene
7252 c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7257 C This section to check the numerical derivatives of the energy of ith side
7258 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7259 C #define DEBUG in the code to turn it on.
7261 write (2,*) "sumene =",sumene
7265 write (2,*) xx,yy,zz
7266 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7267 de_dxx_num=(sumenep-sumene)/aincr
7269 write (2,*) "xx+ sumene from enesc=",sumenep
7272 write (2,*) xx,yy,zz
7273 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7274 de_dyy_num=(sumenep-sumene)/aincr
7276 write (2,*) "yy+ sumene from enesc=",sumenep
7279 write (2,*) xx,yy,zz
7280 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7281 de_dzz_num=(sumenep-sumene)/aincr
7283 write (2,*) "zz+ sumene from enesc=",sumenep
7284 costsave=cost2tab(i+1)
7285 sintsave=sint2tab(i+1)
7286 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7287 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7288 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7289 de_dt_num=(sumenep-sumene)/aincr
7290 write (2,*) " t+ sumene from enesc=",sumenep
7291 cost2tab(i+1)=costsave
7292 sint2tab(i+1)=sintsave
7293 C End of diagnostics section.
7296 C Compute the gradient of esc
7298 c zz=zz*dsign(1.0,dfloat(itype(i)))
7299 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7300 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7301 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7302 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7303 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7304 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7305 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7306 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7307 pom1=(sumene3*sint2tab(i+1)+sumene1)
7308 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7309 pom2=(sumene4*cost2tab(i+1)+sumene2)
7310 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7311 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7312 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7313 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7315 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7316 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7317 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7319 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7320 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7321 & +(pom1+pom2)*pom_dx
7323 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7326 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7327 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7328 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7330 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7331 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7332 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7333 & +x(59)*zz**2 +x(60)*xx*zz
7334 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7335 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7336 & +(pom1-pom2)*pom_dy
7338 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7341 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7342 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7343 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7344 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7345 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7346 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7347 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7348 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7350 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7353 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7354 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7355 & +pom1*pom_dt1+pom2*pom_dt2
7357 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7362 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7363 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7364 cosfac2xx=cosfac2*xx
7365 sinfac2yy=sinfac2*yy
7367 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7369 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7371 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7372 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7373 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7374 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7375 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7376 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7377 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7378 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7379 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7380 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7384 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7385 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7386 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7387 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7390 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7391 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7392 dZZ_XYZ(k)=vbld_inv(i+nres)*
7393 & (z_prime(k)-zz*dC_norm(k,i+nres))
7395 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7396 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7400 dXX_Ctab(k,i)=dXX_Ci(k)
7401 dXX_C1tab(k,i)=dXX_Ci1(k)
7402 dYY_Ctab(k,i)=dYY_Ci(k)
7403 dYY_C1tab(k,i)=dYY_Ci1(k)
7404 dZZ_Ctab(k,i)=dZZ_Ci(k)
7405 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7406 dXX_XYZtab(k,i)=dXX_XYZ(k)
7407 dYY_XYZtab(k,i)=dYY_XYZ(k)
7408 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7412 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7413 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7414 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7415 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7416 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7418 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7419 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7420 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7421 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7422 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7423 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7424 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7425 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7427 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7428 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7430 C to check gradient call subroutine check_grad
7436 c------------------------------------------------------------------------------
7437 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7439 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7440 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7441 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7442 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7444 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7445 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7447 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7448 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7449 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7450 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7451 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7453 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7454 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7455 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7456 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7457 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7459 dsc_i = 0.743d0+x(61)
7461 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7462 & *(xx*cost2+yy*sint2))
7463 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7464 & *(xx*cost2-yy*sint2))
7465 s1=(1+x(63))/(0.1d0 + dscp1)
7466 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7467 s2=(1+x(65))/(0.1d0 + dscp2)
7468 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7469 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7470 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7475 c------------------------------------------------------------------------------
7476 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7478 C This procedure calculates two-body contact function g(rij) and its derivative:
7481 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7484 C where x=(rij-r0ij)/delta
7486 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7489 double precision rij,r0ij,eps0ij,fcont,fprimcont
7490 double precision x,x2,x4,delta
7494 if (x.lt.-1.0D0) then
7497 else if (x.le.1.0D0) then
7500 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7501 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7508 c------------------------------------------------------------------------------
7509 subroutine splinthet(theti,delta,ss,ssder)
7510 implicit real*8 (a-h,o-z)
7511 include 'DIMENSIONS'
7512 include 'COMMON.VAR'
7513 include 'COMMON.GEO'
7516 if (theti.gt.pipol) then
7517 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7519 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7524 c------------------------------------------------------------------------------
7525 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7527 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7528 double precision ksi,ksi2,ksi3,a1,a2,a3
7529 a1=fprim0*delta/(f1-f0)
7535 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7536 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7539 c------------------------------------------------------------------------------
7540 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7542 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7543 double precision ksi,ksi2,ksi3,a1,a2,a3
7548 a2=3*(f1x-f0x)-2*fprim0x*delta
7549 a3=fprim0x*delta-2*(f1x-f0x)
7550 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7553 C-----------------------------------------------------------------------------
7555 C-----------------------------------------------------------------------------
7556 subroutine etor(etors,edihcnstr)
7557 implicit real*8 (a-h,o-z)
7558 include 'DIMENSIONS'
7559 include 'COMMON.VAR'
7560 include 'COMMON.GEO'
7561 include 'COMMON.LOCAL'
7562 include 'COMMON.TORSION'
7563 include 'COMMON.INTERACT'
7564 include 'COMMON.DERIV'
7565 include 'COMMON.CHAIN'
7566 include 'COMMON.NAMES'
7567 include 'COMMON.IOUNITS'
7568 include 'COMMON.FFIELD'
7569 include 'COMMON.TORCNSTR'
7570 include 'COMMON.CONTROL'
7572 C Set lprn=.true. for debugging
7576 do i=iphi_start,iphi_end
7578 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7579 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7580 itori=itortyp(itype(i-2))
7581 itori1=itortyp(itype(i-1))
7584 C Proline-Proline pair is a special case...
7585 if (itori.eq.3 .and. itori1.eq.3) then
7586 if (phii.gt.-dwapi3) then
7588 fac=1.0D0/(1.0D0-cosphi)
7589 etorsi=v1(1,3,3)*fac
7590 etorsi=etorsi+etorsi
7591 etors=etors+etorsi-v1(1,3,3)
7592 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7593 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7596 v1ij=v1(j+1,itori,itori1)
7597 v2ij=v2(j+1,itori,itori1)
7600 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7601 if (energy_dec) etors_ii=etors_ii+
7602 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7603 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7607 v1ij=v1(j,itori,itori1)
7608 v2ij=v2(j,itori,itori1)
7611 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7612 if (energy_dec) etors_ii=etors_ii+
7613 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7614 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7617 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7620 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7621 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7622 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7623 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7624 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7626 ! 6/20/98 - dihedral angle constraints
7629 itori=idih_constr(i)
7632 if (difi.gt.drange(i)) then
7634 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7635 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7636 else if (difi.lt.-drange(i)) then
7638 edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7639 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7641 ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7642 ! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7644 ! write (iout,*) 'edihcnstr',edihcnstr
7647 c------------------------------------------------------------------------------
7648 subroutine etor_d(etors_d)
7652 c----------------------------------------------------------------------------
7654 subroutine etor(etors,edihcnstr)
7655 implicit real*8 (a-h,o-z)
7656 include 'DIMENSIONS'
7657 include 'COMMON.VAR'
7658 include 'COMMON.GEO'
7659 include 'COMMON.LOCAL'
7660 include 'COMMON.TORSION'
7661 include 'COMMON.INTERACT'
7662 include 'COMMON.DERIV'
7663 include 'COMMON.CHAIN'
7664 include 'COMMON.NAMES'
7665 include 'COMMON.IOUNITS'
7666 include 'COMMON.FFIELD'
7667 include 'COMMON.TORCNSTR'
7668 include 'COMMON.CONTROL'
7670 C Set lprn=.true. for debugging
7674 do i=iphi_start,iphi_end
7675 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7676 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7677 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7678 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7679 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7680 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7681 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7682 C For introducing the NH3+ and COO- group please check the etor_d for reference
7685 if (iabs(itype(i)).eq.20) then
7690 itori=itortyp(itype(i-2))
7691 itori1=itortyp(itype(i-1))
7694 C Regular cosine and sine terms
7695 do j=1,nterm(itori,itori1,iblock)
7696 v1ij=v1(j,itori,itori1,iblock)
7697 v2ij=v2(j,itori,itori1,iblock)
7700 etors=etors+v1ij*cosphi+v2ij*sinphi
7701 if (energy_dec) etors_ii=etors_ii+
7702 & v1ij*cosphi+v2ij*sinphi
7703 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7707 C E = SUM ----------------------------------- - v1
7708 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7710 cosphi=dcos(0.5d0*phii)
7711 sinphi=dsin(0.5d0*phii)
7712 do j=1,nlor(itori,itori1,iblock)
7713 vl1ij=vlor1(j,itori,itori1)
7714 vl2ij=vlor2(j,itori,itori1)
7715 vl3ij=vlor3(j,itori,itori1)
7716 pom=vl2ij*cosphi+vl3ij*sinphi
7717 pom1=1.0d0/(pom*pom+1.0d0)
7718 etors=etors+vl1ij*pom1
7719 if (energy_dec) etors_ii=etors_ii+
7722 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7724 C Subtract the constant term
7725 etors=etors-v0(itori,itori1,iblock)
7726 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7727 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7729 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7730 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7731 & (v1(j,itori,itori1,iblock),j=1,6),
7732 & (v2(j,itori,itori1,iblock),j=1,6)
7733 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7734 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7736 ! 6/20/98 - dihedral angle constraints
7738 c do i=1,ndih_constr
7739 do i=idihconstr_start,idihconstr_end
7740 itori=idih_constr(i)
7742 difi=pinorm(phii-phi0(i))
7743 if (difi.gt.drange(i)) then
7745 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7746 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7747 else if (difi.lt.-drange(i)) then
7749 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7750 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7754 if (energy_dec) then
7755 write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7756 & i,itori,rad2deg*phii,
7757 & rad2deg*phi0(i), rad2deg*drange(i),
7758 & rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7761 cd write (iout,*) 'edihcnstr',edihcnstr
7764 c----------------------------------------------------------------------------
7765 subroutine etor_d(etors_d)
7766 C 6/23/01 Compute double torsional energy
7767 implicit real*8 (a-h,o-z)
7768 include 'DIMENSIONS'
7769 include 'COMMON.VAR'
7770 include 'COMMON.GEO'
7771 include 'COMMON.LOCAL'
7772 include 'COMMON.TORSION'
7773 include 'COMMON.INTERACT'
7774 include 'COMMON.DERIV'
7775 include 'COMMON.CHAIN'
7776 include 'COMMON.NAMES'
7777 include 'COMMON.IOUNITS'
7778 include 'COMMON.FFIELD'
7779 include 'COMMON.TORCNSTR'
7781 C Set lprn=.true. for debugging
7785 c write(iout,*) "a tu??"
7786 do i=iphid_start,iphid_end
7787 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7788 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7789 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7790 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7791 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7792 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7793 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7794 & (itype(i+1).eq.ntyp1)) cycle
7795 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7796 itori=itortyp(itype(i-2))
7797 itori1=itortyp(itype(i-1))
7798 itori2=itortyp(itype(i))
7804 if (iabs(itype(i+1)).eq.20) iblock=2
7805 C Iblock=2 Proline type
7806 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7807 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7808 C if (itype(i+1).eq.ntyp1) iblock=3
7809 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7810 C IS or IS NOT need for this
7811 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7812 C is (itype(i-3).eq.ntyp1) ntblock=2
7813 C ntblock is N-terminal blocking group
7815 C Regular cosine and sine terms
7816 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7817 C Example of changes for NH3+ blocking group
7818 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7819 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7820 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7821 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7822 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7823 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7824 cosphi1=dcos(j*phii)
7825 sinphi1=dsin(j*phii)
7826 cosphi2=dcos(j*phii1)
7827 sinphi2=dsin(j*phii1)
7828 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7829 & v2cij*cosphi2+v2sij*sinphi2
7830 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7831 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7833 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7835 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7836 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7837 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7838 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7839 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7840 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7841 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7842 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7843 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7844 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7845 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7846 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7847 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7848 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7851 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7852 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7857 C----------------------------------------------------------------------------------
7858 C The rigorous attempt to derive energy function
7859 subroutine etor_kcc(etors,edihcnstr)
7860 implicit real*8 (a-h,o-z)
7861 include 'DIMENSIONS'
7862 include 'COMMON.VAR'
7863 include 'COMMON.GEO'
7864 include 'COMMON.LOCAL'
7865 include 'COMMON.TORSION'
7866 include 'COMMON.INTERACT'
7867 include 'COMMON.DERIV'
7868 include 'COMMON.CHAIN'
7869 include 'COMMON.NAMES'
7870 include 'COMMON.IOUNITS'
7871 include 'COMMON.FFIELD'
7872 include 'COMMON.TORCNSTR'
7873 include 'COMMON.CONTROL'
7875 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7876 C Set lprn=.true. for debugging
7879 C print *,"wchodze kcc"
7880 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7881 if (tor_mode.ne.2) then
7884 do i=iphi_start,iphi_end
7885 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7886 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7887 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7888 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7889 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7890 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7891 itori=itortyp_kcc(itype(i-2))
7892 itori1=itortyp_kcc(itype(i-1))
7897 sumnonchebyshev=0.0d0
7899 C to avoid multiple devision by 2
7900 c theti22=0.5d0*theta(i)
7901 C theta 12 is the theta_1 /2
7902 C theta 22 is theta_2 /2
7903 c theti12=0.5d0*theta(i-1)
7904 C and appropriate sinus function
7905 sinthet1=dsin(theta(i-1))
7906 sinthet2=dsin(theta(i))
7907 costhet1=dcos(theta(i-1))
7908 costhet2=dcos(theta(i))
7909 c Cosines of halves thetas
7910 costheti12=0.5d0*(1.0d0+costhet1)
7911 costheti22=0.5d0*(1.0d0+costhet2)
7912 C to speed up lets store its mutliplication
7913 sint1t2=sinthet2*sinthet1
7915 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7916 C +d_n*sin(n*gamma)) *
7917 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7918 C we have two sum 1) Non-Chebyshev which is with n and gamma
7920 do j=1,nterm_kcc(itori,itori1)
7922 nval=nterm_kcc_Tb(itori,itori1)
7923 v1ij=v1_kcc(j,itori,itori1)
7924 v2ij=v2_kcc(j,itori,itori1)
7925 c write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7926 C v1ij is c_n and d_n in euation above
7930 sint1t2n=sint1t2n*sint1t2
7931 sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7933 gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7934 & v11_chyb(1,j,itori,itori1),costheti12)
7935 c write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7936 c & " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7937 sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7939 gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7940 & v21_chyb(1,j,itori,itori1),costheti22)
7941 c write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7942 c & " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7943 sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7945 gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7946 & v12_chyb(1,j,itori,itori1),costheti12)
7947 c write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7948 c & " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7949 sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7951 gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7952 & v22_chyb(1,j,itori,itori1),costheti22)
7953 c write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7954 c & " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7955 C etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7956 C if (energy_dec) etors_ii=etors_ii+
7957 C & v1ij*cosphi+v2ij*sinphi
7958 C glocig is the gradient local i site in gamma
7959 actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7960 actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7961 etori=etori+sint1t2n*(actval1+actval2)
7963 & j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7964 & -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7965 C now gradient over theta_1
7967 & j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7968 & sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7970 & j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7971 & sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7973 C now the Czebyshev polinominal sum
7974 c do k=1,nterm_kcc_Tb(itori,itori1)
7975 c thybt1(k)=v1_chyb(k,j,itori,itori1)
7976 c thybt2(k)=v2_chyb(k,j,itori,itori1)
7980 C print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7982 C & (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7983 C & dcos(theti22)**2),
7986 C now overal sumation
7987 C print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7990 C derivative over gamma
7991 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7992 C derivative over theta1
7993 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7994 C now derivative over theta2
7995 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7997 & write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7998 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
8000 C gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
8001 ! 6/20/98 - dihedral angle constraints
8002 if (tor_mode.ne.2) then
8004 c do i=1,ndih_constr
8005 do i=idihconstr_start,idihconstr_end
8006 itori=idih_constr(i)
8008 difi=pinorm(phii-phi0(i))
8009 if (difi.gt.drange(i)) then
8011 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8012 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8013 else if (difi.lt.-drange(i)) then
8015 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8016 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8025 C The rigorous attempt to derive energy function
8026 subroutine ebend_kcc(etheta,ethetacnstr)
8028 implicit real*8 (a-h,o-z)
8029 include 'DIMENSIONS'
8030 include 'COMMON.VAR'
8031 include 'COMMON.GEO'
8032 include 'COMMON.LOCAL'
8033 include 'COMMON.TORSION'
8034 include 'COMMON.INTERACT'
8035 include 'COMMON.DERIV'
8036 include 'COMMON.CHAIN'
8037 include 'COMMON.NAMES'
8038 include 'COMMON.IOUNITS'
8039 include 'COMMON.FFIELD'
8040 include 'COMMON.TORCNSTR'
8041 include 'COMMON.CONTROL'
8043 double precision thybt1(maxtermkcc)
8044 C Set lprn=.true. for debugging
8047 C print *,"wchodze kcc"
8048 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8049 if (tor_mode.ne.2) etheta=0.0D0
8050 do i=ithet_start,ithet_end
8051 c print *,i,itype(i-1),itype(i),itype(i-2)
8052 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8053 & .or.itype(i).eq.ntyp1) cycle
8054 iti=itortyp_kcc(itype(i-1))
8055 sinthet=dsin(theta(i)/2.0d0)
8056 costhet=dcos(theta(i)/2.0d0)
8057 do j=1,nbend_kcc_Tb(iti)
8058 thybt1(j)=v1bend_chyb(j,iti)
8060 sumth1thyb=tschebyshev
8061 & (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8062 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8064 ihelp=nbend_kcc_Tb(iti)-1
8065 gradthybt1=gradtschebyshev
8066 & (0,ihelp,thybt1(1),costhet)
8067 etheta=etheta+sumth1thyb
8068 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8069 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
8070 & gradthybt1*sinthet*(-0.5d0)
8072 if (tor_mode.ne.2) then
8074 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8075 do i=ithetaconstr_start,ithetaconstr_end
8076 itheta=itheta_constr(i)
8077 thetiii=theta(itheta)
8078 difi=pinorm(thetiii-theta_constr0(i))
8079 if (difi.gt.theta_drange(i)) then
8080 difi=difi-theta_drange(i)
8081 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8082 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8083 & +for_thet_constr(i)*difi**3
8084 else if (difi.lt.-drange(i)) then
8086 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8087 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8088 & +for_thet_constr(i)*difi**3
8092 if (energy_dec) then
8093 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8094 & i,itheta,rad2deg*thetiii,
8095 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8096 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8097 & gloc(itheta+nphi-2,icg)
8103 c------------------------------------------------------------------------------
8104 subroutine eback_sc_corr(esccor)
8105 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8106 c conformational states; temporarily implemented as differences
8107 c between UNRES torsional potentials (dependent on three types of
8108 c residues) and the torsional potentials dependent on all 20 types
8109 c of residues computed from AM1 energy surfaces of terminally-blocked
8110 c amino-acid residues.
8111 implicit real*8 (a-h,o-z)
8112 include 'DIMENSIONS'
8113 include 'COMMON.VAR'
8114 include 'COMMON.GEO'
8115 include 'COMMON.LOCAL'
8116 include 'COMMON.TORSION'
8117 include 'COMMON.SCCOR'
8118 include 'COMMON.INTERACT'
8119 include 'COMMON.DERIV'
8120 include 'COMMON.CHAIN'
8121 include 'COMMON.NAMES'
8122 include 'COMMON.IOUNITS'
8123 include 'COMMON.FFIELD'
8124 include 'COMMON.CONTROL'
8126 C Set lprn=.true. for debugging
8129 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8131 do i=itau_start,itau_end
8132 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8134 isccori=isccortyp(itype(i-2))
8135 isccori1=isccortyp(itype(i-1))
8136 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8138 do intertyp=1,3 !intertyp
8139 cc Added 09 May 2012 (Adasko)
8140 cc Intertyp means interaction type of backbone mainchain correlation:
8141 c 1 = SC...Ca...Ca...Ca
8142 c 2 = Ca...Ca...Ca...SC
8143 c 3 = SC...Ca...Ca...SCi
8145 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8146 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8147 & (itype(i-1).eq.ntyp1)))
8148 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8149 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8150 & .or.(itype(i).eq.ntyp1)))
8151 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8152 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8153 & (itype(i-3).eq.ntyp1)))) cycle
8154 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8155 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8157 do j=1,nterm_sccor(isccori,isccori1)
8158 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8159 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8160 cosphi=dcos(j*tauangle(intertyp,i))
8161 sinphi=dsin(j*tauangle(intertyp,i))
8162 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8163 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8165 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8166 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8168 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8169 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8170 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8171 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8172 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8178 c----------------------------------------------------------------------------
8179 subroutine multibody(ecorr)
8180 C This subroutine calculates multi-body contributions to energy following
8181 C the idea of Skolnick et al. If side chains I and J make a contact and
8182 C at the same time side chains I+1 and J+1 make a contact, an extra
8183 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8184 implicit real*8 (a-h,o-z)
8185 include 'DIMENSIONS'
8186 include 'COMMON.IOUNITS'
8187 include 'COMMON.DERIV'
8188 include 'COMMON.INTERACT'
8189 include 'COMMON.CONTACTS'
8190 double precision gx(3),gx1(3)
8193 C Set lprn=.true. for debugging
8197 write (iout,'(a)') 'Contact function values:'
8199 write (iout,'(i2,20(1x,i2,f10.5))')
8200 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8215 num_conti=num_cont(i)
8216 num_conti1=num_cont(i1)
8221 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8222 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8223 cd & ' ishift=',ishift
8224 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8225 C The system gains extra energy.
8226 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8227 endif ! j1==j+-ishift
8236 c------------------------------------------------------------------------------
8237 double precision function esccorr(i,j,k,l,jj,kk)
8238 implicit real*8 (a-h,o-z)
8239 include 'DIMENSIONS'
8240 include 'COMMON.IOUNITS'
8241 include 'COMMON.DERIV'
8242 include 'COMMON.INTERACT'
8243 include 'COMMON.CONTACTS'
8244 include 'COMMON.SHIELD'
8245 double precision gx(3),gx1(3)
8250 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8251 C Calculate the multi-body contribution to energy.
8252 C Calculate multi-body contributions to the gradient.
8253 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8254 cd & k,l,(gacont(m,kk,k),m=1,3)
8256 gx(m) =ekl*gacont(m,jj,i)
8257 gx1(m)=eij*gacont(m,kk,k)
8258 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8259 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8260 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8261 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8265 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8270 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8276 c------------------------------------------------------------------------------
8277 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8278 C This subroutine calculates multi-body contributions to hydrogen-bonding
8279 implicit real*8 (a-h,o-z)
8280 include 'DIMENSIONS'
8281 include 'COMMON.IOUNITS'
8284 parameter (max_cont=maxconts)
8285 parameter (max_dim=26)
8286 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8287 double precision zapas(max_dim,maxconts,max_fg_procs),
8288 & zapas_recv(max_dim,maxconts,max_fg_procs)
8289 common /przechowalnia/ zapas
8290 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8291 & status_array(MPI_STATUS_SIZE,maxconts*2)
8293 include 'COMMON.SETUP'
8294 include 'COMMON.FFIELD'
8295 include 'COMMON.DERIV'
8296 include 'COMMON.INTERACT'
8297 include 'COMMON.CONTACTS'
8298 include 'COMMON.CONTROL'
8299 include 'COMMON.LOCAL'
8300 double precision gx(3),gx1(3),time00
8303 C Set lprn=.true. for debugging
8308 if (nfgtasks.le.1) goto 30
8310 write (iout,'(a)') 'Contact function values before RECEIVE:'
8312 write (iout,'(2i3,50(1x,i2,f5.2))')
8313 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8314 & j=1,num_cont_hb(i))
8318 do i=1,ntask_cont_from
8321 do i=1,ntask_cont_to
8324 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8326 C Make the list of contacts to send to send to other procesors
8327 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8329 do i=iturn3_start,iturn3_end
8330 c write (iout,*) "make contact list turn3",i," num_cont",
8332 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8334 do i=iturn4_start,iturn4_end
8335 c write (iout,*) "make contact list turn4",i," num_cont",
8337 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8341 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8343 do j=1,num_cont_hb(i)
8346 iproc=iint_sent_local(k,jjc,ii)
8347 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8348 if (iproc.gt.0) then
8349 ncont_sent(iproc)=ncont_sent(iproc)+1
8350 nn=ncont_sent(iproc)
8352 zapas(2,nn,iproc)=jjc
8353 zapas(3,nn,iproc)=facont_hb(j,i)
8354 zapas(4,nn,iproc)=ees0p(j,i)
8355 zapas(5,nn,iproc)=ees0m(j,i)
8356 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8357 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8358 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8359 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8360 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8361 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8362 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8363 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8364 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8365 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8366 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8367 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8368 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8369 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8370 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8371 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8372 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8373 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8374 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8375 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8376 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8383 & "Numbers of contacts to be sent to other processors",
8384 & (ncont_sent(i),i=1,ntask_cont_to)
8385 write (iout,*) "Contacts sent"
8386 do ii=1,ntask_cont_to
8388 iproc=itask_cont_to(ii)
8389 write (iout,*) nn," contacts to processor",iproc,
8390 & " of CONT_TO_COMM group"
8392 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8400 CorrelID1=nfgtasks+fg_rank+1
8402 C Receive the numbers of needed contacts from other processors
8403 do ii=1,ntask_cont_from
8404 iproc=itask_cont_from(ii)
8406 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8407 & FG_COMM,req(ireq),IERR)
8409 c write (iout,*) "IRECV ended"
8411 C Send the number of contacts needed by other processors
8412 do ii=1,ntask_cont_to
8413 iproc=itask_cont_to(ii)
8415 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8416 & FG_COMM,req(ireq),IERR)
8418 c write (iout,*) "ISEND ended"
8419 c write (iout,*) "number of requests (nn)",ireq
8422 & call MPI_Waitall(ireq,req,status_array,ierr)
8424 c & "Numbers of contacts to be received from other processors",
8425 c & (ncont_recv(i),i=1,ntask_cont_from)
8429 do ii=1,ntask_cont_from
8430 iproc=itask_cont_from(ii)
8432 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8433 c & " of CONT_TO_COMM group"
8437 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8438 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8439 c write (iout,*) "ireq,req",ireq,req(ireq)
8442 C Send the contacts to processors that need them
8443 do ii=1,ntask_cont_to
8444 iproc=itask_cont_to(ii)
8446 c write (iout,*) nn," contacts to processor",iproc,
8447 c & " of CONT_TO_COMM group"
8450 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8451 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8452 c write (iout,*) "ireq,req",ireq,req(ireq)
8454 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8458 c write (iout,*) "number of requests (contacts)",ireq
8459 c write (iout,*) "req",(req(i),i=1,4)
8462 & call MPI_Waitall(ireq,req,status_array,ierr)
8463 do iii=1,ntask_cont_from
8464 iproc=itask_cont_from(iii)
8467 write (iout,*) "Received",nn," contacts from processor",iproc,
8468 & " of CONT_FROM_COMM group"
8471 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8476 ii=zapas_recv(1,i,iii)
8477 c Flag the received contacts to prevent double-counting
8478 jj=-zapas_recv(2,i,iii)
8479 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8481 nnn=num_cont_hb(ii)+1
8484 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8485 ees0p(nnn,ii)=zapas_recv(4,i,iii)
8486 ees0m(nnn,ii)=zapas_recv(5,i,iii)
8487 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8488 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8489 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8490 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8491 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8492 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8493 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8494 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8495 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8496 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8497 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8498 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8499 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8500 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8501 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8502 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8503 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8504 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8505 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8506 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8507 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8512 write (iout,'(a)') 'Contact function values after receive:'
8514 write (iout,'(2i3,50(1x,i3,f5.2))')
8515 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8516 & j=1,num_cont_hb(i))
8523 write (iout,'(a)') 'Contact function values:'
8525 write (iout,'(2i3,50(1x,i3,f5.2))')
8526 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8527 & j=1,num_cont_hb(i))
8531 C Remove the loop below after debugging !!!
8538 C Calculate the local-electrostatic correlation terms
8539 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8541 num_conti=num_cont_hb(i)
8542 num_conti1=num_cont_hb(i+1)
8549 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8550 c & ' jj=',jj,' kk=',kk
8551 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8552 & .or. j.lt.0 .and. j1.gt.0) .and.
8553 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8554 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8555 C The system gains extra energy.
8556 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8557 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8558 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8560 else if (j1.eq.j) then
8561 C Contacts I-J and I-(J+1) occur simultaneously.
8562 C The system loses extra energy.
8563 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8568 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8569 c & ' jj=',jj,' kk=',kk
8571 C Contacts I-J and (I+1)-J occur simultaneously.
8572 C The system loses extra energy.
8573 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8580 c------------------------------------------------------------------------------
8581 subroutine add_hb_contact(ii,jj,itask)
8582 implicit real*8 (a-h,o-z)
8583 include "DIMENSIONS"
8584 include "COMMON.IOUNITS"
8587 parameter (max_cont=maxconts)
8588 parameter (max_dim=26)
8589 include "COMMON.CONTACTS"
8590 double precision zapas(max_dim,maxconts,max_fg_procs),
8591 & zapas_recv(max_dim,maxconts,max_fg_procs)
8592 common /przechowalnia/ zapas
8593 integer i,j,ii,jj,iproc,itask(4),nn
8594 c write (iout,*) "itask",itask
8597 if (iproc.gt.0) then
8598 do j=1,num_cont_hb(ii)
8600 c write (iout,*) "i",ii," j",jj," jjc",jjc
8602 ncont_sent(iproc)=ncont_sent(iproc)+1
8603 nn=ncont_sent(iproc)
8604 zapas(1,nn,iproc)=ii
8605 zapas(2,nn,iproc)=jjc
8606 zapas(3,nn,iproc)=facont_hb(j,ii)
8607 zapas(4,nn,iproc)=ees0p(j,ii)
8608 zapas(5,nn,iproc)=ees0m(j,ii)
8609 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8610 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8611 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8612 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8613 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8614 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8615 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8616 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8617 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8618 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8619 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8620 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8621 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8622 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8623 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8624 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8625 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8626 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8627 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8628 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8629 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8637 c------------------------------------------------------------------------------
8638 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8640 C This subroutine calculates multi-body contributions to hydrogen-bonding
8641 implicit real*8 (a-h,o-z)
8642 include 'DIMENSIONS'
8643 include 'COMMON.IOUNITS'
8646 parameter (max_cont=maxconts)
8647 parameter (max_dim=70)
8648 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8649 double precision zapas(max_dim,maxconts,max_fg_procs),
8650 & zapas_recv(max_dim,maxconts,max_fg_procs)
8651 common /przechowalnia/ zapas
8652 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8653 & status_array(MPI_STATUS_SIZE,maxconts*2)
8655 include 'COMMON.SETUP'
8656 include 'COMMON.FFIELD'
8657 include 'COMMON.DERIV'
8658 include 'COMMON.LOCAL'
8659 include 'COMMON.INTERACT'
8660 include 'COMMON.CONTACTS'
8661 include 'COMMON.CHAIN'
8662 include 'COMMON.CONTROL'
8663 include 'COMMON.SHIELD'
8664 double precision gx(3),gx1(3)
8665 integer num_cont_hb_old(maxres)
8667 double precision eello4,eello5,eelo6,eello_turn6
8668 external eello4,eello5,eello6,eello_turn6
8669 C Set lprn=.true. for debugging
8674 num_cont_hb_old(i)=num_cont_hb(i)
8678 if (nfgtasks.le.1) goto 30
8680 write (iout,'(a)') 'Contact function values before RECEIVE:'
8682 write (iout,'(2i3,50(1x,i2,f5.2))')
8683 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8684 & j=1,num_cont_hb(i))
8688 do i=1,ntask_cont_from
8691 do i=1,ntask_cont_to
8694 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8696 C Make the list of contacts to send to send to other procesors
8697 do i=iturn3_start,iturn3_end
8698 c write (iout,*) "make contact list turn3",i," num_cont",
8700 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8702 do i=iturn4_start,iturn4_end
8703 c write (iout,*) "make contact list turn4",i," num_cont",
8705 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8709 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8711 do j=1,num_cont_hb(i)
8714 iproc=iint_sent_local(k,jjc,ii)
8715 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8716 if (iproc.ne.0) then
8717 ncont_sent(iproc)=ncont_sent(iproc)+1
8718 nn=ncont_sent(iproc)
8720 zapas(2,nn,iproc)=jjc
8721 zapas(3,nn,iproc)=d_cont(j,i)
8725 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8730 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8738 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8749 & "Numbers of contacts to be sent to other processors",
8750 & (ncont_sent(i),i=1,ntask_cont_to)
8751 write (iout,*) "Contacts sent"
8752 do ii=1,ntask_cont_to
8754 iproc=itask_cont_to(ii)
8755 write (iout,*) nn," contacts to processor",iproc,
8756 & " of CONT_TO_COMM group"
8758 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8766 CorrelID1=nfgtasks+fg_rank+1
8768 C Receive the numbers of needed contacts from other processors
8769 do ii=1,ntask_cont_from
8770 iproc=itask_cont_from(ii)
8772 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8773 & FG_COMM,req(ireq),IERR)
8775 c write (iout,*) "IRECV ended"
8777 C Send the number of contacts needed by other processors
8778 do ii=1,ntask_cont_to
8779 iproc=itask_cont_to(ii)
8781 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8782 & FG_COMM,req(ireq),IERR)
8784 c write (iout,*) "ISEND ended"
8785 c write (iout,*) "number of requests (nn)",ireq
8788 & call MPI_Waitall(ireq,req,status_array,ierr)
8790 c & "Numbers of contacts to be received from other processors",
8791 c & (ncont_recv(i),i=1,ntask_cont_from)
8795 do ii=1,ntask_cont_from
8796 iproc=itask_cont_from(ii)
8798 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8799 c & " of CONT_TO_COMM group"
8803 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8804 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8805 c write (iout,*) "ireq,req",ireq,req(ireq)
8808 C Send the contacts to processors that need them
8809 do ii=1,ntask_cont_to
8810 iproc=itask_cont_to(ii)
8812 c write (iout,*) nn," contacts to processor",iproc,
8813 c & " of CONT_TO_COMM group"
8816 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8817 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8818 c write (iout,*) "ireq,req",ireq,req(ireq)
8820 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8824 c write (iout,*) "number of requests (contacts)",ireq
8825 c write (iout,*) "req",(req(i),i=1,4)
8828 & call MPI_Waitall(ireq,req,status_array,ierr)
8829 do iii=1,ntask_cont_from
8830 iproc=itask_cont_from(iii)
8833 write (iout,*) "Received",nn," contacts from processor",iproc,
8834 & " of CONT_FROM_COMM group"
8837 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8842 ii=zapas_recv(1,i,iii)
8843 c Flag the received contacts to prevent double-counting
8844 jj=-zapas_recv(2,i,iii)
8845 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8847 nnn=num_cont_hb(ii)+1
8850 d_cont(nnn,ii)=zapas_recv(3,i,iii)
8854 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8859 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8867 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8876 write (iout,'(a)') 'Contact function values after receive:'
8878 write (iout,'(2i3,50(1x,i3,5f6.3))')
8879 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8880 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8887 write (iout,'(a)') 'Contact function values:'
8889 write (iout,'(2i3,50(1x,i2,5f6.3))')
8890 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8891 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8897 C Remove the loop below after debugging !!!
8904 C Calculate the dipole-dipole interaction energies
8905 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8906 do i=iatel_s,iatel_e+1
8907 num_conti=num_cont_hb(i)
8916 C Calculate the local-electrostatic correlation terms
8917 c write (iout,*) "gradcorr5 in eello5 before loop"
8919 c write (iout,'(i5,3f10.5)')
8920 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8922 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8923 c write (iout,*) "corr loop i",i
8925 num_conti=num_cont_hb(i)
8926 num_conti1=num_cont_hb(i+1)
8933 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8934 c & ' jj=',jj,' kk=',kk
8935 c if (j1.eq.j+1 .or. j1.eq.j-1) then
8936 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8937 & .or. j.lt.0 .and. j1.gt.0) .and.
8938 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8939 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8940 C The system gains extra energy.
8942 sqd1=dsqrt(d_cont(jj,i))
8943 sqd2=dsqrt(d_cont(kk,i1))
8944 sred_geom = sqd1*sqd2
8945 IF (sred_geom.lt.cutoff_corr) THEN
8946 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8948 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8949 cd & ' jj=',jj,' kk=',kk
8950 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8951 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8953 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8954 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8957 cd write (iout,*) 'sred_geom=',sred_geom,
8958 cd & ' ekont=',ekont,' fprim=',fprimcont,
8959 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8960 cd write (iout,*) "g_contij",g_contij
8961 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8962 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8963 call calc_eello(i,jp,i+1,jp1,jj,kk)
8964 if (wcorr4.gt.0.0d0)
8965 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8966 CC & *fac_shield(i)**2*fac_shield(j)**2
8967 if (energy_dec.and.wcorr4.gt.0.0d0)
8968 1 write (iout,'(a6,4i5,0pf7.3)')
8969 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8970 c write (iout,*) "gradcorr5 before eello5"
8972 c write (iout,'(i5,3f10.5)')
8973 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8975 if (wcorr5.gt.0.0d0)
8976 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8977 c write (iout,*) "gradcorr5 after eello5"
8979 c write (iout,'(i5,3f10.5)')
8980 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8982 if (energy_dec.and.wcorr5.gt.0.0d0)
8983 1 write (iout,'(a6,4i5,0pf7.3)')
8984 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8985 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8986 cd write(2,*)'ijkl',i,jp,i+1,jp1
8987 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8988 & .or. wturn6.eq.0.0d0))then
8989 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8990 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8991 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8992 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8993 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8994 cd & 'ecorr6=',ecorr6
8995 cd write (iout,'(4e15.5)') sred_geom,
8996 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8997 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8998 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
8999 else if (wturn6.gt.0.0d0
9000 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9001 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9002 eturn6=eturn6+eello_turn6(i,jj,kk)
9003 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9004 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9005 cd write (2,*) 'multibody_eello:eturn6',eturn6
9014 num_cont_hb(i)=num_cont_hb_old(i)
9016 c write (iout,*) "gradcorr5 in eello5"
9018 c write (iout,'(i5,3f10.5)')
9019 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9023 c------------------------------------------------------------------------------
9024 subroutine add_hb_contact_eello(ii,jj,itask)
9025 implicit real*8 (a-h,o-z)
9026 include "DIMENSIONS"
9027 include "COMMON.IOUNITS"
9030 parameter (max_cont=maxconts)
9031 parameter (max_dim=70)
9032 include "COMMON.CONTACTS"
9033 double precision zapas(max_dim,maxconts,max_fg_procs),
9034 & zapas_recv(max_dim,maxconts,max_fg_procs)
9035 common /przechowalnia/ zapas
9036 integer i,j,ii,jj,iproc,itask(4),nn
9037 c write (iout,*) "itask",itask
9040 if (iproc.gt.0) then
9041 do j=1,num_cont_hb(ii)
9043 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9045 ncont_sent(iproc)=ncont_sent(iproc)+1
9046 nn=ncont_sent(iproc)
9047 zapas(1,nn,iproc)=ii
9048 zapas(2,nn,iproc)=jjc
9049 zapas(3,nn,iproc)=d_cont(j,ii)
9053 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9058 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9066 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9078 c------------------------------------------------------------------------------
9079 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9080 implicit real*8 (a-h,o-z)
9081 include 'DIMENSIONS'
9082 include 'COMMON.IOUNITS'
9083 include 'COMMON.DERIV'
9084 include 'COMMON.INTERACT'
9085 include 'COMMON.CONTACTS'
9086 include 'COMMON.SHIELD'
9087 include 'COMMON.CONTROL'
9088 double precision gx(3),gx1(3)
9091 C print *,"wchodze",fac_shield(i),shield_mode
9099 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9101 C & fac_shield(i)**2*fac_shield(j)**2
9102 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9103 C Following 4 lines for diagnostics.
9108 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9109 c & 'Contacts ',i,j,
9110 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9111 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9113 C Calculate the multi-body contribution to energy.
9114 C ecorr=ecorr+ekont*ees
9115 C Calculate multi-body contributions to the gradient.
9116 coeffpees0pij=coeffp*ees0pij
9117 coeffmees0mij=coeffm*ees0mij
9118 coeffpees0pkl=coeffp*ees0pkl
9119 coeffmees0mkl=coeffm*ees0mkl
9121 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9122 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9123 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9124 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9125 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9126 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9127 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9128 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9129 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9130 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9131 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9132 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9133 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9134 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9135 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9136 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9137 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9138 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9139 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9140 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9141 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9142 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9143 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9144 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9145 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9150 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9151 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9152 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9153 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9158 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9159 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9160 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9161 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9164 c write (iout,*) "ehbcorr",ekont*ees
9165 C print *,ekont,ees,i,k
9167 C now gradient over shielding
9169 if (shield_mode.gt.0) then
9172 C print *,i,j,fac_shield(i),fac_shield(j),
9173 C &fac_shield(k),fac_shield(l)
9174 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9175 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9176 do ilist=1,ishield_list(i)
9177 iresshield=shield_list(ilist,i)
9179 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9181 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9183 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9184 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9188 do ilist=1,ishield_list(j)
9189 iresshield=shield_list(ilist,j)
9191 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9193 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9195 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9196 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9201 do ilist=1,ishield_list(k)
9202 iresshield=shield_list(ilist,k)
9204 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9206 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9208 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9209 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9213 do ilist=1,ishield_list(l)
9214 iresshield=shield_list(ilist,l)
9216 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9218 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9220 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9221 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9225 C print *,gshieldx(m,iresshield)
9227 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9228 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9229 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9230 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9231 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9232 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9233 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9234 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9236 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9237 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9238 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9239 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9240 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9241 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9242 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9243 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9251 C---------------------------------------------------------------------------
9252 subroutine dipole(i,j,jj)
9253 implicit real*8 (a-h,o-z)
9254 include 'DIMENSIONS'
9255 include 'COMMON.IOUNITS'
9256 include 'COMMON.CHAIN'
9257 include 'COMMON.FFIELD'
9258 include 'COMMON.DERIV'
9259 include 'COMMON.INTERACT'
9260 include 'COMMON.CONTACTS'
9261 include 'COMMON.TORSION'
9262 include 'COMMON.VAR'
9263 include 'COMMON.GEO'
9264 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9266 iti1 = itortyp(itype(i+1))
9267 if (j.lt.nres-1) then
9268 itj1 = itype2loc(itype(j+1))
9273 dipi(iii,1)=Ub2(iii,i)
9274 dipderi(iii)=Ub2der(iii,i)
9275 dipi(iii,2)=b1(iii,i+1)
9276 dipj(iii,1)=Ub2(iii,j)
9277 dipderj(iii)=Ub2der(iii,j)
9278 dipj(iii,2)=b1(iii,j+1)
9282 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9285 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9292 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9296 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9301 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9302 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9304 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9306 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9308 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9313 C---------------------------------------------------------------------------
9314 subroutine calc_eello(i,j,k,l,jj,kk)
9316 C This subroutine computes matrices and vectors needed to calculate
9317 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9319 implicit real*8 (a-h,o-z)
9320 include 'DIMENSIONS'
9321 include 'COMMON.IOUNITS'
9322 include 'COMMON.CHAIN'
9323 include 'COMMON.DERIV'
9324 include 'COMMON.INTERACT'
9325 include 'COMMON.CONTACTS'
9326 include 'COMMON.TORSION'
9327 include 'COMMON.VAR'
9328 include 'COMMON.GEO'
9329 include 'COMMON.FFIELD'
9330 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9331 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9334 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9335 cd & ' jj=',jj,' kk=',kk
9336 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9337 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9338 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9341 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9342 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9345 call transpose2(aa1(1,1),aa1t(1,1))
9346 call transpose2(aa2(1,1),aa2t(1,1))
9349 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9350 & aa1tder(1,1,lll,kkk))
9351 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9352 & aa2tder(1,1,lll,kkk))
9356 C parallel orientation of the two CA-CA-CA frames.
9358 iti=itype2loc(itype(i))
9362 itk1=itype2loc(itype(k+1))
9363 itj=itype2loc(itype(j))
9364 if (l.lt.nres-1) then
9365 itl1=itype2loc(itype(l+1))
9369 C A1 kernel(j+1) A2T
9371 cd write (iout,'(3f10.5,5x,3f10.5)')
9372 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9374 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9375 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9376 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9377 C Following matrices are needed only for 6-th order cumulants
9378 IF (wcorr6.gt.0.0d0) THEN
9379 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9380 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9381 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9382 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9383 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9384 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9385 & ADtEAderx(1,1,1,1,1,1))
9387 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9388 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9389 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9390 & ADtEA1derx(1,1,1,1,1,1))
9392 C End 6-th order cumulants
9395 cd write (2,*) 'In calc_eello6'
9397 cd write (2,*) 'iii=',iii
9399 cd write (2,*) 'kkk=',kkk
9401 cd write (2,'(3(2f10.5),5x)')
9402 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9407 call transpose2(EUgder(1,1,k),auxmat(1,1))
9408 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9409 call transpose2(EUg(1,1,k),auxmat(1,1))
9410 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9411 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9415 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9416 & EAEAderx(1,1,lll,kkk,iii,1))
9420 C A1T kernel(i+1) A2
9421 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9422 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9423 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9424 C Following matrices are needed only for 6-th order cumulants
9425 IF (wcorr6.gt.0.0d0) THEN
9426 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9427 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9428 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9429 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9430 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9431 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9432 & ADtEAderx(1,1,1,1,1,2))
9433 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9434 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9435 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9436 & ADtEA1derx(1,1,1,1,1,2))
9438 C End 6-th order cumulants
9439 call transpose2(EUgder(1,1,l),auxmat(1,1))
9440 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9441 call transpose2(EUg(1,1,l),auxmat(1,1))
9442 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9443 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9447 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9448 & EAEAderx(1,1,lll,kkk,iii,2))
9453 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9454 C They are needed only when the fifth- or the sixth-order cumulants are
9456 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9457 call transpose2(AEA(1,1,1),auxmat(1,1))
9458 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9459 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9460 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9461 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9462 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9463 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9464 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9465 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9466 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9467 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9468 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9469 call transpose2(AEA(1,1,2),auxmat(1,1))
9470 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9471 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9472 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9473 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9474 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9475 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9476 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9477 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9478 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9479 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9480 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9481 C Calculate the Cartesian derivatives of the vectors.
9485 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9486 call matvec2(auxmat(1,1),b1(1,i),
9487 & AEAb1derx(1,lll,kkk,iii,1,1))
9488 call matvec2(auxmat(1,1),Ub2(1,i),
9489 & AEAb2derx(1,lll,kkk,iii,1,1))
9490 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9491 & AEAb1derx(1,lll,kkk,iii,2,1))
9492 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9493 & AEAb2derx(1,lll,kkk,iii,2,1))
9494 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9495 call matvec2(auxmat(1,1),b1(1,j),
9496 & AEAb1derx(1,lll,kkk,iii,1,2))
9497 call matvec2(auxmat(1,1),Ub2(1,j),
9498 & AEAb2derx(1,lll,kkk,iii,1,2))
9499 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9500 & AEAb1derx(1,lll,kkk,iii,2,2))
9501 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9502 & AEAb2derx(1,lll,kkk,iii,2,2))
9509 C Antiparallel orientation of the two CA-CA-CA frames.
9511 iti=itype2loc(itype(i))
9515 itk1=itype2loc(itype(k+1))
9516 itl=itype2loc(itype(l))
9517 itj=itype2loc(itype(j))
9518 if (j.lt.nres-1) then
9519 itj1=itype2loc(itype(j+1))
9523 C A2 kernel(j-1)T A1T
9524 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9525 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9526 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9527 C Following matrices are needed only for 6-th order cumulants
9528 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9529 & j.eq.i+4 .and. l.eq.i+3)) THEN
9530 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9531 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9532 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9533 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9534 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9535 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9536 & ADtEAderx(1,1,1,1,1,1))
9537 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9538 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9539 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9540 & ADtEA1derx(1,1,1,1,1,1))
9542 C End 6-th order cumulants
9543 call transpose2(EUgder(1,1,k),auxmat(1,1))
9544 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9545 call transpose2(EUg(1,1,k),auxmat(1,1))
9546 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9547 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9551 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9552 & EAEAderx(1,1,lll,kkk,iii,1))
9556 C A2T kernel(i+1)T A1
9557 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9558 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9559 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9560 C Following matrices are needed only for 6-th order cumulants
9561 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9562 & j.eq.i+4 .and. l.eq.i+3)) THEN
9563 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9564 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9565 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9566 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9567 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9568 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9569 & ADtEAderx(1,1,1,1,1,2))
9570 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9571 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9572 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9573 & ADtEA1derx(1,1,1,1,1,2))
9575 C End 6-th order cumulants
9576 call transpose2(EUgder(1,1,j),auxmat(1,1))
9577 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9578 call transpose2(EUg(1,1,j),auxmat(1,1))
9579 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9580 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9584 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9585 & EAEAderx(1,1,lll,kkk,iii,2))
9590 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9591 C They are needed only when the fifth- or the sixth-order cumulants are
9593 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9594 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9595 call transpose2(AEA(1,1,1),auxmat(1,1))
9596 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9597 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9598 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9599 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9600 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9601 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9602 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9603 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9604 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9605 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9606 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9607 call transpose2(AEA(1,1,2),auxmat(1,1))
9608 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9609 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9610 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9611 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9612 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9613 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9614 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9615 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9616 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9617 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9618 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9619 C Calculate the Cartesian derivatives of the vectors.
9623 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9624 call matvec2(auxmat(1,1),b1(1,i),
9625 & AEAb1derx(1,lll,kkk,iii,1,1))
9626 call matvec2(auxmat(1,1),Ub2(1,i),
9627 & AEAb2derx(1,lll,kkk,iii,1,1))
9628 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9629 & AEAb1derx(1,lll,kkk,iii,2,1))
9630 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9631 & AEAb2derx(1,lll,kkk,iii,2,1))
9632 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9633 call matvec2(auxmat(1,1),b1(1,l),
9634 & AEAb1derx(1,lll,kkk,iii,1,2))
9635 call matvec2(auxmat(1,1),Ub2(1,l),
9636 & AEAb2derx(1,lll,kkk,iii,1,2))
9637 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9638 & AEAb1derx(1,lll,kkk,iii,2,2))
9639 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9640 & AEAb2derx(1,lll,kkk,iii,2,2))
9649 C---------------------------------------------------------------------------
9650 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9651 & KK,KKderg,AKA,AKAderg,AKAderx)
9655 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9656 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9657 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9662 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9664 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9667 cd if (lprn) write (2,*) 'In kernel'
9669 cd if (lprn) write (2,*) 'kkk=',kkk
9671 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9672 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9674 cd write (2,*) 'lll=',lll
9675 cd write (2,*) 'iii=1'
9677 cd write (2,'(3(2f10.5),5x)')
9678 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9681 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9682 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9684 cd write (2,*) 'lll=',lll
9685 cd write (2,*) 'iii=2'
9687 cd write (2,'(3(2f10.5),5x)')
9688 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9695 C---------------------------------------------------------------------------
9696 double precision function eello4(i,j,k,l,jj,kk)
9697 implicit real*8 (a-h,o-z)
9698 include 'DIMENSIONS'
9699 include 'COMMON.IOUNITS'
9700 include 'COMMON.CHAIN'
9701 include 'COMMON.DERIV'
9702 include 'COMMON.INTERACT'
9703 include 'COMMON.CONTACTS'
9704 include 'COMMON.TORSION'
9705 include 'COMMON.VAR'
9706 include 'COMMON.GEO'
9707 double precision pizda(2,2),ggg1(3),ggg2(3)
9708 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9712 cd print *,'eello4:',i,j,k,l,jj,kk
9713 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
9714 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
9715 cold eij=facont_hb(jj,i)
9716 cold ekl=facont_hb(kk,k)
9718 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9719 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9720 gcorr_loc(k-1)=gcorr_loc(k-1)
9721 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9723 gcorr_loc(l-1)=gcorr_loc(l-1)
9724 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9726 gcorr_loc(j-1)=gcorr_loc(j-1)
9727 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9732 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9733 & -EAEAderx(2,2,lll,kkk,iii,1)
9734 cd derx(lll,kkk,iii)=0.0d0
9738 cd gcorr_loc(l-1)=0.0d0
9739 cd gcorr_loc(j-1)=0.0d0
9740 cd gcorr_loc(k-1)=0.0d0
9742 cd write (iout,*)'Contacts have occurred for peptide groups',
9743 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
9744 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9745 if (j.lt.nres-1) then
9752 if (l.lt.nres-1) then
9760 cgrad ggg1(ll)=eel4*g_contij(ll,1)
9761 cgrad ggg2(ll)=eel4*g_contij(ll,2)
9762 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9763 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9764 cgrad ghalf=0.5d0*ggg1(ll)
9765 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9766 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9767 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9768 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9769 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9770 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9771 cgrad ghalf=0.5d0*ggg2(ll)
9772 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9773 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9774 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9775 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9776 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9777 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9781 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9786 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9791 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9796 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9800 cd write (2,*) iii,gcorr_loc(iii)
9803 cd write (2,*) 'ekont',ekont
9804 cd write (iout,*) 'eello4',ekont*eel4
9807 C---------------------------------------------------------------------------
9808 double precision function eello5(i,j,k,l,jj,kk)
9809 implicit real*8 (a-h,o-z)
9810 include 'DIMENSIONS'
9811 include 'COMMON.IOUNITS'
9812 include 'COMMON.CHAIN'
9813 include 'COMMON.DERIV'
9814 include 'COMMON.INTERACT'
9815 include 'COMMON.CONTACTS'
9816 include 'COMMON.TORSION'
9817 include 'COMMON.VAR'
9818 include 'COMMON.GEO'
9819 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9820 double precision ggg1(3),ggg2(3)
9821 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9826 C /l\ / \ \ / \ / \ / C
9827 C / \ / \ \ / \ / \ / C
9828 C j| o |l1 | o | o| o | | o |o C
9829 C \ |/k\| |/ \| / |/ \| |/ \| C
9830 C \i/ \ / \ / / \ / \ C
9832 C (I) (II) (III) (IV) C
9834 C eello5_1 eello5_2 eello5_3 eello5_4 C
9836 C Antiparallel chains C
9839 C /j\ / \ \ / \ / \ / C
9840 C / \ / \ \ / \ / \ / C
9841 C j1| o |l | o | o| o | | o |o C
9842 C \ |/k\| |/ \| / |/ \| |/ \| C
9843 C \i/ \ / \ / / \ / \ C
9845 C (I) (II) (III) (IV) C
9847 C eello5_1 eello5_2 eello5_3 eello5_4 C
9849 C o denotes a local interaction, vertical lines an electrostatic interaction. C
9851 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9852 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9857 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
9859 itk=itype2loc(itype(k))
9860 itl=itype2loc(itype(l))
9861 itj=itype2loc(itype(j))
9866 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9867 cd & eel5_3_num,eel5_4_num)
9871 derx(lll,kkk,iii)=0.0d0
9875 cd eij=facont_hb(jj,i)
9876 cd ekl=facont_hb(kk,k)
9878 cd write (iout,*)'Contacts have occurred for peptide groups',
9879 cd & i,j,' fcont:',eij,' eij',' and ',k,l
9881 C Contribution from the graph I.
9882 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9883 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9884 call transpose2(EUg(1,1,k),auxmat(1,1))
9885 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9886 vv(1)=pizda(1,1)-pizda(2,2)
9887 vv(2)=pizda(1,2)+pizda(2,1)
9888 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9889 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9890 C Explicit gradient in virtual-dihedral angles.
9891 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9892 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9893 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9894 call transpose2(EUgder(1,1,k),auxmat1(1,1))
9895 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9896 vv(1)=pizda(1,1)-pizda(2,2)
9897 vv(2)=pizda(1,2)+pizda(2,1)
9898 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9899 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9900 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9901 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9902 vv(1)=pizda(1,1)-pizda(2,2)
9903 vv(2)=pizda(1,2)+pizda(2,1)
9905 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9906 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9907 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9909 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9910 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9911 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9913 C Cartesian gradient
9917 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9919 vv(1)=pizda(1,1)-pizda(2,2)
9920 vv(2)=pizda(1,2)+pizda(2,1)
9921 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9922 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9923 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9929 C Contribution from graph II
9930 call transpose2(EE(1,1,k),auxmat(1,1))
9931 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9932 vv(1)=pizda(1,1)+pizda(2,2)
9933 vv(2)=pizda(2,1)-pizda(1,2)
9934 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9935 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9936 C Explicit gradient in virtual-dihedral angles.
9937 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9938 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9939 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9940 vv(1)=pizda(1,1)+pizda(2,2)
9941 vv(2)=pizda(2,1)-pizda(1,2)
9943 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9944 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9945 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9947 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9948 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9949 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9951 C Cartesian gradient
9955 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9957 vv(1)=pizda(1,1)+pizda(2,2)
9958 vv(2)=pizda(2,1)-pizda(1,2)
9959 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9960 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9961 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9969 C Parallel orientation
9970 C Contribution from graph III
9971 call transpose2(EUg(1,1,l),auxmat(1,1))
9972 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9973 vv(1)=pizda(1,1)-pizda(2,2)
9974 vv(2)=pizda(1,2)+pizda(2,1)
9975 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9976 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9977 C Explicit gradient in virtual-dihedral angles.
9978 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9979 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9980 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9981 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9982 vv(1)=pizda(1,1)-pizda(2,2)
9983 vv(2)=pizda(1,2)+pizda(2,1)
9984 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9985 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9986 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9987 call transpose2(EUgder(1,1,l),auxmat1(1,1))
9988 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9989 vv(1)=pizda(1,1)-pizda(2,2)
9990 vv(2)=pizda(1,2)+pizda(2,1)
9991 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9992 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9993 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9994 C Cartesian gradient
9998 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10000 vv(1)=pizda(1,1)-pizda(2,2)
10001 vv(2)=pizda(1,2)+pizda(2,1)
10002 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10003 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10004 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10009 C Contribution from graph IV
10011 call transpose2(EE(1,1,l),auxmat(1,1))
10012 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10013 vv(1)=pizda(1,1)+pizda(2,2)
10014 vv(2)=pizda(2,1)-pizda(1,2)
10015 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10016 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10017 C Explicit gradient in virtual-dihedral angles.
10018 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10019 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10020 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10021 vv(1)=pizda(1,1)+pizda(2,2)
10022 vv(2)=pizda(2,1)-pizda(1,2)
10023 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10024 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10025 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10026 C Cartesian gradient
10030 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10032 vv(1)=pizda(1,1)+pizda(2,2)
10033 vv(2)=pizda(2,1)-pizda(1,2)
10034 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10035 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10036 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10041 C Antiparallel orientation
10042 C Contribution from graph III
10044 call transpose2(EUg(1,1,j),auxmat(1,1))
10045 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10046 vv(1)=pizda(1,1)-pizda(2,2)
10047 vv(2)=pizda(1,2)+pizda(2,1)
10048 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10049 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10050 C Explicit gradient in virtual-dihedral angles.
10051 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10052 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10053 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10054 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10055 vv(1)=pizda(1,1)-pizda(2,2)
10056 vv(2)=pizda(1,2)+pizda(2,1)
10057 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10058 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10059 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10060 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10061 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10062 vv(1)=pizda(1,1)-pizda(2,2)
10063 vv(2)=pizda(1,2)+pizda(2,1)
10064 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10065 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10066 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10067 C Cartesian gradient
10071 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10073 vv(1)=pizda(1,1)-pizda(2,2)
10074 vv(2)=pizda(1,2)+pizda(2,1)
10075 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10076 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10077 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10082 C Contribution from graph IV
10084 call transpose2(EE(1,1,j),auxmat(1,1))
10085 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10086 vv(1)=pizda(1,1)+pizda(2,2)
10087 vv(2)=pizda(2,1)-pizda(1,2)
10088 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10089 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10090 C Explicit gradient in virtual-dihedral angles.
10091 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10092 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10093 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10094 vv(1)=pizda(1,1)+pizda(2,2)
10095 vv(2)=pizda(2,1)-pizda(1,2)
10096 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10097 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10098 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10099 C Cartesian gradient
10103 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10105 vv(1)=pizda(1,1)+pizda(2,2)
10106 vv(2)=pizda(2,1)-pizda(1,2)
10107 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10108 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10109 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10115 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10116 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10117 cd write (2,*) 'ijkl',i,j,k,l
10118 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10119 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10121 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10122 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10123 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10124 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10125 if (j.lt.nres-1) then
10132 if (l.lt.nres-1) then
10142 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10143 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10144 C summed up outside the subrouine as for the other subroutines
10145 C handling long-range interactions. The old code is commented out
10146 C with "cgrad" to keep track of changes.
10148 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10149 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10150 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10151 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10152 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10153 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10154 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10155 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10156 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10157 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10159 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10160 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10161 cgrad ghalf=0.5d0*ggg1(ll)
10163 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10164 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10165 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10166 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10167 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10168 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10169 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10170 cgrad ghalf=0.5d0*ggg2(ll)
10172 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10173 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10174 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10175 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10176 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10177 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10182 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10183 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10188 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10189 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10195 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10200 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10204 cd write (2,*) iii,g_corr5_loc(iii)
10207 cd write (2,*) 'ekont',ekont
10208 cd write (iout,*) 'eello5',ekont*eel5
10211 c--------------------------------------------------------------------------
10212 double precision function eello6(i,j,k,l,jj,kk)
10213 implicit real*8 (a-h,o-z)
10214 include 'DIMENSIONS'
10215 include 'COMMON.IOUNITS'
10216 include 'COMMON.CHAIN'
10217 include 'COMMON.DERIV'
10218 include 'COMMON.INTERACT'
10219 include 'COMMON.CONTACTS'
10220 include 'COMMON.TORSION'
10221 include 'COMMON.VAR'
10222 include 'COMMON.GEO'
10223 include 'COMMON.FFIELD'
10224 double precision ggg1(3),ggg2(3)
10225 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10230 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10238 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10239 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10243 derx(lll,kkk,iii)=0.0d0
10247 cd eij=facont_hb(jj,i)
10248 cd ekl=facont_hb(kk,k)
10254 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10255 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10256 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10257 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10258 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10259 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10261 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10262 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10263 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10264 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10265 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10266 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10270 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10272 C If turn contributions are considered, they will be handled separately.
10273 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10274 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10275 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10276 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10277 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10278 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10279 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10281 if (j.lt.nres-1) then
10288 if (l.lt.nres-1) then
10296 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10297 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10298 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10299 cgrad ghalf=0.5d0*ggg1(ll)
10301 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10302 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10303 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10304 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10305 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10306 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10307 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10308 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10309 cgrad ghalf=0.5d0*ggg2(ll)
10310 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10312 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10313 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10314 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10315 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10316 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10317 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10322 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10323 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10328 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10329 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10335 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10340 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10344 cd write (2,*) iii,g_corr6_loc(iii)
10347 cd write (2,*) 'ekont',ekont
10348 cd write (iout,*) 'eello6',ekont*eel6
10351 c--------------------------------------------------------------------------
10352 double precision function eello6_graph1(i,j,k,l,imat,swap)
10353 implicit real*8 (a-h,o-z)
10354 include 'DIMENSIONS'
10355 include 'COMMON.IOUNITS'
10356 include 'COMMON.CHAIN'
10357 include 'COMMON.DERIV'
10358 include 'COMMON.INTERACT'
10359 include 'COMMON.CONTACTS'
10360 include 'COMMON.TORSION'
10361 include 'COMMON.VAR'
10362 include 'COMMON.GEO'
10363 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10366 common /kutas/ lprn
10367 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10369 C Parallel Antiparallel C
10375 C \ j|/k\| / \ |/k\|l / C
10376 C \ / \ / \ / \ / C
10380 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10381 itk=itype2loc(itype(k))
10382 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10383 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10384 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10385 call transpose2(EUgC(1,1,k),auxmat(1,1))
10386 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10387 vv1(1)=pizda1(1,1)-pizda1(2,2)
10388 vv1(2)=pizda1(1,2)+pizda1(2,1)
10389 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10390 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10391 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10392 s5=scalar2(vv(1),Dtobr2(1,i))
10393 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10394 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10395 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10396 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10397 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10398 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10399 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10400 & +scalar2(vv(1),Dtobr2der(1,i)))
10401 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10402 vv1(1)=pizda1(1,1)-pizda1(2,2)
10403 vv1(2)=pizda1(1,2)+pizda1(2,1)
10404 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10405 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10407 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10408 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10409 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10410 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10411 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10413 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10414 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10415 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10416 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10417 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10419 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10420 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10421 vv1(1)=pizda1(1,1)-pizda1(2,2)
10422 vv1(2)=pizda1(1,2)+pizda1(2,1)
10423 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10424 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10425 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10426 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10435 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10436 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10437 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10438 call transpose2(EUgC(1,1,k),auxmat(1,1))
10439 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10441 vv1(1)=pizda1(1,1)-pizda1(2,2)
10442 vv1(2)=pizda1(1,2)+pizda1(2,1)
10443 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10444 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10445 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10446 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10447 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10448 s5=scalar2(vv(1),Dtobr2(1,i))
10449 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10455 c----------------------------------------------------------------------------
10456 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10457 implicit real*8 (a-h,o-z)
10458 include 'DIMENSIONS'
10459 include 'COMMON.IOUNITS'
10460 include 'COMMON.CHAIN'
10461 include 'COMMON.DERIV'
10462 include 'COMMON.INTERACT'
10463 include 'COMMON.CONTACTS'
10464 include 'COMMON.TORSION'
10465 include 'COMMON.VAR'
10466 include 'COMMON.GEO'
10468 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10469 & auxvec1(2),auxvec2(2),auxmat1(2,2)
10471 common /kutas/ lprn
10472 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10474 C Parallel Antiparallel C
10480 C \ j|/k\| \ |/k\|l C
10485 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10486 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10487 C AL 7/4/01 s1 would occur in the sixth-order moment,
10488 C but not in a cluster cumulant
10490 s1=dip(1,jj,i)*dip(1,kk,k)
10492 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10493 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10494 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10495 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10496 call transpose2(EUg(1,1,k),auxmat(1,1))
10497 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10498 vv(1)=pizda(1,1)-pizda(2,2)
10499 vv(2)=pizda(1,2)+pizda(2,1)
10500 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10501 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10503 eello6_graph2=-(s1+s2+s3+s4)
10505 eello6_graph2=-(s2+s3+s4)
10507 c eello6_graph2=-s3
10508 C Derivatives in gamma(i-1)
10511 s1=dipderg(1,jj,i)*dip(1,kk,k)
10513 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10514 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10515 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10516 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10518 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10520 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10522 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10524 C Derivatives in gamma(k-1)
10526 s1=dip(1,jj,i)*dipderg(1,kk,k)
10528 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10529 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10530 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10531 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10532 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10533 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10534 vv(1)=pizda(1,1)-pizda(2,2)
10535 vv(2)=pizda(1,2)+pizda(2,1)
10536 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10538 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10540 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10542 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10543 C Derivatives in gamma(j-1) or gamma(l-1)
10546 s1=dipderg(3,jj,i)*dip(1,kk,k)
10548 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10549 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10550 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10551 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10552 vv(1)=pizda(1,1)-pizda(2,2)
10553 vv(2)=pizda(1,2)+pizda(2,1)
10554 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10557 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10559 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10562 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10563 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10565 C Derivatives in gamma(l-1) or gamma(j-1)
10568 s1=dip(1,jj,i)*dipderg(3,kk,k)
10570 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10571 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10572 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10573 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10574 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10575 vv(1)=pizda(1,1)-pizda(2,2)
10576 vv(2)=pizda(1,2)+pizda(2,1)
10577 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10580 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10582 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10585 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10586 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10588 C Cartesian derivatives.
10590 write (2,*) 'In eello6_graph2'
10592 write (2,*) 'iii=',iii
10594 write (2,*) 'kkk=',kkk
10596 write (2,'(3(2f10.5),5x)')
10597 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10607 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10609 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10612 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10614 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10615 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10617 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10618 call transpose2(EUg(1,1,k),auxmat(1,1))
10619 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10621 vv(1)=pizda(1,1)-pizda(2,2)
10622 vv(2)=pizda(1,2)+pizda(2,1)
10623 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10624 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10626 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10628 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10631 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10633 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10640 c----------------------------------------------------------------------------
10641 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10642 implicit real*8 (a-h,o-z)
10643 include 'DIMENSIONS'
10644 include 'COMMON.IOUNITS'
10645 include 'COMMON.CHAIN'
10646 include 'COMMON.DERIV'
10647 include 'COMMON.INTERACT'
10648 include 'COMMON.CONTACTS'
10649 include 'COMMON.TORSION'
10650 include 'COMMON.VAR'
10651 include 'COMMON.GEO'
10652 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10654 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10656 C Parallel Antiparallel C
10661 C /| o |o o| o |\ C
10662 C j|/k\| / |/k\|l / C
10667 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10669 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10670 C energy moment and not to the cluster cumulant.
10671 iti=itortyp(itype(i))
10672 if (j.lt.nres-1) then
10673 itj1=itype2loc(itype(j+1))
10677 itk=itype2loc(itype(k))
10678 itk1=itype2loc(itype(k+1))
10679 if (l.lt.nres-1) then
10680 itl1=itype2loc(itype(l+1))
10685 s1=dip(4,jj,i)*dip(4,kk,k)
10687 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10688 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10689 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10690 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10691 call transpose2(EE(1,1,k),auxmat(1,1))
10692 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10693 vv(1)=pizda(1,1)+pizda(2,2)
10694 vv(2)=pizda(2,1)-pizda(1,2)
10695 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10696 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10697 cd & "sum",-(s2+s3+s4)
10699 eello6_graph3=-(s1+s2+s3+s4)
10701 eello6_graph3=-(s2+s3+s4)
10703 c eello6_graph3=-s4
10704 C Derivatives in gamma(k-1)
10705 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10706 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10707 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10708 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10709 C Derivatives in gamma(l-1)
10710 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10711 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10712 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10713 vv(1)=pizda(1,1)+pizda(2,2)
10714 vv(2)=pizda(2,1)-pizda(1,2)
10715 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10716 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10717 C Cartesian derivatives.
10723 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10725 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10728 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10730 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10731 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10733 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10734 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10736 vv(1)=pizda(1,1)+pizda(2,2)
10737 vv(2)=pizda(2,1)-pizda(1,2)
10738 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10740 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10742 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10745 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10747 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10749 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10755 c----------------------------------------------------------------------------
10756 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10757 implicit real*8 (a-h,o-z)
10758 include 'DIMENSIONS'
10759 include 'COMMON.IOUNITS'
10760 include 'COMMON.CHAIN'
10761 include 'COMMON.DERIV'
10762 include 'COMMON.INTERACT'
10763 include 'COMMON.CONTACTS'
10764 include 'COMMON.TORSION'
10765 include 'COMMON.VAR'
10766 include 'COMMON.GEO'
10767 include 'COMMON.FFIELD'
10768 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10769 & auxvec1(2),auxmat1(2,2)
10771 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10773 C Parallel Antiparallel C
10778 C /| o |o o| o |\ C
10779 C \ j|/k\| \ |/k\|l C
10784 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10786 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10787 C energy moment and not to the cluster cumulant.
10788 cd write (2,*) 'eello_graph4: wturn6',wturn6
10789 iti=itype2loc(itype(i))
10790 itj=itype2loc(itype(j))
10791 if (j.lt.nres-1) then
10792 itj1=itype2loc(itype(j+1))
10796 itk=itype2loc(itype(k))
10797 if (k.lt.nres-1) then
10798 itk1=itype2loc(itype(k+1))
10802 itl=itype2loc(itype(l))
10803 if (l.lt.nres-1) then
10804 itl1=itype2loc(itype(l+1))
10808 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10809 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10810 cd & ' itl',itl,' itl1',itl1
10812 if (imat.eq.1) then
10813 s1=dip(3,jj,i)*dip(3,kk,k)
10815 s1=dip(2,jj,j)*dip(2,kk,l)
10818 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10819 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10821 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10822 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10824 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10825 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10827 call transpose2(EUg(1,1,k),auxmat(1,1))
10828 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10829 vv(1)=pizda(1,1)-pizda(2,2)
10830 vv(2)=pizda(2,1)+pizda(1,2)
10831 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10832 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10834 eello6_graph4=-(s1+s2+s3+s4)
10836 eello6_graph4=-(s2+s3+s4)
10838 C Derivatives in gamma(i-1)
10841 if (imat.eq.1) then
10842 s1=dipderg(2,jj,i)*dip(3,kk,k)
10844 s1=dipderg(4,jj,j)*dip(2,kk,l)
10847 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10849 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10850 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10852 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10853 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10855 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10856 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10857 cd write (2,*) 'turn6 derivatives'
10859 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10861 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10865 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10867 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10871 C Derivatives in gamma(k-1)
10873 if (imat.eq.1) then
10874 s1=dip(3,jj,i)*dipderg(2,kk,k)
10876 s1=dip(2,jj,j)*dipderg(4,kk,l)
10879 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10880 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10882 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10883 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10885 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10886 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10888 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10889 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10890 vv(1)=pizda(1,1)-pizda(2,2)
10891 vv(2)=pizda(2,1)+pizda(1,2)
10892 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10893 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10895 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10897 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10901 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10903 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10906 C Derivatives in gamma(j-1) or gamma(l-1)
10907 if (l.eq.j+1 .and. l.gt.1) then
10908 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10909 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10910 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10911 vv(1)=pizda(1,1)-pizda(2,2)
10912 vv(2)=pizda(2,1)+pizda(1,2)
10913 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10914 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10915 else if (j.gt.1) then
10916 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10917 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10918 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10919 vv(1)=pizda(1,1)-pizda(2,2)
10920 vv(2)=pizda(2,1)+pizda(1,2)
10921 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10922 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10923 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10925 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10928 C Cartesian derivatives.
10934 if (imat.eq.1) then
10935 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10937 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10940 if (imat.eq.1) then
10941 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10943 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10947 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10949 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10951 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10952 & b1(1,j+1),auxvec(1))
10953 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10955 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10956 & b1(1,l+1),auxvec(1))
10957 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10959 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10961 vv(1)=pizda(1,1)-pizda(2,2)
10962 vv(2)=pizda(2,1)+pizda(1,2)
10963 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10965 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10967 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10970 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10973 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10976 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10978 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10980 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10984 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10986 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10989 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10991 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10999 c----------------------------------------------------------------------------
11000 double precision function eello_turn6(i,jj,kk)
11001 implicit real*8 (a-h,o-z)
11002 include 'DIMENSIONS'
11003 include 'COMMON.IOUNITS'
11004 include 'COMMON.CHAIN'
11005 include 'COMMON.DERIV'
11006 include 'COMMON.INTERACT'
11007 include 'COMMON.CONTACTS'
11008 include 'COMMON.TORSION'
11009 include 'COMMON.VAR'
11010 include 'COMMON.GEO'
11011 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11012 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11014 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11015 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11016 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11017 C the respective energy moment and not to the cluster cumulant.
11026 iti=itype2loc(itype(i))
11027 itk=itype2loc(itype(k))
11028 itk1=itype2loc(itype(k+1))
11029 itl=itype2loc(itype(l))
11030 itj=itype2loc(itype(j))
11031 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11032 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11033 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11038 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11040 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11044 derx_turn(lll,kkk,iii)=0.0d0
11051 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11053 cd write (2,*) 'eello6_5',eello6_5
11055 call transpose2(AEA(1,1,1),auxmat(1,1))
11056 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11057 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11058 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11060 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11061 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11062 s2 = scalar2(b1(1,k),vtemp1(1))
11064 call transpose2(AEA(1,1,2),atemp(1,1))
11065 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11066 call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11067 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11069 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11070 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11071 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11073 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11074 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11075 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11076 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11077 ss13 = scalar2(b1(1,k),vtemp4(1))
11078 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11080 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11086 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11087 C Derivatives in gamma(i+2)
11091 call transpose2(AEA(1,1,1),auxmatd(1,1))
11092 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11093 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11094 call transpose2(AEAderg(1,1,2),atempd(1,1))
11095 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11096 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11098 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11099 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11100 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11106 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11107 C Derivatives in gamma(i+3)
11109 call transpose2(AEA(1,1,1),auxmatd(1,1))
11110 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11111 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11112 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11114 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11115 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11116 s2d = scalar2(b1(1,k),vtemp1d(1))
11118 call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11119 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11121 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11123 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11124 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11125 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11133 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11134 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11136 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11137 & -0.5d0*ekont*(s2d+s12d)
11139 C Derivatives in gamma(i+4)
11140 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11141 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11142 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11144 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11145 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11146 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11154 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11156 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11158 C Derivatives in gamma(i+5)
11160 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11161 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11162 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11164 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11165 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11166 s2d = scalar2(b1(1,k),vtemp1d(1))
11168 call transpose2(AEA(1,1,2),atempd(1,1))
11169 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11170 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11172 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11173 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11175 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11176 ss13d = scalar2(b1(1,k),vtemp4d(1))
11177 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11185 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11186 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11188 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11189 & -0.5d0*ekont*(s2d+s12d)
11191 C Cartesian derivatives
11196 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11197 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11198 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11200 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11201 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11203 s2d = scalar2(b1(1,k),vtemp1d(1))
11205 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11206 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11207 s8d = -(atempd(1,1)+atempd(2,2))*
11208 & scalar2(cc(1,1,itl),vtemp2(1))
11210 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11212 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11213 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11220 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11221 & - 0.5d0*(s1d+s2d)
11223 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11227 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11228 & - 0.5d0*(s8d+s12d)
11230 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11239 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11240 & achuj_tempd(1,1))
11241 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11242 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11243 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11244 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11245 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11247 ss13d = scalar2(b1(1,k),vtemp4d(1))
11248 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11249 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11253 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11254 cd & 16*eel_turn6_num
11256 if (j.lt.nres-1) then
11263 if (l.lt.nres-1) then
11271 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11272 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11273 cgrad ghalf=0.5d0*ggg1(ll)
11275 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11276 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11277 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11278 & +ekont*derx_turn(ll,2,1)
11279 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11280 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11281 & +ekont*derx_turn(ll,4,1)
11282 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11283 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11284 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11285 cgrad ghalf=0.5d0*ggg2(ll)
11287 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11288 & +ekont*derx_turn(ll,2,2)
11289 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11290 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11291 & +ekont*derx_turn(ll,4,2)
11292 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11293 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11294 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11299 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11304 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11310 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11315 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11319 cd write (2,*) iii,g_corr6_loc(iii)
11321 eello_turn6=ekont*eel_turn6
11322 cd write (2,*) 'ekont',ekont
11323 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11327 C-----------------------------------------------------------------------------
11328 double precision function scalar(u,v)
11329 !DIR$ INLINEALWAYS scalar
11331 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11334 double precision u(3),v(3)
11335 cd double precision sc
11343 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11346 crc-------------------------------------------------
11347 SUBROUTINE MATVEC2(A1,V1,V2)
11348 !DIR$ INLINEALWAYS MATVEC2
11350 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11352 implicit real*8 (a-h,o-z)
11353 include 'DIMENSIONS'
11354 DIMENSION A1(2,2),V1(2),V2(2)
11358 c 3 VI=VI+A1(I,K)*V1(K)
11362 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11363 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11368 C---------------------------------------
11369 SUBROUTINE MATMAT2(A1,A2,A3)
11371 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11373 implicit real*8 (a-h,o-z)
11374 include 'DIMENSIONS'
11375 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11376 c DIMENSION AI3(2,2)
11380 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11386 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11387 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11388 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11389 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11397 c-------------------------------------------------------------------------
11398 double precision function scalar2(u,v)
11399 !DIR$ INLINEALWAYS scalar2
11401 double precision u(2),v(2)
11402 double precision sc
11404 scalar2=u(1)*v(1)+u(2)*v(2)
11408 C-----------------------------------------------------------------------------
11410 subroutine transpose2(a,at)
11411 !DIR$ INLINEALWAYS transpose2
11413 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11416 double precision a(2,2),at(2,2)
11423 c--------------------------------------------------------------------------
11424 subroutine transpose(n,a,at)
11427 double precision a(n,n),at(n,n)
11435 C---------------------------------------------------------------------------
11436 subroutine prodmat3(a1,a2,kk,transp,prod)
11437 !DIR$ INLINEALWAYS prodmat3
11439 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11443 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11445 crc double precision auxmat(2,2),prod_(2,2)
11448 crc call transpose2(kk(1,1),auxmat(1,1))
11449 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11450 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11452 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11453 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11454 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11455 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11456 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11457 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11458 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11459 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11462 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11463 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11465 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11466 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11467 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11468 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11469 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11470 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11471 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11472 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11475 c call transpose2(a2(1,1),a2t(1,1))
11478 crc print *,((prod_(i,j),i=1,2),j=1,2)
11479 crc print *,((prod(i,j),i=1,2),j=1,2)
11483 CCC----------------------------------------------
11484 subroutine Eliptransfer(eliptran)
11485 implicit real*8 (a-h,o-z)
11486 include 'DIMENSIONS'
11487 include 'COMMON.GEO'
11488 include 'COMMON.VAR'
11489 include 'COMMON.LOCAL'
11490 include 'COMMON.CHAIN'
11491 include 'COMMON.DERIV'
11492 include 'COMMON.NAMES'
11493 include 'COMMON.INTERACT'
11494 include 'COMMON.IOUNITS'
11495 include 'COMMON.CALC'
11496 include 'COMMON.CONTROL'
11497 include 'COMMON.SPLITELE'
11498 include 'COMMON.SBRIDGE'
11499 C this is done by Adasko
11500 C print *,"wchodze"
11501 C structure of box:
11503 C--bordliptop-- buffore starts
11504 C--bufliptop--- here true lipid starts
11506 C--buflipbot--- lipid ends buffore starts
11507 C--bordlipbot--buffore ends
11509 do i=ilip_start,ilip_end
11511 if (itype(i).eq.ntyp1) cycle
11513 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11514 if (positi.le.0.0) positi=positi+boxzsize
11516 C first for peptide groups
11517 c for each residue check if it is in lipid or lipid water border area
11518 if ((positi.gt.bordlipbot)
11519 &.and.(positi.lt.bordliptop)) then
11520 C the energy transfer exist
11521 if (positi.lt.buflipbot) then
11522 C what fraction I am in
11524 & ((positi-bordlipbot)/lipbufthick)
11525 C lipbufthick is thickenes of lipid buffore
11526 sslip=sscalelip(fracinbuf)
11527 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11528 eliptran=eliptran+sslip*pepliptran
11529 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11530 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11531 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11533 C print *,"doing sccale for lower part"
11534 C print *,i,sslip,fracinbuf,ssgradlip
11535 elseif (positi.gt.bufliptop) then
11536 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11537 sslip=sscalelip(fracinbuf)
11538 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11539 eliptran=eliptran+sslip*pepliptran
11540 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11541 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11542 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11543 C print *, "doing sscalefor top part"
11544 C print *,i,sslip,fracinbuf,ssgradlip
11546 eliptran=eliptran+pepliptran
11547 C print *,"I am in true lipid"
11550 C eliptran=elpitran+0.0 ! I am in water
11553 C print *, "nic nie bylo w lipidzie?"
11554 C now multiply all by the peptide group transfer factor
11555 C eliptran=eliptran*pepliptran
11556 C now the same for side chains
11558 do i=ilip_start,ilip_end
11559 if (itype(i).eq.ntyp1) cycle
11560 positi=(mod(c(3,i+nres),boxzsize))
11561 if (positi.le.0) positi=positi+boxzsize
11562 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11563 c for each residue check if it is in lipid or lipid water border area
11564 C respos=mod(c(3,i+nres),boxzsize)
11565 C print *,positi,bordlipbot,buflipbot
11566 if ((positi.gt.bordlipbot)
11567 & .and.(positi.lt.bordliptop)) then
11568 C the energy transfer exist
11569 if (positi.lt.buflipbot) then
11571 & ((positi-bordlipbot)/lipbufthick)
11572 C lipbufthick is thickenes of lipid buffore
11573 sslip=sscalelip(fracinbuf)
11574 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11575 eliptran=eliptran+sslip*liptranene(itype(i))
11576 gliptranx(3,i)=gliptranx(3,i)
11577 &+ssgradlip*liptranene(itype(i))
11578 gliptranc(3,i-1)= gliptranc(3,i-1)
11579 &+ssgradlip*liptranene(itype(i))
11580 C print *,"doing sccale for lower part"
11581 elseif (positi.gt.bufliptop) then
11583 &((bordliptop-positi)/lipbufthick)
11584 sslip=sscalelip(fracinbuf)
11585 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11586 eliptran=eliptran+sslip*liptranene(itype(i))
11587 gliptranx(3,i)=gliptranx(3,i)
11588 &+ssgradlip*liptranene(itype(i))
11589 gliptranc(3,i-1)= gliptranc(3,i-1)
11590 &+ssgradlip*liptranene(itype(i))
11591 C print *, "doing sscalefor top part",sslip,fracinbuf
11593 eliptran=eliptran+liptranene(itype(i))
11594 C print *,"I am in true lipid"
11596 endif ! if in lipid or buffor
11598 C eliptran=elpitran+0.0 ! I am in water
11602 C---------------------------------------------------------
11603 C AFM soubroutine for constant force
11604 subroutine AFMforce(Eafmforce)
11605 implicit real*8 (a-h,o-z)
11606 include 'DIMENSIONS'
11607 include 'COMMON.GEO'
11608 include 'COMMON.VAR'
11609 include 'COMMON.LOCAL'
11610 include 'COMMON.CHAIN'
11611 include 'COMMON.DERIV'
11612 include 'COMMON.NAMES'
11613 include 'COMMON.INTERACT'
11614 include 'COMMON.IOUNITS'
11615 include 'COMMON.CALC'
11616 include 'COMMON.CONTROL'
11617 include 'COMMON.SPLITELE'
11618 include 'COMMON.SBRIDGE'
11623 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11624 dist=dist+diffafm(i)**2
11627 Eafmforce=-forceAFMconst*(dist-distafminit)
11629 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11630 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11632 C print *,'AFM',Eafmforce
11635 C---------------------------------------------------------
11636 C AFM subroutine with pseudoconstant velocity
11637 subroutine AFMvel(Eafmforce)
11638 implicit real*8 (a-h,o-z)
11639 include 'DIMENSIONS'
11640 include 'COMMON.GEO'
11641 include 'COMMON.VAR'
11642 include 'COMMON.LOCAL'
11643 include 'COMMON.CHAIN'
11644 include 'COMMON.DERIV'
11645 include 'COMMON.NAMES'
11646 include 'COMMON.INTERACT'
11647 include 'COMMON.IOUNITS'
11648 include 'COMMON.CALC'
11649 include 'COMMON.CONTROL'
11650 include 'COMMON.SPLITELE'
11651 include 'COMMON.SBRIDGE'
11653 C Only for check grad COMMENT if not used for checkgrad
11655 C--------------------------------------------------------
11656 C print *,"wchodze"
11660 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11661 dist=dist+diffafm(i)**2
11664 Eafmforce=0.5d0*forceAFMconst
11665 & *(distafminit+totTafm*velAFMconst-dist)**2
11666 C Eafmforce=-forceAFMconst*(dist-distafminit)
11668 gradafm(i,afmend-1)=-forceAFMconst*
11669 &(distafminit+totTafm*velAFMconst-dist)
11671 gradafm(i,afmbeg-1)=forceAFMconst*
11672 &(distafminit+totTafm*velAFMconst-dist)
11675 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11678 C-----------------------------------------------------------
11679 C first for shielding is setting of function of side-chains
11680 subroutine set_shield_fac
11681 implicit real*8 (a-h,o-z)
11682 include 'DIMENSIONS'
11683 include 'COMMON.CHAIN'
11684 include 'COMMON.DERIV'
11685 include 'COMMON.IOUNITS'
11686 include 'COMMON.SHIELD'
11687 include 'COMMON.INTERACT'
11688 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11689 double precision div77_81/0.974996043d0/,
11690 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11692 C the vector between center of side_chain and peptide group
11693 double precision pep_side(3),long,side_calf(3),
11694 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11695 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11696 C the line belowe needs to be changed for FGPROC>1
11698 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11700 Cif there two consequtive dummy atoms there is no peptide group between them
11701 C the line below has to be changed for FGPROC>1
11704 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11708 C first lets set vector conecting the ithe side-chain with kth side-chain
11709 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11710 C pep_side(j)=2.0d0
11711 C and vector conecting the side-chain with its proper calfa
11712 side_calf(j)=c(j,k+nres)-c(j,k)
11713 C side_calf(j)=2.0d0
11714 pept_group(j)=c(j,i)-c(j,i+1)
11715 C lets have their lenght
11716 dist_pep_side=pep_side(j)**2+dist_pep_side
11717 dist_side_calf=dist_side_calf+side_calf(j)**2
11718 dist_pept_group=dist_pept_group+pept_group(j)**2
11720 dist_pep_side=dsqrt(dist_pep_side)
11721 dist_pept_group=dsqrt(dist_pept_group)
11722 dist_side_calf=dsqrt(dist_side_calf)
11724 pep_side_norm(j)=pep_side(j)/dist_pep_side
11725 side_calf_norm(j)=dist_side_calf
11727 C now sscale fraction
11728 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11729 C print *,buff_shield,"buff"
11731 if (sh_frac_dist.le.0.0) cycle
11732 C If we reach here it means that this side chain reaches the shielding sphere
11733 C Lets add him to the list for gradient
11734 ishield_list(i)=ishield_list(i)+1
11735 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11736 C this list is essential otherwise problem would be O3
11737 shield_list(ishield_list(i),i)=k
11738 C Lets have the sscale value
11739 if (sh_frac_dist.gt.1.0) then
11740 scale_fac_dist=1.0d0
11742 sh_frac_dist_grad(j)=0.0d0
11745 scale_fac_dist=-sh_frac_dist*sh_frac_dist
11746 & *(2.0*sh_frac_dist-3.0d0)
11747 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11748 & /dist_pep_side/buff_shield*0.5
11749 C remember for the final gradient multiply sh_frac_dist_grad(j)
11750 C for side_chain by factor -2 !
11752 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11753 C print *,"jestem",scale_fac_dist,fac_help_scale,
11754 C & sh_frac_dist_grad(j)
11757 C if ((i.eq.3).and.(k.eq.2)) then
11758 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11762 C this is what is now we have the distance scaling now volume...
11763 short=short_r_sidechain(itype(k))
11764 long=long_r_sidechain(itype(k))
11765 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11768 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11769 C costhet_fac=0.0d0
11771 costhet_grad(j)=costhet_fac*pep_side(j)
11773 C remember for the final gradient multiply costhet_grad(j)
11774 C for side_chain by factor -2 !
11775 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11776 C pep_side0pept_group is vector multiplication
11777 pep_side0pept_group=0.0
11779 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11781 cosalfa=(pep_side0pept_group/
11782 & (dist_pep_side*dist_side_calf))
11783 fac_alfa_sin=1.0-cosalfa**2
11784 fac_alfa_sin=dsqrt(fac_alfa_sin)
11785 rkprim=fac_alfa_sin*(long-short)+short
11787 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11788 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11791 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11792 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11793 &*(long-short)/fac_alfa_sin*cosalfa/
11794 &((dist_pep_side*dist_side_calf))*
11795 &((side_calf(j))-cosalfa*
11796 &((pep_side(j)/dist_pep_side)*dist_side_calf))
11798 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11799 &*(long-short)/fac_alfa_sin*cosalfa
11800 &/((dist_pep_side*dist_side_calf))*
11802 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11805 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11808 C now the gradient...
11809 C grad_shield is gradient of Calfa for peptide groups
11810 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11812 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11813 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11815 grad_shield(j,i)=grad_shield(j,i)
11816 C gradient po skalowaniu
11817 & +(sh_frac_dist_grad(j)
11818 C gradient po costhet
11819 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11820 &-scale_fac_dist*(cosphi_grad_long(j))
11821 &/(1.0-cosphi) )*div77_81
11823 C grad_shield_side is Cbeta sidechain gradient
11824 grad_shield_side(j,ishield_list(i),i)=
11825 & (sh_frac_dist_grad(j)*-2.0d0
11826 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11827 & +scale_fac_dist*(cosphi_grad_long(j))
11828 & *2.0d0/(1.0-cosphi))
11829 & *div77_81*VofOverlap
11831 grad_shield_loc(j,ishield_list(i),i)=
11832 & scale_fac_dist*cosphi_grad_loc(j)
11833 & *2.0d0/(1.0-cosphi)
11834 & *div77_81*VofOverlap
11836 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11838 fac_shield(i)=VolumeTotal*div77_81+div4_81
11839 C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11843 C--------------------------------------------------------------------------
11844 double precision function tschebyshev(m,n,x,y)
11846 include "DIMENSIONS"
11848 double precision x(n),y,yy(0:maxvar),aux
11849 c Tschebyshev polynomial. Note that the first term is omitted
11850 c m=0: the constant term is included
11851 c m=1: the constant term is not included
11855 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11864 C--------------------------------------------------------------------------
11865 double precision function gradtschebyshev(m,n,x,y)
11867 include "DIMENSIONS"
11869 double precision x(n+1),y,yy(0:maxvar),aux
11870 c Tschebyshev polynomial. Note that the first term is omitted
11871 c m=0: the constant term is included
11872 c m=1: the constant term is not included
11876 yy(i)=2*y*yy(i-1)-yy(i-2)
11880 aux=aux+x(i+1)*yy(i)*(i+1)
11881 C print *, x(i+1),yy(i),i
11883 gradtschebyshev=aux
11886 C------------------------------------------------------------------------
11887 C first for shielding is setting of function of side-chains
11888 subroutine set_shield_fac2
11889 implicit real*8 (a-h,o-z)
11890 include 'DIMENSIONS'
11891 include 'COMMON.CHAIN'
11892 include 'COMMON.DERIV'
11893 include 'COMMON.IOUNITS'
11894 include 'COMMON.SHIELD'
11895 include 'COMMON.INTERACT'
11896 include 'COMMON.LOCAL'
11898 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11899 double precision div77_81/0.974996043d0/,
11900 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11902 C the vector between center of side_chain and peptide group
11903 double precision pep_side(3),long,side_calf(3),
11904 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11905 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11906 C write(2,*) "ivec",ivec_start,ivec_end
11908 fac_shield(i)=0.0d0
11910 grad_shield(j,i)=0.0d0
11913 C the line belowe needs to be changed for FGPROC>1
11914 do i=ivec_start,ivec_end
11916 C if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11918 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11919 Cif there two consequtive dummy atoms there is no peptide group between them
11920 C the line below has to be changed for FGPROC>1
11923 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11927 C first lets set vector conecting the ithe side-chain with kth side-chain
11928 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11929 C pep_side(j)=2.0d0
11930 C and vector conecting the side-chain with its proper calfa
11931 side_calf(j)=c(j,k+nres)-c(j,k)
11932 C side_calf(j)=2.0d0
11933 pept_group(j)=c(j,i)-c(j,i+1)
11934 C lets have their lenght
11935 dist_pep_side=pep_side(j)**2+dist_pep_side
11936 dist_side_calf=dist_side_calf+side_calf(j)**2
11937 dist_pept_group=dist_pept_group+pept_group(j)**2
11939 dist_pep_side=dsqrt(dist_pep_side)
11940 dist_pept_group=dsqrt(dist_pept_group)
11941 dist_side_calf=dsqrt(dist_side_calf)
11943 pep_side_norm(j)=pep_side(j)/dist_pep_side
11944 side_calf_norm(j)=dist_side_calf
11946 C now sscale fraction
11947 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11948 C print *,buff_shield,"buff"
11950 if (sh_frac_dist.le.0.0) cycle
11951 C print *,ishield_list(i),i
11952 C If we reach here it means that this side chain reaches the shielding sphere
11953 C Lets add him to the list for gradient
11954 ishield_list(i)=ishield_list(i)+1
11955 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11956 C this list is essential otherwise problem would be O3
11957 shield_list(ishield_list(i),i)=k
11958 C Lets have the sscale value
11959 if (sh_frac_dist.gt.1.0) then
11960 scale_fac_dist=1.0d0
11962 sh_frac_dist_grad(j)=0.0d0
11965 scale_fac_dist=-sh_frac_dist*sh_frac_dist
11966 & *(2.0d0*sh_frac_dist-3.0d0)
11967 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11968 & /dist_pep_side/buff_shield*0.5d0
11969 C remember for the final gradient multiply sh_frac_dist_grad(j)
11970 C for side_chain by factor -2 !
11972 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11973 C sh_frac_dist_grad(j)=0.0d0
11974 C scale_fac_dist=1.0d0
11975 C print *,"jestem",scale_fac_dist,fac_help_scale,
11976 C & sh_frac_dist_grad(j)
11979 C this is what is now we have the distance scaling now volume...
11980 short=short_r_sidechain(itype(k))
11981 long=long_r_sidechain(itype(k))
11982 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11983 sinthet=short/dist_pep_side*costhet
11987 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11988 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11989 C & -short/dist_pep_side**2/costhet)
11990 C costhet_fac=0.0d0
11992 costhet_grad(j)=costhet_fac*pep_side(j)
11994 C remember for the final gradient multiply costhet_grad(j)
11995 C for side_chain by factor -2 !
11996 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11997 C pep_side0pept_group is vector multiplication
11998 pep_side0pept_group=0.0d0
12000 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12002 cosalfa=(pep_side0pept_group/
12003 & (dist_pep_side*dist_side_calf))
12004 fac_alfa_sin=1.0d0-cosalfa**2
12005 fac_alfa_sin=dsqrt(fac_alfa_sin)
12006 rkprim=fac_alfa_sin*(long-short)+short
12010 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12012 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12013 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12014 & dist_pep_side**2)
12017 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12018 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12019 &*(long-short)/fac_alfa_sin*cosalfa/
12020 &((dist_pep_side*dist_side_calf))*
12021 &((side_calf(j))-cosalfa*
12022 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12023 C cosphi_grad_long(j)=0.0d0
12024 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12025 &*(long-short)/fac_alfa_sin*cosalfa
12026 &/((dist_pep_side*dist_side_calf))*
12028 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12029 C cosphi_grad_loc(j)=0.0d0
12031 C print *,sinphi,sinthet
12032 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12035 C now the gradient...
12037 grad_shield(j,i)=grad_shield(j,i)
12038 C gradient po skalowaniu
12039 & +(sh_frac_dist_grad(j)*VofOverlap
12040 C gradient po costhet
12041 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12042 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12043 & sinphi/sinthet*costhet*costhet_grad(j)
12044 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12046 C grad_shield_side is Cbeta sidechain gradient
12047 grad_shield_side(j,ishield_list(i),i)=
12048 & (sh_frac_dist_grad(j)*-2.0d0
12050 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12051 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12052 & sinphi/sinthet*costhet*costhet_grad(j)
12053 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12056 grad_shield_loc(j,ishield_list(i),i)=
12057 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12058 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12059 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12063 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12065 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12066 C write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
12070 C-----------------------------------------------------------------------
12071 C-----------------------------------------------------------
12072 C This subroutine is to mimic the histone like structure but as well can be
12073 C utilizet to nanostructures (infinit) small modification has to be used to
12074 C make it finite (z gradient at the ends has to be changes as well as the x,y
12075 C gradient has to be modified at the ends
12076 C The energy function is Kihara potential
12077 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12078 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12079 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12080 C simple Kihara potential
12081 subroutine calctube(Etube)
12082 implicit real*8 (a-h,o-z)
12083 include 'DIMENSIONS'
12084 include 'COMMON.GEO'
12085 include 'COMMON.VAR'
12086 include 'COMMON.LOCAL'
12087 include 'COMMON.CHAIN'
12088 include 'COMMON.DERIV'
12089 include 'COMMON.NAMES'
12090 include 'COMMON.INTERACT'
12091 include 'COMMON.IOUNITS'
12092 include 'COMMON.CALC'
12093 include 'COMMON.CONTROL'
12094 include 'COMMON.SPLITELE'
12095 include 'COMMON.SBRIDGE'
12096 double precision tub_r,vectube(3),enetube(maxres*2)
12101 C first we calculate the distance from tube center
12102 C first sugare-phosphate group for NARES this would be peptide group
12105 C lets ommit dummy atoms for now
12106 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12107 C now calculate distance from center of tube and direction vectors
12108 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12109 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12110 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12111 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12112 vectube(1)=vectube(1)-tubecenter(1)
12113 vectube(2)=vectube(2)-tubecenter(2)
12115 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12116 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12118 C as the tube is infinity we do not calculate the Z-vector use of Z
12121 C now calculte the distance
12122 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12123 C now normalize vector
12124 vectube(1)=vectube(1)/tub_r
12125 vectube(2)=vectube(2)/tub_r
12126 C calculte rdiffrence between r and r0
12129 rdiff6=rdiff**6.0d0
12130 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12131 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12132 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12133 C print *,rdiff,rdiff6,pep_aa_tube
12134 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12135 C now we calculate gradient
12136 fac=(-12.0d0*pep_aa_tube/rdiff6+
12137 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12138 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12141 C now direction of gg_tube vector
12143 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12144 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12147 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12149 C Lets not jump over memory as we use many times iti
12151 C lets ommit dummy atoms for now
12153 C in UNRES uncomment the line below as GLY has no side-chain...
12156 vectube(1)=c(1,i+nres)
12157 vectube(1)=mod(vectube(1),boxxsize)
12158 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12159 vectube(2)=c(2,i+nres)
12160 vectube(2)=mod(vectube(2),boxysize)
12161 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12163 vectube(1)=vectube(1)-tubecenter(1)
12164 vectube(2)=vectube(2)-tubecenter(2)
12166 C as the tube is infinity we do not calculate the Z-vector use of Z
12169 C now calculte the distance
12170 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12171 C now normalize vector
12172 vectube(1)=vectube(1)/tub_r
12173 vectube(2)=vectube(2)/tub_r
12174 C calculte rdiffrence between r and r0
12177 rdiff6=rdiff**6.0d0
12178 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12179 sc_aa_tube=sc_aa_tube_par(iti)
12180 sc_bb_tube=sc_bb_tube_par(iti)
12181 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12182 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12183 C now we calculate gradient
12184 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12185 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12186 C now direction of gg_tube vector
12188 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12189 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12193 Etube=Etube+enetube(i)
12195 C print *,"ETUBE", etube
12198 C TO DO 1) add to total energy
12199 C 2) add to gradient summation
12200 C 3) add reading parameters (AND of course oppening of PARAM file)
12201 C 4) add reading the center of tube
12203 C 6) add to zerograd
12205 C-----------------------------------------------------------------------
12206 C-----------------------------------------------------------
12207 C This subroutine is to mimic the histone like structure but as well can be
12208 C utilizet to nanostructures (infinit) small modification has to be used to
12209 C make it finite (z gradient at the ends has to be changes as well as the x,y
12210 C gradient has to be modified at the ends
12211 C The energy function is Kihara potential
12212 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12213 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12214 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12215 C simple Kihara potential
12216 subroutine calctube2(Etube)
12217 implicit real*8 (a-h,o-z)
12218 include 'DIMENSIONS'
12219 include 'COMMON.GEO'
12220 include 'COMMON.VAR'
12221 include 'COMMON.LOCAL'
12222 include 'COMMON.CHAIN'
12223 include 'COMMON.DERIV'
12224 include 'COMMON.NAMES'
12225 include 'COMMON.INTERACT'
12226 include 'COMMON.IOUNITS'
12227 include 'COMMON.CALC'
12228 include 'COMMON.CONTROL'
12229 include 'COMMON.SPLITELE'
12230 include 'COMMON.SBRIDGE'
12231 double precision tub_r,vectube(3),enetube(maxres*2)
12236 C first we calculate the distance from tube center
12237 C first sugare-phosphate group for NARES this would be peptide group
12240 C lets ommit dummy atoms for now
12242 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12243 C now calculate distance from center of tube and direction vectors
12244 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12245 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12246 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12247 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12248 vectube(1)=vectube(1)-tubecenter(1)
12249 vectube(2)=vectube(2)-tubecenter(2)
12251 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12252 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12254 C as the tube is infinity we do not calculate the Z-vector use of Z
12257 C now calculte the distance
12258 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12259 C now normalize vector
12260 vectube(1)=vectube(1)/tub_r
12261 vectube(2)=vectube(2)/tub_r
12262 C calculte rdiffrence between r and r0
12265 rdiff6=rdiff**6.0d0
12266 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12267 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12268 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12269 C print *,rdiff,rdiff6,pep_aa_tube
12270 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12271 C now we calculate gradient
12272 fac=(-12.0d0*pep_aa_tube/rdiff6+
12273 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12274 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12277 C now direction of gg_tube vector
12279 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12280 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12283 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12285 C Lets not jump over memory as we use many times iti
12287 C lets ommit dummy atoms for now
12289 C in UNRES uncomment the line below as GLY has no side-chain...
12292 vectube(1)=c(1,i+nres)
12293 vectube(1)=mod(vectube(1),boxxsize)
12294 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12295 vectube(2)=c(2,i+nres)
12296 vectube(2)=mod(vectube(2),boxysize)
12297 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12299 vectube(1)=vectube(1)-tubecenter(1)
12300 vectube(2)=vectube(2)-tubecenter(2)
12301 C THIS FRAGMENT MAKES TUBE FINITE
12302 positi=(mod(c(3,i+nres),boxzsize))
12303 if (positi.le.0) positi=positi+boxzsize
12304 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12305 c for each residue check if it is in lipid or lipid water border area
12306 C respos=mod(c(3,i+nres),boxzsize)
12307 print *,positi,bordtubebot,buftubebot,bordtubetop
12308 if ((positi.gt.bordtubebot)
12309 & .and.(positi.lt.bordtubetop)) then
12310 C the energy transfer exist
12311 if (positi.lt.buftubebot) then
12313 & ((positi-bordtubebot)/tubebufthick)
12314 C lipbufthick is thickenes of lipid buffore
12315 sstube=sscalelip(fracinbuf)
12316 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12317 print *,ssgradtube, sstube,tubetranene(itype(i))
12318 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12319 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12320 C &+ssgradtube*tubetranene(itype(i))
12321 C gg_tube(3,i-1)= gg_tube(3,i-1)
12322 C &+ssgradtube*tubetranene(itype(i))
12323 C print *,"doing sccale for lower part"
12324 elseif (positi.gt.buftubetop) then
12326 &((bordtubetop-positi)/tubebufthick)
12327 sstube=sscalelip(fracinbuf)
12328 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12329 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12330 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12331 C &+ssgradtube*tubetranene(itype(i))
12332 C gg_tube(3,i-1)= gg_tube(3,i-1)
12333 C &+ssgradtube*tubetranene(itype(i))
12334 C print *, "doing sscalefor top part",sslip,fracinbuf
12338 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12339 C print *,"I am in true lipid"
12345 endif ! if in lipid or buffor
12346 CEND OF FINITE FRAGMENT
12347 C as the tube is infinity we do not calculate the Z-vector use of Z
12350 C now calculte the distance
12351 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12352 C now normalize vector
12353 vectube(1)=vectube(1)/tub_r
12354 vectube(2)=vectube(2)/tub_r
12355 C calculte rdiffrence between r and r0
12358 rdiff6=rdiff**6.0d0
12359 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12360 sc_aa_tube=sc_aa_tube_par(iti)
12361 sc_bb_tube=sc_bb_tube_par(iti)
12362 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12363 & *sstube+enetube(i+nres)
12364 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12365 C now we calculate gradient
12366 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12367 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12368 C now direction of gg_tube vector
12370 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12371 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12373 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12374 &+ssgradtube*enetube(i+nres)/sstube
12375 gg_tube(3,i-1)= gg_tube(3,i-1)
12376 &+ssgradtube*enetube(i+nres)/sstube
12380 Etube=Etube+enetube(i)
12382 C print *,"ETUBE", etube
12385 C TO DO 1) add to total energy
12386 C 2) add to gradient summation
12387 C 3) add reading parameters (AND of course oppening of PARAM file)
12388 C 4) add reading the center of tube
12390 C 6) add to zerograd