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 xmedi=mod(xmedi,boxxsize)
3640 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3641 ymedi=mod(ymedi,boxysize)
3642 if (ymedi.lt.0) ymedi=ymedi+boxysize
3643 zmedi=mod(zmedi,boxzsize)
3644 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3645 zmedi2=mod(zmedi,boxzsize)
3646 if (zmedi2.lt.0) zmedi2=zmedi2+boxzsize
3647 if ((zmedi2.gt.bordlipbot)
3648 &.and.(zmedi2.lt.bordliptop)) then
3649 C the energy transfer exist
3650 if (zmedi2.lt.buflipbot) then
3651 C what fraction I am in
3653 & ((zmedi2-bordlipbot)/lipbufthick)
3654 C lipbufthick is thickenes of lipid buffore
3655 sslipi=sscalelip(fracinbuf)
3656 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3657 elseif (zmedi2.gt.bufliptop) then
3658 fracinbuf=1.0d0-((bordliptop-zmedi2)/lipbufthick)
3659 sslipi=sscalelip(fracinbuf)
3660 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3669 num_conti=num_cont_hb(i)
3670 c write(iout,*) "JESTEM W PETLI"
3671 call eelecij(i,i+3,ees,evdw1,eel_loc)
3672 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3673 & call eturn4(i,eello_turn4)
3674 num_cont_hb(i)=num_conti
3676 C Loop over all neighbouring boxes
3681 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3684 do i=iatel_s,iatel_e
3687 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3688 C changes suggested by Ana to avoid out of bounds
3689 c & .or.((i+2).gt.nres)
3690 c & .or.((i-1).le.0)
3691 C end of changes by Ana
3692 c & .or. itype(i+2).eq.ntyp1
3693 c & .or. itype(i-1).eq.ntyp1
3698 dx_normi=dc_norm(1,i)
3699 dy_normi=dc_norm(2,i)
3700 dz_normi=dc_norm(3,i)
3701 xmedi=c(1,i)+0.5d0*dxi
3702 ymedi=c(2,i)+0.5d0*dyi
3703 zmedi=c(3,i)+0.5d0*dzi
3704 xmedi=mod(xmedi,boxxsize)
3705 if (xmedi.lt.0) xmedi=xmedi+boxxsize
3706 ymedi=mod(ymedi,boxysize)
3707 if (ymedi.lt.0) ymedi=ymedi+boxysize
3708 zmedi=mod(zmedi,boxzsize)
3709 if (zmedi.lt.0) zmedi=zmedi+boxzsize
3710 if ((zmedi.gt.bordlipbot)
3711 &.and.(zmedi.lt.bordliptop)) then
3712 C the energy transfer exist
3713 if (zmedi.lt.buflipbot) then
3714 C what fraction I am in
3716 & ((zmedi-bordlipbot)/lipbufthick)
3717 C lipbufthick is thickenes of lipid buffore
3718 sslipi=sscalelip(fracinbuf)
3719 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3720 elseif (zmedi.gt.bufliptop) then
3721 fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3722 sslipi=sscalelip(fracinbuf)
3723 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3732 C print *,sslipi,"TU?!"
3733 C xmedi=xmedi+xshift*boxxsize
3734 C ymedi=ymedi+yshift*boxysize
3735 C zmedi=zmedi+zshift*boxzsize
3737 C Return tom into box, boxxsize is size of box in x dimension
3739 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3740 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3741 C Condition for being inside the proper box
3742 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3743 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3747 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3748 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3749 C Condition for being inside the proper box
3750 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3751 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3755 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3756 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3757 cC Condition for being inside the proper box
3758 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3759 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3763 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3764 num_conti=num_cont_hb(i)
3766 do j=ielstart(i),ielend(i)
3768 C write (iout,*) i,j
3770 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3771 C changes suggested by Ana to avoid out of bounds
3772 c & .or.((j+2).gt.nres)
3773 c & .or.((j-1).le.0)
3774 C end of changes by Ana
3775 c & .or.itype(j+2).eq.ntyp1
3776 c & .or.itype(j-1).eq.ntyp1
3778 call eelecij(i,j,ees,evdw1,eel_loc)
3780 num_cont_hb(i)=num_conti
3786 c write (iout,*) "Number of loop steps in EELEC:",ind
3788 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3789 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3791 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3792 ccc eel_loc=eel_loc+eello_turn3
3793 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3796 C-------------------------------------------------------------------------------
3797 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3798 implicit real*8 (a-h,o-z)
3799 include 'DIMENSIONS'
3803 include 'COMMON.CONTROL'
3804 include 'COMMON.IOUNITS'
3805 include 'COMMON.GEO'
3806 include 'COMMON.VAR'
3807 include 'COMMON.LOCAL'
3808 include 'COMMON.CHAIN'
3809 include 'COMMON.DERIV'
3810 include 'COMMON.INTERACT'
3811 include 'COMMON.CONTACTS'
3812 include 'COMMON.TORSION'
3813 include 'COMMON.VECTORS'
3814 include 'COMMON.FFIELD'
3815 include 'COMMON.TIME1'
3816 include 'COMMON.SPLITELE'
3817 include 'COMMON.SHIELD'
3818 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3819 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3820 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3821 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3822 & gmuij2(4),gmuji2(4)
3823 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3824 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3826 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3828 double precision scal_el /1.0d0/
3830 double precision scal_el /0.5d0/
3833 C 13-go grudnia roku pamietnego...
3834 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3835 & 0.0d0,1.0d0,0.0d0,
3836 & 0.0d0,0.0d0,1.0d0/
3837 integer xshift,yshift,zshift
3838 c time00=MPI_Wtime()
3839 cd write (iout,*) "eelecij",i,j
3843 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3844 aaa=app(iteli,itelj)
3845 bbb=bpp(iteli,itelj)
3846 ael6i=ael6(iteli,itelj)
3847 ael3i=ael3(iteli,itelj)
3851 dx_normj=dc_norm(1,j)
3852 dy_normj=dc_norm(2,j)
3853 dz_normj=dc_norm(3,j)
3854 C xj=c(1,j)+0.5D0*dxj-xmedi
3855 C yj=c(2,j)+0.5D0*dyj-ymedi
3856 C zj=c(3,j)+0.5D0*dzj-zmedi
3861 if (xj.lt.0) xj=xj+boxxsize
3863 if (yj.lt.0) yj=yj+boxysize
3865 if (zj.lt.0) zj=zj+boxzsize
3866 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3867 if ((zj.gt.bordlipbot)
3868 &.and.(zj.lt.bordliptop)) then
3869 C the energy transfer exist
3870 if (zj.lt.buflipbot) then
3871 C what fraction I am in
3873 & ((zj-bordlipbot)/lipbufthick)
3874 C lipbufthick is thickenes of lipid buffore
3875 sslipj=sscalelip(fracinbuf)
3876 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3877 elseif (zj.gt.bufliptop) then
3878 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3879 sslipj=sscalelip(fracinbuf)
3880 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3889 dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3897 xj=xj_safe+xshift*boxxsize
3898 yj=yj_safe+yshift*boxysize
3899 zj=zj_safe+zshift*boxzsize
3900 dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3901 if(dist_temp.lt.dist_init) then
3911 if (isubchap.eq.1) then
3920 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3922 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3923 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3924 C Condition for being inside the proper box
3925 c if ((xj.gt.((0.5d0)*boxxsize)).or.
3926 c & (xj.lt.((-0.5d0)*boxxsize))) then
3930 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3931 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3932 C Condition for being inside the proper box
3933 c if ((yj.gt.((0.5d0)*boxysize)).or.
3934 c & (yj.lt.((-0.5d0)*boxysize))) then
3938 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3939 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3940 C Condition for being inside the proper box
3941 c if ((zj.gt.((0.5d0)*boxzsize)).or.
3942 c & (zj.lt.((-0.5d0)*boxzsize))) then
3945 C endif !endPBC condintion
3949 rij=xj*xj+yj*yj+zj*zj
3951 sss=sscale(sqrt(rij))
3952 sssgrad=sscagrad(sqrt(rij))
3953 c if (sss.gt.0.0d0) then
3959 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3960 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3961 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3962 fac=cosa-3.0D0*cosb*cosg
3964 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3965 if (j.eq.i+2) ev1=scal_el*ev1
3970 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3974 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3975 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3976 if (shield_mode.gt.0) then
3979 el1=el1*fac_shield(i)**2*fac_shield(j)**2
3980 el2=el2*fac_shield(i)**2*fac_shield(j)**2
3983 C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3984 C & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3990 &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3991 C print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3993 evdw1=evdw1+evdwij*sss
3994 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3995 C print *,sslipi,sslipj,lipscale**2,
3996 C & (sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3997 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3998 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3999 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
4000 cd & xmedi,ymedi,zmedi,xj,yj,zj
4002 if (energy_dec) then
4003 write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
4005 &,iteli,itelj,aaa,evdw1
4007 write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
4008 &fac_shield(i),fac_shield(j)
4012 C Calculate contributions to the Cartesian gradient.
4015 facvdw=-6*rrmij*(ev1+evdwij)*sss
4016 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4017 facel=-3*rrmij*(el1+eesij)
4018 &*((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4025 * Radial derivatives. First process both termini of the fragment (i,j)
4030 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4031 & (shield_mode.gt.0)) then
4033 do ilist=1,ishield_list(i)
4034 iresshield=shield_list(ilist,i)
4036 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4038 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4040 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4041 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4042 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4043 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4044 C if (iresshield.gt.i) then
4045 C do ishi=i+1,iresshield-1
4046 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4047 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4051 C do ishi=iresshield,i
4052 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4053 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4059 do ilist=1,ishield_list(j)
4060 iresshield=shield_list(ilist,j)
4062 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4064 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4066 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4067 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4069 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4070 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4071 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4072 C if (iresshield.gt.j) then
4073 C do ishi=j+1,iresshield-1
4074 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4075 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4079 C do ishi=iresshield,j
4080 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4081 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4088 gshieldc(k,i)=gshieldc(k,i)+
4089 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4090 gshieldc(k,j)=gshieldc(k,j)+
4091 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4092 gshieldc(k,i-1)=gshieldc(k,i-1)+
4093 & grad_shield(k,i)*eesij/fac_shield(i)*2.0
4094 gshieldc(k,j-1)=gshieldc(k,j-1)+
4095 & grad_shield(k,j)*eesij/fac_shield(j)*2.0
4100 c ghalf=0.5D0*ggg(k)
4101 c gelc(k,i)=gelc(k,i)+ghalf
4102 c gelc(k,j)=gelc(k,j)+ghalf
4104 c 9/28/08 AL Gradient compotents will be summed only at the end
4105 C print *,"before", gelc_long(1,i), gelc_long(1,j)
4107 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4108 C & +grad_shield(k,j)*eesij/fac_shield(j)
4109 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4110 C & +grad_shield(k,i)*eesij/fac_shield(i)
4111 C gelc_long(k,i-1)=gelc_long(k,i-1)
4112 C & +grad_shield(k,i)*eesij/fac_shield(i)
4113 C gelc_long(k,j-1)=gelc_long(k,j-1)
4114 C & +grad_shield(k,j)*eesij/fac_shield(j)
4116 C print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4117 C Lipidic part for lipscale
4118 gelc_long(3,j)=gelc_long(3,j)+
4119 & ssgradlipj*eesij/2.0d0*lipscale**2
4121 gelc_long(3,i)=gelc_long(3,i)+
4122 & ssgradlipi*eesij/2.0d0*lipscale**2
4125 * Loop over residues i+1 thru j-1.
4129 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4132 if (sss.gt.0.0) then
4133 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4134 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4136 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4137 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4139 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4140 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4147 c ghalf=0.5D0*ggg(k)
4148 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4149 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4151 c 9/28/08 AL Gradient compotents will be summed only at the end
4153 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4154 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4156 C Lipidic part for scaling weight
4157 gvdwpp(3,j)=gvdwpp(3,j)+
4158 & sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4159 gvdwpp(3,i)=gvdwpp(3,i)+
4160 & sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4163 * Loop over residues i+1 thru j-1.
4167 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4172 facvdw=(ev1+evdwij)*sss
4173 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4176 fac=-3*rrmij*(facvdw+facvdw+facel)
4181 * Radial derivatives. First process both termini of the fragment (i,j)
4184 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4186 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4188 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4190 c ghalf=0.5D0*ggg(k)
4191 c gelc(k,i)=gelc(k,i)+ghalf
4192 c gelc(k,j)=gelc(k,j)+ghalf
4194 c 9/28/08 AL Gradient compotents will be summed only at the end
4196 gelc_long(k,j)=gelc(k,j)+ggg(k)
4197 gelc_long(k,i)=gelc(k,i)-ggg(k)
4200 * Loop over residues i+1 thru j-1.
4204 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4207 c 9/28/08 AL Gradient compotents will be summed only at the end
4208 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4209 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4211 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4212 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4214 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4215 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4217 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4218 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4220 gvdwpp(3,j)=gvdwpp(3,j)+
4221 & sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4222 gvdwpp(3,i)=gvdwpp(3,i)+
4223 & sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4229 ecosa=2.0D0*fac3*fac1+fac4
4232 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4233 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4235 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4236 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4238 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4239 cd & (dcosg(k),k=1,3)
4241 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4242 & fac_shield(i)**2*fac_shield(j)**2
4243 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4246 c ghalf=0.5D0*ggg(k)
4247 c gelc(k,i)=gelc(k,i)+ghalf
4248 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4249 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4250 c gelc(k,j)=gelc(k,j)+ghalf
4251 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4252 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4256 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4259 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4262 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4263 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4264 & *fac_shield(i)**2*fac_shield(j)**2
4265 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4267 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4268 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4269 & *fac_shield(i)**2*fac_shield(j)**2
4270 & *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4271 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4272 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4274 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4278 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4279 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4280 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4282 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4283 C energy of a peptide unit is assumed in the form of a second-order
4284 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4285 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4286 C are computed for EVERY pair of non-contiguous peptide groups.
4289 if (j.lt.nres-1) then
4301 muij(kkk)=mu(k,i)*mu(l,j)
4302 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4304 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4305 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4306 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4307 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4308 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4309 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4313 cd write (iout,*) 'EELEC: i',i,' j',j
4314 cd write (iout,*) 'j',j,' j1',j1,' j2',j2
4315 cd write(iout,*) 'muij',muij
4316 ury=scalar(uy(1,i),erij)
4317 urz=scalar(uz(1,i),erij)
4318 vry=scalar(uy(1,j),erij)
4319 vrz=scalar(uz(1,j),erij)
4320 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4321 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4322 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4323 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4324 fac=dsqrt(-ael6i)*r3ij
4329 cd write (iout,'(4i5,4f10.5)')
4330 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4331 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4332 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4333 cd & uy(:,j),uz(:,j)
4334 cd write (iout,'(4f10.5)')
4335 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4336 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4337 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4338 cd write (iout,'(9f10.5/)')
4339 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4340 C Derivatives of the elements of A in virtual-bond vectors
4341 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4343 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4344 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4345 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4346 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4347 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4348 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4349 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4350 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4351 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4352 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4353 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4354 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4356 C Compute radial contributions to the gradient
4374 C Add the contributions coming from er
4377 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4378 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4379 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4380 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4383 C Derivatives in DC(i)
4384 cgrad ghalf1=0.5d0*agg(k,1)
4385 cgrad ghalf2=0.5d0*agg(k,2)
4386 cgrad ghalf3=0.5d0*agg(k,3)
4387 cgrad ghalf4=0.5d0*agg(k,4)
4388 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4389 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4390 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4391 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4392 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4393 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4394 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4395 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4396 C Derivatives in DC(i+1)
4397 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4398 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4399 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4400 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4401 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4402 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4403 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4404 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4405 C Derivatives in DC(j)
4406 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4407 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4408 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4409 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4410 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4411 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4412 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4413 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4414 C Derivatives in DC(j+1) or DC(nres-1)
4415 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4416 & -3.0d0*vryg(k,3)*ury)
4417 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4418 & -3.0d0*vrzg(k,3)*ury)
4419 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4420 & -3.0d0*vryg(k,3)*urz)
4421 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4422 & -3.0d0*vrzg(k,3)*urz)
4423 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4425 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4438 aggi(k,l)=-aggi(k,l)
4439 aggi1(k,l)=-aggi1(k,l)
4440 aggj(k,l)=-aggj(k,l)
4441 aggj1(k,l)=-aggj1(k,l)
4444 if (j.lt.nres-1) then
4450 aggi(k,l)=-aggi(k,l)
4451 aggi1(k,l)=-aggi1(k,l)
4452 aggj(k,l)=-aggj(k,l)
4453 aggj1(k,l)=-aggj1(k,l)
4464 aggi(k,l)=-aggi(k,l)
4465 aggi1(k,l)=-aggi1(k,l)
4466 aggj(k,l)=-aggj(k,l)
4467 aggj1(k,l)=-aggj1(k,l)
4472 IF (wel_loc.gt.0.0d0) THEN
4473 C Contribution to the local-electrostatic energy coming from the i-j pair
4474 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4476 if (shield_mode.eq.0) then
4483 eel_loc_ij=eel_loc_ij
4484 & *fac_shield(i)*fac_shield(j)
4485 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4487 C Now derivative over eel_loc
4488 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4489 & (shield_mode.gt.0)) then
4492 do ilist=1,ishield_list(i)
4493 iresshield=shield_list(ilist,i)
4495 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4498 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4500 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4501 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4505 do ilist=1,ishield_list(j)
4506 iresshield=shield_list(ilist,j)
4508 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4511 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4513 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4514 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4521 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4522 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4523 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4524 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4525 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4526 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4527 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4528 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4533 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4534 c & ' eel_loc_ij',eel_loc_ij
4535 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4536 C Calculate patrial derivative for theta angle
4538 geel_loc_ij=(a22*gmuij1(1)
4542 & *fac_shield(i)*fac_shield(j)
4543 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4545 c write(iout,*) "derivative over thatai"
4546 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4548 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4549 & geel_loc_ij*wel_loc
4550 c write(iout,*) "derivative over thatai-1"
4551 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4558 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4559 & geel_loc_ij*wel_loc
4560 & *fac_shield(i)*fac_shield(j)
4561 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4564 c Derivative over j residue
4565 geel_loc_ji=a22*gmuji1(1)
4569 c write(iout,*) "derivative over thataj"
4570 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4573 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4574 & geel_loc_ji*wel_loc
4575 & *fac_shield(i)*fac_shield(j)
4576 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4583 c write(iout,*) "derivative over thataj-1"
4584 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4586 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4587 & geel_loc_ji*wel_loc
4588 & *fac_shield(i)*fac_shield(j)
4589 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4592 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4594 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4595 & 'eelloc',i,j,eel_loc_ij
4596 c if (eel_loc_ij.ne.0)
4597 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4598 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4600 eel_loc=eel_loc+eel_loc_ij
4601 C Partial derivatives in virtual-bond dihedral angles gamma
4603 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4604 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4605 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4606 & *fac_shield(i)*fac_shield(j)
4607 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4609 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4610 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4611 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4612 & *fac_shield(i)*fac_shield(j)
4613 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4615 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4617 ggg(l)=(agg(l,1)*muij(1)+
4618 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4619 & *fac_shield(i)*fac_shield(j)
4620 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4622 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4623 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4624 cgrad ghalf=0.5d0*ggg(l)
4625 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4626 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4628 gel_loc_long(3,j)=gel_loc_long(3,j)+
4629 & ssgradlipj*eel_loc_ij/2.0d0*lipscale/
4630 & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4632 gel_loc_long(3,i)=gel_loc_long(3,i)+
4633 & ssgradlipi*eel_loc_ij/2.0d0*lipscale/
4634 & ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4638 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4641 C Remaining derivatives of eello
4643 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4644 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4645 & *fac_shield(i)*fac_shield(j)
4646 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4648 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4649 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4650 & *fac_shield(i)*fac_shield(j)
4651 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4653 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4654 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4655 & *fac_shield(i)*fac_shield(j)
4656 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4658 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4659 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4660 & *fac_shield(i)*fac_shield(j)
4661 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4665 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4666 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4667 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4668 & .and. num_conti.le.maxconts) then
4669 c write (iout,*) i,j," entered corr"
4671 C Calculate the contact function. The ith column of the array JCONT will
4672 C contain the numbers of atoms that make contacts with the atom I (of numbers
4673 C greater than I). The arrays FACONT and GACONT will contain the values of
4674 C the contact function and its derivative.
4675 c r0ij=1.02D0*rpp(iteli,itelj)
4676 c r0ij=1.11D0*rpp(iteli,itelj)
4677 r0ij=2.20D0*rpp(iteli,itelj)
4678 c r0ij=1.55D0*rpp(iteli,itelj)
4679 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4680 if (fcont.gt.0.0D0) then
4681 num_conti=num_conti+1
4682 if (num_conti.gt.maxconts) then
4683 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4684 & ' will skip next contacts for this conf.'
4686 jcont_hb(num_conti,i)=j
4687 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4688 cd & " jcont_hb",jcont_hb(num_conti,i)
4689 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4690 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4691 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4693 d_cont(num_conti,i)=rij
4694 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4695 C --- Electrostatic-interaction matrix ---
4696 a_chuj(1,1,num_conti,i)=a22
4697 a_chuj(1,2,num_conti,i)=a23
4698 a_chuj(2,1,num_conti,i)=a32
4699 a_chuj(2,2,num_conti,i)=a33
4700 C --- Gradient of rij
4702 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4709 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4710 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4711 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4712 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4713 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4718 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4719 C Calculate contact energies
4721 wij=cosa-3.0D0*cosb*cosg
4724 c fac3=dsqrt(-ael6i)/r0ij**3
4725 fac3=dsqrt(-ael6i)*r3ij
4726 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4727 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4728 if (ees0tmp.gt.0) then
4729 ees0pij=dsqrt(ees0tmp)
4733 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4734 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4735 if (ees0tmp.gt.0) then
4736 ees0mij=dsqrt(ees0tmp)
4741 if (shield_mode.eq.0) then
4745 ees0plist(num_conti,i)=j
4746 C fac_shield(i)=0.4d0
4747 C fac_shield(j)=0.6d0
4749 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4750 & *fac_shield(i)*fac_shield(j)
4751 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4752 & *fac_shield(i)*fac_shield(j)
4753 C Diagnostics. Comment out or remove after debugging!
4754 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4755 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4756 c ees0m(num_conti,i)=0.0D0
4758 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4759 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4760 C Angular derivatives of the contact function
4761 ees0pij1=fac3/ees0pij
4762 ees0mij1=fac3/ees0mij
4763 fac3p=-3.0D0*fac3*rrmij
4764 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4765 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4767 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4768 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4769 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4770 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4771 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4772 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4773 ecosap=ecosa1+ecosa2
4774 ecosbp=ecosb1+ecosb2
4775 ecosgp=ecosg1+ecosg2
4776 ecosam=ecosa1-ecosa2
4777 ecosbm=ecosb1-ecosb2
4778 ecosgm=ecosg1-ecosg2
4787 facont_hb(num_conti,i)=fcont
4788 fprimcont=fprimcont/rij
4789 cd facont_hb(num_conti,i)=1.0D0
4790 C Following line is for diagnostics.
4793 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4794 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4797 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4798 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4800 gggp(1)=gggp(1)+ees0pijp*xj
4801 gggp(2)=gggp(2)+ees0pijp*yj
4802 gggp(3)=gggp(3)+ees0pijp*zj
4803 gggm(1)=gggm(1)+ees0mijp*xj
4804 gggm(2)=gggm(2)+ees0mijp*yj
4805 gggm(3)=gggm(3)+ees0mijp*zj
4806 C Derivatives due to the contact function
4807 gacont_hbr(1,num_conti,i)=fprimcont*xj
4808 gacont_hbr(2,num_conti,i)=fprimcont*yj
4809 gacont_hbr(3,num_conti,i)=fprimcont*zj
4812 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4813 c following the change of gradient-summation algorithm.
4815 cgrad ghalfp=0.5D0*gggp(k)
4816 cgrad ghalfm=0.5D0*gggm(k)
4817 gacontp_hb1(k,num_conti,i)=!ghalfp
4818 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4819 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4820 & *fac_shield(i)*fac_shield(j)
4822 gacontp_hb2(k,num_conti,i)=!ghalfp
4823 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4824 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4825 & *fac_shield(i)*fac_shield(j)
4827 gacontp_hb3(k,num_conti,i)=gggp(k)
4828 & *fac_shield(i)*fac_shield(j)
4830 gacontm_hb1(k,num_conti,i)=!ghalfm
4831 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4832 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4833 & *fac_shield(i)*fac_shield(j)
4835 gacontm_hb2(k,num_conti,i)=!ghalfm
4836 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4837 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4838 & *fac_shield(i)*fac_shield(j)
4840 gacontm_hb3(k,num_conti,i)=gggm(k)
4841 & *fac_shield(i)*fac_shield(j)
4844 C Diagnostics. Comment out or remove after debugging!
4846 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4847 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4848 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4849 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4850 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4851 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4854 endif ! num_conti.le.maxconts
4857 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4860 ghalf=0.5d0*agg(l,k)
4861 aggi(l,k)=aggi(l,k)+ghalf
4862 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4863 aggj(l,k)=aggj(l,k)+ghalf
4866 if (j.eq.nres-1 .and. i.lt.j-2) then
4869 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4874 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4877 C-----------------------------------------------------------------------------
4878 subroutine eturn3(i,eello_turn3)
4879 C Third- and fourth-order contributions from turns
4880 implicit real*8 (a-h,o-z)
4881 include 'DIMENSIONS'
4882 include 'COMMON.IOUNITS'
4883 include 'COMMON.GEO'
4884 include 'COMMON.VAR'
4885 include 'COMMON.LOCAL'
4886 include 'COMMON.CHAIN'
4887 include 'COMMON.DERIV'
4888 include 'COMMON.INTERACT'
4889 include 'COMMON.CONTACTS'
4890 include 'COMMON.TORSION'
4891 include 'COMMON.VECTORS'
4892 include 'COMMON.FFIELD'
4893 include 'COMMON.CONTROL'
4894 include 'COMMON.SHIELD'
4896 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4897 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4898 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4899 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4900 & auxgmat2(2,2),auxgmatt2(2,2)
4901 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4902 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4903 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4904 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4907 C xj=(c(1,j)+c(1,j+1))/2.0d0
4908 C yj=(c(2,j)+c(2,j+1))/2.0d0
4909 zj=(c(3,j)+c(3,j+1))/2.0d0
4910 C xj=mod(xj,boxxsize)
4911 C if (xj.lt.0) xj=xj+boxxsize
4912 C yj=mod(yj,boxysize)
4913 C if (yj.lt.0) yj=yj+boxysize
4915 if (zj.lt.0) zj=zj+boxzsize
4916 if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
4917 if ((zj.gt.bordlipbot)
4918 &.and.(zj.lt.bordliptop)) then
4919 C the energy transfer exist
4920 if (zj.lt.buflipbot) then
4921 C what fraction I am in
4923 & ((zj-bordlipbot)/lipbufthick)
4924 C lipbufthick is thickenes of lipid buffore
4925 sslipj=sscalelip(fracinbuf)
4926 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4927 elseif (zj.gt.bufliptop) then
4928 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4929 sslipj=sscalelip(fracinbuf)
4930 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4942 C write (iout,*) "eturn3",i,j,j1,j2
4947 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4949 C Third-order contributions
4956 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4957 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4958 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4959 c auxalary matices for theta gradient
4960 c auxalary matrix for i+1 and constant i+2
4961 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4962 c auxalary matrix for i+2 and constant i+1
4963 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4964 call transpose2(auxmat(1,1),auxmat1(1,1))
4965 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4966 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4967 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4968 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4969 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4970 if (shield_mode.eq.0) then
4978 C & write(iout,*) i,j,fac_shield(i),fac_shield(j)
4979 eello_turn3=eello_turn3+
4980 C & 1.0*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4981 &0.5d0*(pizda(1,1)+pizda(2,2))
4982 & *fac_shield(i)*fac_shield(j)
4983 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4985 &0.5d0*(pizda(1,1)+pizda(2,2))
4986 & *fac_shield(i)*fac_shield(j)
4988 C Derivatives in theta
4989 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4990 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4991 & *fac_shield(i)*fac_shield(j)
4992 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4994 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4995 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4996 & *fac_shield(i)*fac_shield(j)
4997 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5001 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5002 C Derivatives in shield mode
5003 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5004 & (shield_mode.gt.0)) then
5007 do ilist=1,ishield_list(i)
5008 iresshield=shield_list(ilist,i)
5010 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
5012 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5014 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
5015 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5019 do ilist=1,ishield_list(j)
5020 iresshield=shield_list(ilist,j)
5022 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
5024 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
5026 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
5027 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
5034 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
5035 & grad_shield(k,i)*eello_t3/fac_shield(i)
5036 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
5037 & grad_shield(k,j)*eello_t3/fac_shield(j)
5038 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
5039 & grad_shield(k,i)*eello_t3/fac_shield(i)
5040 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
5041 & grad_shield(k,j)*eello_t3/fac_shield(j)
5045 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5046 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
5047 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
5048 cd & ' eello_turn3_num',4*eello_turn3_num
5049 C Derivatives in gamma(i)
5050 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
5051 call transpose2(auxmat2(1,1),auxmat3(1,1))
5052 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5053 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
5054 & *fac_shield(i)*fac_shield(j)
5055 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5057 C Derivatives in gamma(i+1)
5058 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
5059 call transpose2(auxmat2(1,1),auxmat3(1,1))
5060 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
5061 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
5062 & +0.5d0*(pizda(1,1)+pizda(2,2))
5063 & *fac_shield(i)*fac_shield(j)
5064 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5066 C Cartesian derivatives
5068 c ghalf1=0.5d0*agg(l,1)
5069 c ghalf2=0.5d0*agg(l,2)
5070 c ghalf3=0.5d0*agg(l,3)
5071 c ghalf4=0.5d0*agg(l,4)
5072 a_temp(1,1)=aggi(l,1)!+ghalf1
5073 a_temp(1,2)=aggi(l,2)!+ghalf2
5074 a_temp(2,1)=aggi(l,3)!+ghalf3
5075 a_temp(2,2)=aggi(l,4)!+ghalf4
5076 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5077 gcorr3_turn(l,i)=gcorr3_turn(l,i)
5078 & +0.5d0*(pizda(1,1)+pizda(2,2))
5079 & *fac_shield(i)*fac_shield(j)
5080 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5082 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
5083 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
5084 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
5085 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
5086 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5087 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
5088 & +0.5d0*(pizda(1,1)+pizda(2,2))
5089 & *fac_shield(i)*fac_shield(j)
5090 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5091 a_temp(1,1)=aggj(l,1)!+ghalf1
5092 a_temp(1,2)=aggj(l,2)!+ghalf2
5093 a_temp(2,1)=aggj(l,3)!+ghalf3
5094 a_temp(2,2)=aggj(l,4)!+ghalf4
5095 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5096 gcorr3_turn(l,j)=gcorr3_turn(l,j)
5097 & +0.5d0*(pizda(1,1)+pizda(2,2))
5098 & *fac_shield(i)*fac_shield(j)
5099 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5101 a_temp(1,1)=aggj1(l,1)
5102 a_temp(1,2)=aggj1(l,2)
5103 a_temp(2,1)=aggj1(l,3)
5104 a_temp(2,2)=aggj1(l,4)
5105 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5106 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5107 & +0.5d0*(pizda(1,1)+pizda(2,2))
5108 & *fac_shield(i)*fac_shield(j)
5109 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5111 gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5112 & ssgradlipi*eello_t3/4.0d0*lipscale
5113 gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5114 & ssgradlipj*eello_t3/4.0d0*lipscale
5115 gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5116 & ssgradlipi*eello_t3/4.0d0*lipscale
5117 gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5118 & ssgradlipj*eello_t3/4.0d0*lipscale
5120 C print *,ssgradlipi,ssgradlipj,eello_t3,sslipi,sslipj
5123 C-------------------------------------------------------------------------------
5124 subroutine eturn4(i,eello_turn4)
5125 C Third- and fourth-order contributions from turns
5126 implicit real*8 (a-h,o-z)
5127 include 'DIMENSIONS'
5128 include 'COMMON.IOUNITS'
5129 include 'COMMON.GEO'
5130 include 'COMMON.VAR'
5131 include 'COMMON.LOCAL'
5132 include 'COMMON.CHAIN'
5133 include 'COMMON.DERIV'
5134 include 'COMMON.INTERACT'
5135 include 'COMMON.CONTACTS'
5136 include 'COMMON.TORSION'
5137 include 'COMMON.VECTORS'
5138 include 'COMMON.FFIELD'
5139 include 'COMMON.CONTROL'
5140 include 'COMMON.SHIELD'
5142 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5143 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5144 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5145 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5146 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
5147 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5148 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5149 double precision agg(3,4),aggi(3,4),aggi1(3,4),
5150 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5151 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5152 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5155 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5157 C Fourth-order contributions
5165 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5166 cd call checkint_turn4(i,a_temp,eello_turn4_num)
5167 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5168 c write(iout,*)"WCHODZE W PROGRAM"
5169 zj=(c(3,j)+c(3,j+1))/2.0d0
5170 C xj=mod(xj,boxxsize)
5171 C if (xj.lt.0) xj=xj+boxxsize
5172 C yj=mod(yj,boxysize)
5173 C if (yj.lt.0) yj=yj+boxysize
5175 if (zj.lt.0) zj=zj+boxzsize
5176 C if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
5177 if ((zj.gt.bordlipbot)
5178 &.and.(zj.lt.bordliptop)) then
5179 C the energy transfer exist
5180 if (zj.lt.buflipbot) then
5181 C what fraction I am in
5183 & ((zj-bordlipbot)/lipbufthick)
5184 C lipbufthick is thickenes of lipid buffore
5185 sslipj=sscalelip(fracinbuf)
5186 ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
5187 elseif (zj.gt.bufliptop) then
5188 fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
5189 sslipj=sscalelip(fracinbuf)
5190 ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
5204 iti1=itype2loc(itype(i+1))
5205 iti2=itype2loc(itype(i+2))
5206 iti3=itype2loc(itype(i+3))
5207 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5208 call transpose2(EUg(1,1,i+1),e1t(1,1))
5209 call transpose2(Eug(1,1,i+2),e2t(1,1))
5210 call transpose2(Eug(1,1,i+3),e3t(1,1))
5211 C Ematrix derivative in theta
5212 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5213 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5214 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5215 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5216 c eta1 in derivative theta
5217 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5218 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5219 c auxgvec is derivative of Ub2 so i+3 theta
5220 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5221 c auxalary matrix of E i+1
5222 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5225 s1=scalar2(b1(1,i+2),auxvec(1))
5226 c derivative of theta i+2 with constant i+3
5227 gs23=scalar2(gtb1(1,i+2),auxvec(1))
5228 c derivative of theta i+2 with constant i+2
5229 gs32=scalar2(b1(1,i+2),auxgvec(1))
5230 c derivative of E matix in theta of i+1
5231 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5233 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5234 c ea31 in derivative theta
5235 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5236 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5237 c auxilary matrix auxgvec of Ub2 with constant E matirx
5238 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5239 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5240 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5244 s2=scalar2(b1(1,i+1),auxvec(1))
5245 c derivative of theta i+1 with constant i+3
5246 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5247 c derivative of theta i+2 with constant i+1
5248 gs21=scalar2(b1(1,i+1),auxgvec(1))
5249 c derivative of theta i+3 with constant i+1
5250 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5251 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5253 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5254 c two derivatives over diffetent matrices
5255 c gtae3e2 is derivative over i+3
5256 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5257 c ae3gte2 is derivative over i+2
5258 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5259 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5260 c three possible derivative over theta E matices
5262 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5264 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5266 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5267 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5269 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5270 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5271 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5272 if (shield_mode.eq.0) then
5279 eello_turn4=eello_turn4-(s1+s2+s3)
5280 & *fac_shield(i)*fac_shield(j)
5281 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5283 eello_t4=-(s1+s2+s3)
5284 & *fac_shield(i)*fac_shield(j)
5285 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5286 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5287 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5288 C Now derivative over shield:
5289 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5290 & (shield_mode.gt.0)) then
5293 do ilist=1,ishield_list(i)
5294 iresshield=shield_list(ilist,i)
5296 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5298 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5300 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5301 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5305 do ilist=1,ishield_list(j)
5306 iresshield=shield_list(ilist,j)
5308 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5310 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5312 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5313 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5320 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5321 & grad_shield(k,i)*eello_t4/fac_shield(i)
5322 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5323 & grad_shield(k,j)*eello_t4/fac_shield(j)
5324 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5325 & grad_shield(k,i)*eello_t4/fac_shield(i)
5326 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5327 & grad_shield(k,j)*eello_t4/fac_shield(j)
5336 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5337 cd & ' eello_turn4_num',8*eello_turn4_num
5339 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5340 & -(gs13+gsE13+gsEE1)*wturn4
5341 & *fac_shield(i)*fac_shield(j)
5342 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5344 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5345 & -(gs23+gs21+gsEE2)*wturn4
5346 & *fac_shield(i)*fac_shield(j)
5347 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5349 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5350 & -(gs32+gsE31+gsEE3)*wturn4
5351 & *fac_shield(i)*fac_shield(j)
5352 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5354 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5357 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5358 & 'eturn4',i,j,-(s1+s2+s3)
5359 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5360 c & ' eello_turn4_num',8*eello_turn4_num
5361 C Derivatives in gamma(i)
5362 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5363 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5364 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5365 s1=scalar2(b1(1,i+2),auxvec(1))
5366 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5367 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5368 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5369 & *fac_shield(i)*fac_shield(j)
5370 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5372 C Derivatives in gamma(i+1)
5373 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5374 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5375 s2=scalar2(b1(1,i+1),auxvec(1))
5376 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5377 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5378 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5379 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5380 & *fac_shield(i)*fac_shield(j)
5381 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5383 C Derivatives in gamma(i+2)
5384 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5385 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5386 s1=scalar2(b1(1,i+2),auxvec(1))
5387 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5388 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5389 s2=scalar2(b1(1,i+1),auxvec(1))
5390 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5391 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5392 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5393 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5394 & *fac_shield(i)*fac_shield(j)
5395 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5397 C Cartesian derivatives
5398 C Derivatives of this turn contributions in DC(i+2)
5399 if (j.lt.nres-1) then
5401 a_temp(1,1)=agg(l,1)
5402 a_temp(1,2)=agg(l,2)
5403 a_temp(2,1)=agg(l,3)
5404 a_temp(2,2)=agg(l,4)
5405 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5406 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5407 s1=scalar2(b1(1,i+2),auxvec(1))
5408 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5409 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5410 s2=scalar2(b1(1,i+1),auxvec(1))
5411 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5412 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5413 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5415 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5416 & *fac_shield(i)*fac_shield(j)
5417 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5421 C Remaining derivatives of this turn contribution
5423 a_temp(1,1)=aggi(l,1)
5424 a_temp(1,2)=aggi(l,2)
5425 a_temp(2,1)=aggi(l,3)
5426 a_temp(2,2)=aggi(l,4)
5427 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5428 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5429 s1=scalar2(b1(1,i+2),auxvec(1))
5430 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5431 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5432 s2=scalar2(b1(1,i+1),auxvec(1))
5433 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5434 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5435 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5436 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5437 & *fac_shield(i)*fac_shield(j)
5438 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5440 a_temp(1,1)=aggi1(l,1)
5441 a_temp(1,2)=aggi1(l,2)
5442 a_temp(2,1)=aggi1(l,3)
5443 a_temp(2,2)=aggi1(l,4)
5444 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5445 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5446 s1=scalar2(b1(1,i+2),auxvec(1))
5447 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5448 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5449 s2=scalar2(b1(1,i+1),auxvec(1))
5450 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5451 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5452 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5453 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5454 & *fac_shield(i)*fac_shield(j)
5455 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5457 a_temp(1,1)=aggj(l,1)
5458 a_temp(1,2)=aggj(l,2)
5459 a_temp(2,1)=aggj(l,3)
5460 a_temp(2,2)=aggj(l,4)
5461 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5462 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5463 s1=scalar2(b1(1,i+2),auxvec(1))
5464 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5465 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5466 s2=scalar2(b1(1,i+1),auxvec(1))
5467 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5468 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5469 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5470 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5471 & *fac_shield(i)*fac_shield(j)
5472 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5474 a_temp(1,1)=aggj1(l,1)
5475 a_temp(1,2)=aggj1(l,2)
5476 a_temp(2,1)=aggj1(l,3)
5477 a_temp(2,2)=aggj1(l,4)
5478 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5479 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5480 s1=scalar2(b1(1,i+2),auxvec(1))
5481 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5482 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5483 s2=scalar2(b1(1,i+1),auxvec(1))
5484 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5485 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5486 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5487 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5488 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5489 & *fac_shield(i)*fac_shield(j)
5490 &*((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5492 gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5493 & ssgradlipi*eello_t4/4.0d0*lipscale
5494 gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5495 & ssgradlipj*eello_t4/4.0d0*lipscale
5496 gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5497 & ssgradlipi*eello_t4/4.0d0*lipscale
5498 gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5499 & ssgradlipj*eello_t4/4.0d0*lipscale
5502 C-----------------------------------------------------------------------------
5503 subroutine vecpr(u,v,w)
5504 implicit real*8(a-h,o-z)
5505 dimension u(3),v(3),w(3)
5506 w(1)=u(2)*v(3)-u(3)*v(2)
5507 w(2)=-u(1)*v(3)+u(3)*v(1)
5508 w(3)=u(1)*v(2)-u(2)*v(1)
5511 C-----------------------------------------------------------------------------
5512 subroutine unormderiv(u,ugrad,unorm,ungrad)
5513 C This subroutine computes the derivatives of a normalized vector u, given
5514 C the derivatives computed without normalization conditions, ugrad. Returns
5517 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5518 double precision vec(3)
5519 double precision scalar
5521 c write (2,*) 'ugrad',ugrad
5524 vec(i)=scalar(ugrad(1,i),u(1))
5526 c write (2,*) 'vec',vec
5529 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5532 c write (2,*) 'ungrad',ungrad
5535 C-----------------------------------------------------------------------------
5536 subroutine escp_soft_sphere(evdw2,evdw2_14)
5538 C This subroutine calculates the excluded-volume interaction energy between
5539 C peptide-group centers and side chains and its gradient in virtual-bond and
5540 C side-chain vectors.
5542 implicit real*8 (a-h,o-z)
5543 include 'DIMENSIONS'
5544 include 'COMMON.GEO'
5545 include 'COMMON.VAR'
5546 include 'COMMON.LOCAL'
5547 include 'COMMON.CHAIN'
5548 include 'COMMON.DERIV'
5549 include 'COMMON.INTERACT'
5550 include 'COMMON.FFIELD'
5551 include 'COMMON.IOUNITS'
5552 include 'COMMON.CONTROL'
5557 cd print '(a)','Enter ESCP'
5558 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5562 do i=iatscp_s,iatscp_e
5563 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5565 xi=0.5D0*(c(1,i)+c(1,i+1))
5566 yi=0.5D0*(c(2,i)+c(2,i+1))
5567 zi=0.5D0*(c(3,i)+c(3,i+1))
5568 C Return atom into box, boxxsize is size of box in x dimension
5570 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5571 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5572 C Condition for being inside the proper box
5573 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5574 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5578 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5579 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5580 C Condition for being inside the proper box
5581 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5582 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5586 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5587 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5588 cC Condition for being inside the proper box
5589 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5590 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5594 if (xi.lt.0) xi=xi+boxxsize
5596 if (yi.lt.0) yi=yi+boxysize
5598 if (zi.lt.0) zi=zi+boxzsize
5599 C xi=xi+xshift*boxxsize
5600 C yi=yi+yshift*boxysize
5601 C zi=zi+zshift*boxzsize
5602 do iint=1,nscp_gr(i)
5604 do j=iscpstart(i,iint),iscpend(i,iint)
5605 if (itype(j).eq.ntyp1) cycle
5606 itypj=iabs(itype(j))
5607 C Uncomment following three lines for SC-p interactions
5611 C Uncomment following three lines for Ca-p interactions
5616 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5617 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5618 C Condition for being inside the proper box
5619 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5620 c & (xj.lt.((-0.5d0)*boxxsize))) then
5624 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5625 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5626 cC Condition for being inside the proper box
5627 c if ((yj.gt.((0.5d0)*boxysize)).or.
5628 c & (yj.lt.((-0.5d0)*boxysize))) then
5632 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5633 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5634 C Condition for being inside the proper box
5635 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5636 c & (zj.lt.((-0.5d0)*boxzsize))) then
5639 if (xj.lt.0) xj=xj+boxxsize
5641 if (yj.lt.0) yj=yj+boxysize
5643 if (zj.lt.0) zj=zj+boxzsize
5644 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5652 xj=xj_safe+xshift*boxxsize
5653 yj=yj_safe+yshift*boxysize
5654 zj=zj_safe+zshift*boxzsize
5655 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5656 if(dist_temp.lt.dist_init) then
5666 if (subchap.eq.1) then
5679 rij=xj*xj+yj*yj+zj*zj
5683 if (rij.lt.r0ijsq) then
5684 evdwij=0.25d0*(rij-r0ijsq)**2
5692 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5697 cgrad if (j.lt.i) then
5698 cd write (iout,*) 'j<i'
5699 C Uncomment following three lines for SC-p interactions
5701 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5704 cd write (iout,*) 'j>i'
5706 cgrad ggg(k)=-ggg(k)
5707 C Uncomment following line for SC-p interactions
5708 c gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5712 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5714 cgrad kstart=min0(i+1,j)
5715 cgrad kend=max0(i-1,j-1)
5716 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5717 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5718 cgrad do k=kstart,kend
5720 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5724 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5725 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5736 C-----------------------------------------------------------------------------
5737 subroutine escp(evdw2,evdw2_14)
5739 C This subroutine calculates the excluded-volume interaction energy between
5740 C peptide-group centers and side chains and its gradient in virtual-bond and
5741 C side-chain vectors.
5743 implicit real*8 (a-h,o-z)
5744 include 'DIMENSIONS'
5745 include 'COMMON.GEO'
5746 include 'COMMON.VAR'
5747 include 'COMMON.LOCAL'
5748 include 'COMMON.CHAIN'
5749 include 'COMMON.DERIV'
5750 include 'COMMON.INTERACT'
5751 include 'COMMON.FFIELD'
5752 include 'COMMON.IOUNITS'
5753 include 'COMMON.CONTROL'
5754 include 'COMMON.SPLITELE'
5758 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5759 cd print '(a)','Enter ESCP'
5760 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5764 do i=iatscp_s,iatscp_e
5765 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5767 xi=0.5D0*(c(1,i)+c(1,i+1))
5768 yi=0.5D0*(c(2,i)+c(2,i+1))
5769 zi=0.5D0*(c(3,i)+c(3,i+1))
5771 if (xi.lt.0) xi=xi+boxxsize
5773 if (yi.lt.0) yi=yi+boxysize
5775 if (zi.lt.0) zi=zi+boxzsize
5776 c xi=xi+xshift*boxxsize
5777 c yi=yi+yshift*boxysize
5778 c zi=zi+zshift*boxzsize
5779 c print *,xi,yi,zi,'polozenie i'
5780 C Return atom into box, boxxsize is size of box in x dimension
5782 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5783 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5784 C Condition for being inside the proper box
5785 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5786 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5790 c print *,xi,boxxsize,"pierwszy"
5792 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5793 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5794 C Condition for being inside the proper box
5795 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5796 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5800 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5801 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5802 C Condition for being inside the proper box
5803 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5804 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5807 do iint=1,nscp_gr(i)
5809 do j=iscpstart(i,iint),iscpend(i,iint)
5810 itypj=iabs(itype(j))
5811 if (itypj.eq.ntyp1) cycle
5812 C Uncomment following three lines for SC-p interactions
5816 C Uncomment following three lines for Ca-p interactions
5821 if (xj.lt.0) xj=xj+boxxsize
5823 if (yj.lt.0) yj=yj+boxysize
5825 if (zj.lt.0) zj=zj+boxzsize
5827 c if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5828 c if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5829 C Condition for being inside the proper box
5830 c if ((xj.gt.((0.5d0)*boxxsize)).or.
5831 c & (xj.lt.((-0.5d0)*boxxsize))) then
5835 c if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5836 c if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5837 cC Condition for being inside the proper box
5838 c if ((yj.gt.((0.5d0)*boxysize)).or.
5839 c & (yj.lt.((-0.5d0)*boxysize))) then
5843 c if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5844 c if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5845 C Condition for being inside the proper box
5846 c if ((zj.gt.((0.5d0)*boxzsize)).or.
5847 c & (zj.lt.((-0.5d0)*boxzsize))) then
5850 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5851 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5859 xj=xj_safe+xshift*boxxsize
5860 yj=yj_safe+yshift*boxysize
5861 zj=zj_safe+zshift*boxzsize
5862 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5863 if(dist_temp.lt.dist_init) then
5873 if (subchap.eq.1) then
5882 c print *,xj,yj,zj,'polozenie j'
5883 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5885 sss=sscale(1.0d0/(dsqrt(rrij)))
5886 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5887 c if (sss.eq.0) print *,'czasem jest OK'
5888 if (sss.le.0.0d0) cycle
5889 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5891 e1=fac*fac*aad(itypj,iteli)
5892 e2=fac*bad(itypj,iteli)
5893 if (iabs(j-i) .le. 2) then
5896 evdw2_14=evdw2_14+(e1+e2)*sss
5899 evdw2=evdw2+evdwij*sss
5900 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5901 & 'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5904 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5906 fac=-(evdwij+e1)*rrij*sss
5907 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5911 cgrad if (j.lt.i) then
5912 cd write (iout,*) 'j<i'
5913 C Uncomment following three lines for SC-p interactions
5915 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5918 cd write (iout,*) 'j>i'
5920 cgrad ggg(k)=-ggg(k)
5921 C Uncomment following line for SC-p interactions
5922 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5923 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5927 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5929 cgrad kstart=min0(i+1,j)
5930 cgrad kend=max0(i-1,j-1)
5931 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5932 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5933 cgrad do k=kstart,kend
5935 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5939 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5940 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5942 c endif !endif for sscale cutoff
5952 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5953 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5954 gradx_scp(j,i)=expon*gradx_scp(j,i)
5957 C******************************************************************************
5961 C To save time the factor EXPON has been extracted from ALL components
5962 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5965 C******************************************************************************
5968 C--------------------------------------------------------------------------
5969 subroutine edis(ehpb)
5971 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5973 implicit real*8 (a-h,o-z)
5974 include 'DIMENSIONS'
5975 include 'COMMON.SBRIDGE'
5976 include 'COMMON.CHAIN'
5977 include 'COMMON.DERIV'
5978 include 'COMMON.VAR'
5979 include 'COMMON.INTERACT'
5980 include 'COMMON.IOUNITS'
5981 include 'COMMON.CONTROL'
5987 C write (iout,*) ,"link_end",link_end,constr_dist
5988 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5989 cd write(iout,*)'link_start=',link_start,' link_end=',link_end
5990 if (link_end.eq.0) return
5991 do i=link_start,link_end
5992 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5993 C CA-CA distance used in regularization of structure.
5996 C iii and jjj point to the residues for which the distance is assigned.
5997 if (ii.gt.nres) then
6004 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
6005 c & dhpb(i),dhpb1(i),forcon(i)
6006 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
6007 C distance and angle dependent SS bond potential.
6008 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6009 C & iabs(itype(jjj)).eq.1) then
6010 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
6011 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
6012 if (.not.dyn_ss .and. i.le.nss) then
6013 C 15/02/13 CC dynamic SSbond - additional check
6014 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
6015 & iabs(itype(jjj)).eq.1) then
6016 call ssbond_ene(iii,jjj,eij)
6019 cd write (iout,*) "eij",eij
6020 cd & ' waga=',waga,' fac=',fac
6021 else if (ii.gt.nres .and. jj.gt.nres) then
6022 c Restraints from contact prediction
6024 if (constr_dist.eq.11) then
6025 ehpb=ehpb+fordepth(i)**4.0d0
6026 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6027 fac=fordepth(i)**4.0d0
6028 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6029 if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6030 & ehpb,fordepth(i),dd
6032 if (dhpb1(i).gt.0.0d0) then
6033 ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6034 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6035 c write (iout,*) "beta nmr",
6036 c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6040 C Get the force constant corresponding to this distance.
6042 C Calculate the contribution to energy.
6043 ehpb=ehpb+waga*rdis*rdis
6044 c write (iout,*) "beta reg",dd,waga*rdis*rdis
6046 C Evaluate gradient.
6052 ggg(j)=fac*(c(j,jj)-c(j,ii))
6055 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6056 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6059 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6060 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6063 C Calculate the distance between the two points and its difference from the
6066 if (constr_dist.eq.11) then
6067 ehpb=ehpb+fordepth(i)**4.0d0
6068 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
6069 fac=fordepth(i)**4.0d0
6070 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
6071 if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
6072 & ehpb,fordepth(i),dd
6074 if (dhpb1(i).gt.0.0d0) then
6075 ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6076 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
6077 c write (iout,*) "alph nmr",
6078 c & dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
6081 C Get the force constant corresponding to this distance.
6083 C Calculate the contribution to energy.
6084 ehpb=ehpb+waga*rdis*rdis
6085 c write (iout,*) "alpha reg",dd,waga*rdis*rdis
6087 C Evaluate gradient.
6093 ggg(j)=fac*(c(j,jj)-c(j,ii))
6095 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
6096 C If this is a SC-SC distance, we need to calculate the contributions to the
6097 C Cartesian gradient in the SC vectors (ghpbx).
6100 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
6101 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
6104 cgrad do j=iii,jjj-1
6106 cgrad ghpbc(k,j)=ghpbc(k,j)+ggg(k)
6110 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
6111 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
6115 if (constr_dist.ne.11) ehpb=0.5D0*ehpb
6118 C--------------------------------------------------------------------------
6119 subroutine ssbond_ene(i,j,eij)
6121 C Calculate the distance and angle dependent SS-bond potential energy
6122 C using a free-energy function derived based on RHF/6-31G** ab initio
6123 C calculations of diethyl disulfide.
6125 C A. Liwo and U. Kozlowska, 11/24/03
6127 implicit real*8 (a-h,o-z)
6128 include 'DIMENSIONS'
6129 include 'COMMON.SBRIDGE'
6130 include 'COMMON.CHAIN'
6131 include 'COMMON.DERIV'
6132 include 'COMMON.LOCAL'
6133 include 'COMMON.INTERACT'
6134 include 'COMMON.VAR'
6135 include 'COMMON.IOUNITS'
6136 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6137 itypi=iabs(itype(i))
6141 dxi=dc_norm(1,nres+i)
6142 dyi=dc_norm(2,nres+i)
6143 dzi=dc_norm(3,nres+i)
6144 c dsci_inv=dsc_inv(itypi)
6145 dsci_inv=vbld_inv(nres+i)
6146 itypj=iabs(itype(j))
6147 c dscj_inv=dsc_inv(itypj)
6148 dscj_inv=vbld_inv(nres+j)
6152 dxj=dc_norm(1,nres+j)
6153 dyj=dc_norm(2,nres+j)
6154 dzj=dc_norm(3,nres+j)
6155 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6160 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6161 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6162 om12=dxi*dxj+dyi*dyj+dzi*dzj
6164 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6165 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6171 deltat12=om2-om1+2.0d0
6173 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6174 & +akct*deltad*deltat12
6175 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6176 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6177 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6178 c & " deltat12",deltat12," eij",eij
6179 ed=2*akcm*deltad+akct*deltat12
6181 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6182 eom1=-2*akth*deltat1-pom1-om2*pom2
6183 eom2= 2*akth*deltat2+pom1-om1*pom2
6186 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6187 ghpbx(k,i)=ghpbx(k,i)-ggk
6188 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6189 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6190 ghpbx(k,j)=ghpbx(k,j)+ggk
6191 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6192 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6193 ghpbc(k,i)=ghpbc(k,i)-ggk
6194 ghpbc(k,j)=ghpbc(k,j)+ggk
6197 C Calculate the components of the gradient in DC and X
6201 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
6206 C--------------------------------------------------------------------------
6207 subroutine ebond(estr)
6209 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6211 implicit real*8 (a-h,o-z)
6212 include 'DIMENSIONS'
6213 include 'COMMON.LOCAL'
6214 include 'COMMON.GEO'
6215 include 'COMMON.INTERACT'
6216 include 'COMMON.DERIV'
6217 include 'COMMON.VAR'
6218 include 'COMMON.CHAIN'
6219 include 'COMMON.IOUNITS'
6220 include 'COMMON.NAMES'
6221 include 'COMMON.FFIELD'
6222 include 'COMMON.CONTROL'
6223 include 'COMMON.SETUP'
6224 double precision u(3),ud(3)
6227 do i=ibondp_start,ibondp_end
6228 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6229 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6231 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6232 c & *dc(j,i-1)/vbld(i)
6234 c if (energy_dec) write(iout,*)
6235 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6237 C Checking if it involves dummy (NH3+ or COO-) group
6238 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6239 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
6240 diff = vbld(i)-vbldpDUM
6241 if (energy_dec) write(iout,*) "dum_bond",i,diff
6243 C NO vbldp0 is the equlibrium lenght of spring for peptide group
6244 diff = vbld(i)-vbldp0
6246 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6247 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6250 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6252 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6256 estr=0.5d0*AKP*estr+estr1
6258 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6260 do i=ibond_start,ibond_end
6262 if (iti.ne.10 .and. iti.ne.ntyp1) then
6265 diff=vbld(i+nres)-vbldsc0(1,iti)
6266 if (energy_dec) write (iout,*)
6267 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6268 & AKSC(1,iti),AKSC(1,iti)*diff*diff
6269 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6271 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6275 diff=vbld(i+nres)-vbldsc0(j,iti)
6276 ud(j)=aksc(j,iti)*diff
6277 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6291 uprod2=uprod2*u(k)*u(k)
6295 usumsqder=usumsqder+ud(j)*uprod2
6297 estr=estr+uprod/usum
6299 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6307 C--------------------------------------------------------------------------
6308 subroutine ebend(etheta,ethetacnstr)
6310 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6311 C angles gamma and its derivatives in consecutive thetas and gammas.
6313 implicit real*8 (a-h,o-z)
6314 include 'DIMENSIONS'
6315 include 'COMMON.LOCAL'
6316 include 'COMMON.GEO'
6317 include 'COMMON.INTERACT'
6318 include 'COMMON.DERIV'
6319 include 'COMMON.VAR'
6320 include 'COMMON.CHAIN'
6321 include 'COMMON.IOUNITS'
6322 include 'COMMON.NAMES'
6323 include 'COMMON.FFIELD'
6324 include 'COMMON.CONTROL'
6325 include 'COMMON.TORCNSTR'
6326 common /calcthet/ term1,term2,termm,diffak,ratak,
6327 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6328 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6329 double precision y(2),z(2)
6331 c time11=dexp(-2*time)
6334 c write (*,'(a,i2)') 'EBEND ICG=',icg
6335 do i=ithet_start,ithet_end
6336 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6337 & .or.itype(i).eq.ntyp1) cycle
6338 C Zero the energy function and its derivative at 0 or pi.
6339 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6341 ichir1=isign(1,itype(i-2))
6342 ichir2=isign(1,itype(i))
6343 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6344 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6345 if (itype(i-1).eq.10) then
6346 itype1=isign(10,itype(i-2))
6347 ichir11=isign(1,itype(i-2))
6348 ichir12=isign(1,itype(i-2))
6349 itype2=isign(10,itype(i))
6350 ichir21=isign(1,itype(i))
6351 ichir22=isign(1,itype(i))
6354 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6357 if (phii.ne.phii) phii=150.0
6367 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6370 if (phii1.ne.phii1) phii1=150.0
6382 C Calculate the "mean" value of theta from the part of the distribution
6383 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6384 C In following comments this theta will be referred to as t_c.
6385 thet_pred_mean=0.0d0
6387 athetk=athet(k,it,ichir1,ichir2)
6388 bthetk=bthet(k,it,ichir1,ichir2)
6390 athetk=athet(k,itype1,ichir11,ichir12)
6391 bthetk=bthet(k,itype2,ichir21,ichir22)
6393 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6394 c write(iout,*) 'chuj tu', y(k),z(k)
6396 dthett=thet_pred_mean*ssd
6397 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6398 C Derivatives of the "mean" values in gamma1 and gamma2.
6399 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6400 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6401 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6402 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6404 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6405 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6406 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6407 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6409 if (theta(i).gt.pi-delta) then
6410 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6412 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6413 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6414 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6416 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6418 else if (theta(i).lt.delta) then
6419 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6420 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6421 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6423 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6424 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6427 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6430 etheta=etheta+ethetai
6431 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6432 & 'ebend',i,ethetai,theta(i),itype(i)
6433 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6434 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6435 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6438 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
6439 do i=ithetaconstr_start,ithetaconstr_end
6440 itheta=itheta_constr(i)
6441 thetiii=theta(itheta)
6442 difi=pinorm(thetiii-theta_constr0(i))
6443 if (difi.gt.theta_drange(i)) then
6444 difi=difi-theta_drange(i)
6445 ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6446 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6447 & +for_thet_constr(i)*difi**3
6448 else if (difi.lt.-drange(i)) then
6450 ethetacnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
6451 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6452 & +for_thet_constr(i)*difi**3
6456 if (energy_dec) then
6457 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6458 & i,itheta,rad2deg*thetiii,
6459 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
6460 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6461 & gloc(itheta+nphi-2,icg)
6465 C Ufff.... We've done all this!!!
6468 C---------------------------------------------------------------------------
6469 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6471 implicit real*8 (a-h,o-z)
6472 include 'DIMENSIONS'
6473 include 'COMMON.LOCAL'
6474 include 'COMMON.IOUNITS'
6475 common /calcthet/ term1,term2,termm,diffak,ratak,
6476 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6477 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6478 C Calculate the contributions to both Gaussian lobes.
6479 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6480 C The "polynomial part" of the "standard deviation" of this part of
6481 C the distributioni.
6482 ccc write (iout,*) thetai,thet_pred_mean
6485 sig=sig*thet_pred_mean+polthet(j,it)
6487 C Derivative of the "interior part" of the "standard deviation of the"
6488 C gamma-dependent Gaussian lobe in t_c.
6489 sigtc=3*polthet(3,it)
6491 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6494 C Set the parameters of both Gaussian lobes of the distribution.
6495 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6496 fac=sig*sig+sigc0(it)
6499 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6500 sigsqtc=-4.0D0*sigcsq*sigtc
6501 c print *,i,sig,sigtc,sigsqtc
6502 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6503 sigtc=-sigtc/(fac*fac)
6504 C Following variable is sigma(t_c)**(-2)
6505 sigcsq=sigcsq*sigcsq
6507 sig0inv=1.0D0/sig0i**2
6508 delthec=thetai-thet_pred_mean
6509 delthe0=thetai-theta0i
6510 term1=-0.5D0*sigcsq*delthec*delthec
6511 term2=-0.5D0*sig0inv*delthe0*delthe0
6512 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6513 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6514 C NaNs in taking the logarithm. We extract the largest exponent which is added
6515 C to the energy (this being the log of the distribution) at the end of energy
6516 C term evaluation for this virtual-bond angle.
6517 if (term1.gt.term2) then
6519 term2=dexp(term2-termm)
6523 term1=dexp(term1-termm)
6526 C The ratio between the gamma-independent and gamma-dependent lobes of
6527 C the distribution is a Gaussian function of thet_pred_mean too.
6528 diffak=gthet(2,it)-thet_pred_mean
6529 ratak=diffak/gthet(3,it)**2
6530 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6531 C Let's differentiate it in thet_pred_mean NOW.
6533 C Now put together the distribution terms to make complete distribution.
6534 termexp=term1+ak*term2
6535 termpre=sigc+ak*sig0i
6536 C Contribution of the bending energy from this theta is just the -log of
6537 C the sum of the contributions from the two lobes and the pre-exponential
6538 C factor. Simple enough, isn't it?
6539 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6540 C write (iout,*) 'termexp',termexp,termm,termpre,i
6541 C NOW the derivatives!!!
6542 C 6/6/97 Take into account the deformation.
6543 E_theta=(delthec*sigcsq*term1
6544 & +ak*delthe0*sig0inv*term2)/termexp
6545 E_tc=((sigtc+aktc*sig0i)/termpre
6546 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6547 & aktc*term2)/termexp)
6550 c-----------------------------------------------------------------------------
6551 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6552 implicit real*8 (a-h,o-z)
6553 include 'DIMENSIONS'
6554 include 'COMMON.LOCAL'
6555 include 'COMMON.IOUNITS'
6556 common /calcthet/ term1,term2,termm,diffak,ratak,
6557 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6558 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6559 delthec=thetai-thet_pred_mean
6560 delthe0=thetai-theta0i
6561 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6562 t3 = thetai-thet_pred_mean
6566 t14 = t12+t6*sigsqtc
6568 t21 = thetai-theta0i
6574 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6575 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6576 & *(-t12*t9-ak*sig0inv*t27)
6580 C--------------------------------------------------------------------------
6581 subroutine ebend(etheta,ethetacnstr)
6583 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6584 C angles gamma and its derivatives in consecutive thetas and gammas.
6585 C ab initio-derived potentials from
6586 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6588 implicit real*8 (a-h,o-z)
6589 include 'DIMENSIONS'
6590 include 'COMMON.LOCAL'
6591 include 'COMMON.GEO'
6592 include 'COMMON.INTERACT'
6593 include 'COMMON.DERIV'
6594 include 'COMMON.VAR'
6595 include 'COMMON.CHAIN'
6596 include 'COMMON.IOUNITS'
6597 include 'COMMON.NAMES'
6598 include 'COMMON.FFIELD'
6599 include 'COMMON.CONTROL'
6600 include 'COMMON.TORCNSTR'
6601 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6602 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6603 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6604 & sinph1ph2(maxdouble,maxdouble)
6605 logical lprn /.false./, lprn1 /.false./
6607 do i=ithet_start,ithet_end
6608 c print *,i,itype(i-1),itype(i),itype(i-2)
6609 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6610 & .or.itype(i).eq.ntyp1) cycle
6611 C print *,i,theta(i)
6612 if (iabs(itype(i+1)).eq.20) iblock=2
6613 if (iabs(itype(i+1)).ne.20) iblock=1
6617 theti2=0.5d0*theta(i)
6618 ityp2=ithetyp((itype(i-1)))
6620 coskt(k)=dcos(k*theti2)
6621 sinkt(k)=dsin(k*theti2)
6624 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6627 if (phii.ne.phii) phii=150.0
6631 ityp1=ithetyp((itype(i-2)))
6632 C propagation of chirality for glycine type
6634 cosph1(k)=dcos(k*phii)
6635 sinph1(k)=dsin(k*phii)
6640 ityp1=ithetyp((itype(i-2)))
6645 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6648 if (phii1.ne.phii1) phii1=150.0
6653 ityp3=ithetyp((itype(i)))
6655 cosph2(k)=dcos(k*phii1)
6656 sinph2(k)=dsin(k*phii1)
6660 ityp3=ithetyp((itype(i)))
6666 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6669 ccl=cosph1(l)*cosph2(k-l)
6670 ssl=sinph1(l)*sinph2(k-l)
6671 scl=sinph1(l)*cosph2(k-l)
6672 csl=cosph1(l)*sinph2(k-l)
6673 cosph1ph2(l,k)=ccl-ssl
6674 cosph1ph2(k,l)=ccl+ssl
6675 sinph1ph2(l,k)=scl+csl
6676 sinph1ph2(k,l)=scl-csl
6680 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6681 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6682 write (iout,*) "coskt and sinkt"
6684 write (iout,*) k,coskt(k),sinkt(k)
6688 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6689 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6692 & write (iout,*) "k",k,"
6693 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6694 & " ethetai",ethetai
6697 write (iout,*) "cosph and sinph"
6699 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6701 write (iout,*) "cosph1ph2 and sinph2ph2"
6704 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6705 & sinph1ph2(l,k),sinph1ph2(k,l)
6708 write(iout,*) "ethetai",ethetai
6713 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6714 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6715 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6716 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6717 ethetai=ethetai+sinkt(m)*aux
6718 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6719 dephii=dephii+k*sinkt(m)*(
6720 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6721 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6722 dephii1=dephii1+k*sinkt(m)*(
6723 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6724 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6726 & write (iout,*) "m",m," k",k," bbthet",
6727 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6728 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6729 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6730 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6731 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6734 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6735 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6736 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6737 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6739 & write(iout,*) "ethetai",ethetai
6740 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6744 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6745 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6746 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6747 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6748 ethetai=ethetai+sinkt(m)*aux
6749 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6750 dephii=dephii+l*sinkt(m)*(
6751 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6752 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6753 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6754 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6755 dephii1=dephii1+(k-l)*sinkt(m)*(
6756 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6757 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6758 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6759 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6761 write (iout,*) "m",m," k",k," l",l," ffthet",
6762 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6763 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6764 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6765 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6766 & " ethetai",ethetai
6767 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6768 & cosph1ph2(k,l)*sinkt(m),
6769 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6778 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6779 & i,theta(i)*rad2deg,phii*rad2deg,
6780 & phii1*rad2deg,ethetai
6782 etheta=etheta+ethetai
6783 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6784 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6785 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6789 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
6790 do i=ithetaconstr_start,ithetaconstr_end
6791 itheta=itheta_constr(i)
6792 thetiii=theta(itheta)
6793 difi=pinorm(thetiii-theta_constr0(i))
6794 if (difi.gt.theta_drange(i)) then
6795 difi=difi-theta_drange(i)
6796 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6797 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6798 & +for_thet_constr(i)*difi**3
6799 else if (difi.lt.-drange(i)) then
6801 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6802 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6803 & +for_thet_constr(i)*difi**3
6807 if (energy_dec) then
6808 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6809 & i,itheta,rad2deg*thetiii,
6810 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
6811 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6812 & gloc(itheta+nphi-2,icg)
6820 c-----------------------------------------------------------------------------
6821 subroutine esc(escloc)
6822 C Calculate the local energy of a side chain and its derivatives in the
6823 C corresponding virtual-bond valence angles THETA and the spherical angles
6825 implicit real*8 (a-h,o-z)
6826 include 'DIMENSIONS'
6827 include 'COMMON.GEO'
6828 include 'COMMON.LOCAL'
6829 include 'COMMON.VAR'
6830 include 'COMMON.INTERACT'
6831 include 'COMMON.DERIV'
6832 include 'COMMON.CHAIN'
6833 include 'COMMON.IOUNITS'
6834 include 'COMMON.NAMES'
6835 include 'COMMON.FFIELD'
6836 include 'COMMON.CONTROL'
6837 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6838 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6839 common /sccalc/ time11,time12,time112,theti,it,nlobit
6842 c write (iout,'(a)') 'ESC'
6843 do i=loc_start,loc_end
6845 if (it.eq.ntyp1) cycle
6846 if (it.eq.10) goto 1
6847 nlobit=nlob(iabs(it))
6848 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6849 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6850 theti=theta(i+1)-pipol
6855 if (x(2).gt.pi-delta) then
6859 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6861 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6862 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6864 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6865 & ddersc0(1),dersc(1))
6866 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6867 & ddersc0(3),dersc(3))
6869 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6871 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6872 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6873 & dersc0(2),esclocbi,dersc02)
6874 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6876 call splinthet(x(2),0.5d0*delta,ss,ssd)
6881 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6883 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6884 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6886 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6888 c write (iout,*) escloci
6889 else if (x(2).lt.delta) then
6893 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6895 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6896 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6898 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6899 & ddersc0(1),dersc(1))
6900 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6901 & ddersc0(3),dersc(3))
6903 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6905 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6906 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6907 & dersc0(2),esclocbi,dersc02)
6908 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6913 call splinthet(x(2),0.5d0*delta,ss,ssd)
6915 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6917 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6918 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6920 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6921 c write (iout,*) escloci
6923 call enesc(x,escloci,dersc,ddummy,.false.)
6926 escloc=escloc+escloci
6927 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6928 & 'escloc',i,escloci
6929 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6931 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6933 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6934 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6939 C---------------------------------------------------------------------------
6940 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6941 implicit real*8 (a-h,o-z)
6942 include 'DIMENSIONS'
6943 include 'COMMON.GEO'
6944 include 'COMMON.LOCAL'
6945 include 'COMMON.IOUNITS'
6946 common /sccalc/ time11,time12,time112,theti,it,nlobit
6947 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6948 double precision contr(maxlob,-1:1)
6950 c write (iout,*) 'it=',it,' nlobit=',nlobit
6954 if (mixed) ddersc(j)=0.0d0
6958 C Because of periodicity of the dependence of the SC energy in omega we have
6959 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6960 C To avoid underflows, first compute & store the exponents.
6968 z(k)=x(k)-censc(k,j,it)
6973 Axk=Axk+gaussc(l,k,j,it)*z(l)
6979 expfac=expfac+Ax(k,j,iii)*z(k)
6987 C As in the case of ebend, we want to avoid underflows in exponentiation and
6988 C subsequent NaNs and INFs in energy calculation.
6989 C Find the largest exponent
6993 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6997 cd print *,'it=',it,' emin=',emin
6999 C Compute the contribution to SC energy and derivatives
7004 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
7005 if(adexp.ne.adexp) adexp=1.0
7008 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
7010 cd print *,'j=',j,' expfac=',expfac
7011 escloc_i=escloc_i+expfac
7013 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
7017 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
7018 & +gaussc(k,2,j,it))*expfac
7025 dersc(1)=dersc(1)/cos(theti)**2
7026 ddersc(1)=ddersc(1)/cos(theti)**2
7029 escloci=-(dlog(escloc_i)-emin)
7031 dersc(j)=dersc(j)/escloc_i
7035 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
7040 C------------------------------------------------------------------------------
7041 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
7042 implicit real*8 (a-h,o-z)
7043 include 'DIMENSIONS'
7044 include 'COMMON.GEO'
7045 include 'COMMON.LOCAL'
7046 include 'COMMON.IOUNITS'
7047 common /sccalc/ time11,time12,time112,theti,it,nlobit
7048 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
7049 double precision contr(maxlob)
7060 z(k)=x(k)-censc(k,j,it)
7066 Axk=Axk+gaussc(l,k,j,it)*z(l)
7072 expfac=expfac+Ax(k,j)*z(k)
7077 C As in the case of ebend, we want to avoid underflows in exponentiation and
7078 C subsequent NaNs and INFs in energy calculation.
7079 C Find the largest exponent
7082 if (emin.gt.contr(j)) emin=contr(j)
7086 C Compute the contribution to SC energy and derivatives
7090 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
7091 escloc_i=escloc_i+expfac
7093 dersc(k)=dersc(k)+Ax(k,j)*expfac
7095 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
7096 & +gaussc(1,2,j,it))*expfac
7100 dersc(1)=dersc(1)/cos(theti)**2
7101 dersc12=dersc12/cos(theti)**2
7102 escloci=-(dlog(escloc_i)-emin)
7104 dersc(j)=dersc(j)/escloc_i
7106 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
7110 c----------------------------------------------------------------------------------
7111 subroutine esc(escloc)
7112 C Calculate the local energy of a side chain and its derivatives in the
7113 C corresponding virtual-bond valence angles THETA and the spherical angles
7114 C ALPHA and OMEGA derived from AM1 all-atom calculations.
7115 C added by Urszula Kozlowska. 07/11/2007
7117 implicit real*8 (a-h,o-z)
7118 include 'DIMENSIONS'
7119 include 'COMMON.GEO'
7120 include 'COMMON.LOCAL'
7121 include 'COMMON.VAR'
7122 include 'COMMON.SCROT'
7123 include 'COMMON.INTERACT'
7124 include 'COMMON.DERIV'
7125 include 'COMMON.CHAIN'
7126 include 'COMMON.IOUNITS'
7127 include 'COMMON.NAMES'
7128 include 'COMMON.FFIELD'
7129 include 'COMMON.CONTROL'
7130 include 'COMMON.VECTORS'
7131 double precision x_prime(3),y_prime(3),z_prime(3)
7132 & , sumene,dsc_i,dp2_i,x(65),
7133 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
7134 & de_dxx,de_dyy,de_dzz,de_dt
7135 double precision s1_t,s1_6_t,s2_t,s2_6_t
7137 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
7138 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
7139 & dt_dCi(3),dt_dCi1(3)
7140 common /sccalc/ time11,time12,time112,theti,it,nlobit
7143 do i=loc_start,loc_end
7144 if (itype(i).eq.ntyp1) cycle
7145 costtab(i+1) =dcos(theta(i+1))
7146 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
7147 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
7148 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
7149 cosfac2=0.5d0/(1.0d0+costtab(i+1))
7150 cosfac=dsqrt(cosfac2)
7151 sinfac2=0.5d0/(1.0d0-costtab(i+1))
7152 sinfac=dsqrt(sinfac2)
7154 if (it.eq.10) goto 1
7156 C Compute the axes of tghe local cartesian coordinates system; store in
7157 c x_prime, y_prime and z_prime
7164 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
7165 C & dc_norm(3,i+nres)
7167 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
7168 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
7171 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
7174 c write (2,*) "x_prime",(x_prime(j),j=1,3)
7175 c write (2,*) "y_prime",(y_prime(j),j=1,3)
7176 c write (2,*) "z_prime",(z_prime(j),j=1,3)
7177 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
7178 c & " xy",scalar(x_prime(1),y_prime(1)),
7179 c & " xz",scalar(x_prime(1),z_prime(1)),
7180 c & " yy",scalar(y_prime(1),y_prime(1)),
7181 c & " yz",scalar(y_prime(1),z_prime(1)),
7182 c & " zz",scalar(z_prime(1),z_prime(1))
7184 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
7185 C to local coordinate system. Store in xx, yy, zz.
7191 xx = xx + x_prime(j)*dc_norm(j,i+nres)
7192 yy = yy + y_prime(j)*dc_norm(j,i+nres)
7193 zz = zz + z_prime(j)*dc_norm(j,i+nres)
7200 C Compute the energy of the ith side cbain
7202 c write (2,*) "xx",xx," yy",yy," zz",zz
7205 x(j) = sc_parmin(j,it)
7208 Cc diagnostics - remove later
7210 yy1 = dsin(alph(2))*dcos(omeg(2))
7211 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7212 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7213 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7215 C," --- ", xx_w,yy_w,zz_w
7218 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7219 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7221 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7222 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7224 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7225 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7226 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7227 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7228 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7230 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7231 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7232 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7233 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7234 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7236 dsc_i = 0.743d0+x(61)
7238 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7239 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7240 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7241 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7242 s1=(1+x(63))/(0.1d0 + dscp1)
7243 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7244 s2=(1+x(65))/(0.1d0 + dscp2)
7245 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7246 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7247 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7248 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7250 c & dscp1,dscp2,sumene
7251 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7252 escloc = escloc + sumene
7253 c write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7258 C This section to check the numerical derivatives of the energy of ith side
7259 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7260 C #define DEBUG in the code to turn it on.
7262 write (2,*) "sumene =",sumene
7266 write (2,*) xx,yy,zz
7267 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7268 de_dxx_num=(sumenep-sumene)/aincr
7270 write (2,*) "xx+ sumene from enesc=",sumenep
7273 write (2,*) xx,yy,zz
7274 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7275 de_dyy_num=(sumenep-sumene)/aincr
7277 write (2,*) "yy+ sumene from enesc=",sumenep
7280 write (2,*) xx,yy,zz
7281 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7282 de_dzz_num=(sumenep-sumene)/aincr
7284 write (2,*) "zz+ sumene from enesc=",sumenep
7285 costsave=cost2tab(i+1)
7286 sintsave=sint2tab(i+1)
7287 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7288 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7289 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7290 de_dt_num=(sumenep-sumene)/aincr
7291 write (2,*) " t+ sumene from enesc=",sumenep
7292 cost2tab(i+1)=costsave
7293 sint2tab(i+1)=sintsave
7294 C End of diagnostics section.
7297 C Compute the gradient of esc
7299 c zz=zz*dsign(1.0,dfloat(itype(i)))
7300 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7301 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7302 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7303 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7304 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7305 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7306 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7307 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7308 pom1=(sumene3*sint2tab(i+1)+sumene1)
7309 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7310 pom2=(sumene4*cost2tab(i+1)+sumene2)
7311 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7312 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7313 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7314 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7316 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7317 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7318 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7320 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7321 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7322 & +(pom1+pom2)*pom_dx
7324 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7327 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7328 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7329 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7331 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7332 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7333 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7334 & +x(59)*zz**2 +x(60)*xx*zz
7335 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7336 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7337 & +(pom1-pom2)*pom_dy
7339 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7342 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7343 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7344 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7345 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7346 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7347 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7348 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7349 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7351 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7354 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7355 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7356 & +pom1*pom_dt1+pom2*pom_dt2
7358 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7363 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7364 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7365 cosfac2xx=cosfac2*xx
7366 sinfac2yy=sinfac2*yy
7368 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7370 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7372 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7373 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7374 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7375 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7376 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7377 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7378 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7379 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7380 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7381 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7385 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7386 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7387 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7388 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7391 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7392 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7393 dZZ_XYZ(k)=vbld_inv(i+nres)*
7394 & (z_prime(k)-zz*dC_norm(k,i+nres))
7396 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7397 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7401 dXX_Ctab(k,i)=dXX_Ci(k)
7402 dXX_C1tab(k,i)=dXX_Ci1(k)
7403 dYY_Ctab(k,i)=dYY_Ci(k)
7404 dYY_C1tab(k,i)=dYY_Ci1(k)
7405 dZZ_Ctab(k,i)=dZZ_Ci(k)
7406 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7407 dXX_XYZtab(k,i)=dXX_XYZ(k)
7408 dYY_XYZtab(k,i)=dYY_XYZ(k)
7409 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7413 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7414 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7415 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7416 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7417 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7419 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7420 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7421 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7422 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7423 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7424 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7425 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7426 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7428 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7429 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7431 C to check gradient call subroutine check_grad
7437 c------------------------------------------------------------------------------
7438 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7440 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7441 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7442 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7443 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7445 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7446 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7448 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7449 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7450 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7451 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7452 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7454 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7455 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7456 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7457 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7458 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7460 dsc_i = 0.743d0+x(61)
7462 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7463 & *(xx*cost2+yy*sint2))
7464 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7465 & *(xx*cost2-yy*sint2))
7466 s1=(1+x(63))/(0.1d0 + dscp1)
7467 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7468 s2=(1+x(65))/(0.1d0 + dscp2)
7469 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7470 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7471 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7476 c------------------------------------------------------------------------------
7477 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7479 C This procedure calculates two-body contact function g(rij) and its derivative:
7482 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7485 C where x=(rij-r0ij)/delta
7487 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7490 double precision rij,r0ij,eps0ij,fcont,fprimcont
7491 double precision x,x2,x4,delta
7495 if (x.lt.-1.0D0) then
7498 else if (x.le.1.0D0) then
7501 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7502 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7509 c------------------------------------------------------------------------------
7510 subroutine splinthet(theti,delta,ss,ssder)
7511 implicit real*8 (a-h,o-z)
7512 include 'DIMENSIONS'
7513 include 'COMMON.VAR'
7514 include 'COMMON.GEO'
7517 if (theti.gt.pipol) then
7518 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7520 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7525 c------------------------------------------------------------------------------
7526 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7528 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7529 double precision ksi,ksi2,ksi3,a1,a2,a3
7530 a1=fprim0*delta/(f1-f0)
7536 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7537 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7540 c------------------------------------------------------------------------------
7541 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7543 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7544 double precision ksi,ksi2,ksi3,a1,a2,a3
7549 a2=3*(f1x-f0x)-2*fprim0x*delta
7550 a3=fprim0x*delta-2*(f1x-f0x)
7551 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7554 C-----------------------------------------------------------------------------
7556 C-----------------------------------------------------------------------------
7557 subroutine etor(etors,edihcnstr)
7558 implicit real*8 (a-h,o-z)
7559 include 'DIMENSIONS'
7560 include 'COMMON.VAR'
7561 include 'COMMON.GEO'
7562 include 'COMMON.LOCAL'
7563 include 'COMMON.TORSION'
7564 include 'COMMON.INTERACT'
7565 include 'COMMON.DERIV'
7566 include 'COMMON.CHAIN'
7567 include 'COMMON.NAMES'
7568 include 'COMMON.IOUNITS'
7569 include 'COMMON.FFIELD'
7570 include 'COMMON.TORCNSTR'
7571 include 'COMMON.CONTROL'
7573 C Set lprn=.true. for debugging
7577 do i=iphi_start,iphi_end
7579 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7580 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7581 itori=itortyp(itype(i-2))
7582 itori1=itortyp(itype(i-1))
7585 C Proline-Proline pair is a special case...
7586 if (itori.eq.3 .and. itori1.eq.3) then
7587 if (phii.gt.-dwapi3) then
7589 fac=1.0D0/(1.0D0-cosphi)
7590 etorsi=v1(1,3,3)*fac
7591 etorsi=etorsi+etorsi
7592 etors=etors+etorsi-v1(1,3,3)
7593 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7594 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7597 v1ij=v1(j+1,itori,itori1)
7598 v2ij=v2(j+1,itori,itori1)
7601 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7602 if (energy_dec) etors_ii=etors_ii+
7603 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7604 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7608 v1ij=v1(j,itori,itori1)
7609 v2ij=v2(j,itori,itori1)
7612 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7613 if (energy_dec) etors_ii=etors_ii+
7614 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7615 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7618 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7621 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7622 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7623 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7624 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7625 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7627 ! 6/20/98 - dihedral angle constraints
7630 itori=idih_constr(i)
7633 if (difi.gt.drange(i)) then
7635 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7636 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7637 else if (difi.lt.-drange(i)) then
7639 edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
7640 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7642 ! write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7643 ! & rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7645 ! write (iout,*) 'edihcnstr',edihcnstr
7648 c------------------------------------------------------------------------------
7649 subroutine etor_d(etors_d)
7653 c----------------------------------------------------------------------------
7655 subroutine etor(etors,edihcnstr)
7656 implicit real*8 (a-h,o-z)
7657 include 'DIMENSIONS'
7658 include 'COMMON.VAR'
7659 include 'COMMON.GEO'
7660 include 'COMMON.LOCAL'
7661 include 'COMMON.TORSION'
7662 include 'COMMON.INTERACT'
7663 include 'COMMON.DERIV'
7664 include 'COMMON.CHAIN'
7665 include 'COMMON.NAMES'
7666 include 'COMMON.IOUNITS'
7667 include 'COMMON.FFIELD'
7668 include 'COMMON.TORCNSTR'
7669 include 'COMMON.CONTROL'
7671 C Set lprn=.true. for debugging
7675 do i=iphi_start,iphi_end
7676 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7677 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7678 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7679 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7680 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7681 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7682 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7683 C For introducing the NH3+ and COO- group please check the etor_d for reference
7686 if (iabs(itype(i)).eq.20) then
7691 itori=itortyp(itype(i-2))
7692 itori1=itortyp(itype(i-1))
7695 C Regular cosine and sine terms
7696 do j=1,nterm(itori,itori1,iblock)
7697 v1ij=v1(j,itori,itori1,iblock)
7698 v2ij=v2(j,itori,itori1,iblock)
7701 etors=etors+v1ij*cosphi+v2ij*sinphi
7702 if (energy_dec) etors_ii=etors_ii+
7703 & v1ij*cosphi+v2ij*sinphi
7704 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7708 C E = SUM ----------------------------------- - v1
7709 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7711 cosphi=dcos(0.5d0*phii)
7712 sinphi=dsin(0.5d0*phii)
7713 do j=1,nlor(itori,itori1,iblock)
7714 vl1ij=vlor1(j,itori,itori1)
7715 vl2ij=vlor2(j,itori,itori1)
7716 vl3ij=vlor3(j,itori,itori1)
7717 pom=vl2ij*cosphi+vl3ij*sinphi
7718 pom1=1.0d0/(pom*pom+1.0d0)
7719 etors=etors+vl1ij*pom1
7720 if (energy_dec) etors_ii=etors_ii+
7723 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7725 C Subtract the constant term
7726 etors=etors-v0(itori,itori1,iblock)
7727 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7728 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7730 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7731 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7732 & (v1(j,itori,itori1,iblock),j=1,6),
7733 & (v2(j,itori,itori1,iblock),j=1,6)
7734 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7735 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7737 ! 6/20/98 - dihedral angle constraints
7739 c do i=1,ndih_constr
7740 do i=idihconstr_start,idihconstr_end
7741 itori=idih_constr(i)
7743 difi=pinorm(phii-phi0(i))
7744 if (difi.gt.drange(i)) then
7746 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7747 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7748 else if (difi.lt.-drange(i)) then
7750 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7751 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7755 if (energy_dec) then
7756 write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
7757 & i,itori,rad2deg*phii,
7758 & rad2deg*phi0(i), rad2deg*drange(i),
7759 & rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
7762 cd write (iout,*) 'edihcnstr',edihcnstr
7765 c----------------------------------------------------------------------------
7766 subroutine etor_d(etors_d)
7767 C 6/23/01 Compute double torsional energy
7768 implicit real*8 (a-h,o-z)
7769 include 'DIMENSIONS'
7770 include 'COMMON.VAR'
7771 include 'COMMON.GEO'
7772 include 'COMMON.LOCAL'
7773 include 'COMMON.TORSION'
7774 include 'COMMON.INTERACT'
7775 include 'COMMON.DERIV'
7776 include 'COMMON.CHAIN'
7777 include 'COMMON.NAMES'
7778 include 'COMMON.IOUNITS'
7779 include 'COMMON.FFIELD'
7780 include 'COMMON.TORCNSTR'
7782 C Set lprn=.true. for debugging
7786 c write(iout,*) "a tu??"
7787 do i=iphid_start,iphid_end
7788 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7789 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7790 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7791 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7792 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7793 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7794 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7795 & (itype(i+1).eq.ntyp1)) cycle
7796 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7797 itori=itortyp(itype(i-2))
7798 itori1=itortyp(itype(i-1))
7799 itori2=itortyp(itype(i))
7805 if (iabs(itype(i+1)).eq.20) iblock=2
7806 C Iblock=2 Proline type
7807 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7808 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7809 C if (itype(i+1).eq.ntyp1) iblock=3
7810 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7811 C IS or IS NOT need for this
7812 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7813 C is (itype(i-3).eq.ntyp1) ntblock=2
7814 C ntblock is N-terminal blocking group
7816 C Regular cosine and sine terms
7817 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7818 C Example of changes for NH3+ blocking group
7819 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7820 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7821 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7822 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7823 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7824 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7825 cosphi1=dcos(j*phii)
7826 sinphi1=dsin(j*phii)
7827 cosphi2=dcos(j*phii1)
7828 sinphi2=dsin(j*phii1)
7829 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7830 & v2cij*cosphi2+v2sij*sinphi2
7831 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7832 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7834 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7836 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7837 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7838 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7839 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7840 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7841 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7842 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7843 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7844 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7845 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7846 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7847 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7848 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7849 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7852 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7853 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7858 C----------------------------------------------------------------------------------
7859 C The rigorous attempt to derive energy function
7860 subroutine etor_kcc(etors,edihcnstr)
7861 implicit real*8 (a-h,o-z)
7862 include 'DIMENSIONS'
7863 include 'COMMON.VAR'
7864 include 'COMMON.GEO'
7865 include 'COMMON.LOCAL'
7866 include 'COMMON.TORSION'
7867 include 'COMMON.INTERACT'
7868 include 'COMMON.DERIV'
7869 include 'COMMON.CHAIN'
7870 include 'COMMON.NAMES'
7871 include 'COMMON.IOUNITS'
7872 include 'COMMON.FFIELD'
7873 include 'COMMON.TORCNSTR'
7874 include 'COMMON.CONTROL'
7876 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7877 C Set lprn=.true. for debugging
7880 C print *,"wchodze kcc"
7881 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7882 if (tor_mode.ne.2) then
7885 do i=iphi_start,iphi_end
7886 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7887 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7888 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7889 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7890 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7891 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7892 itori=itortyp_kcc(itype(i-2))
7893 itori1=itortyp_kcc(itype(i-1))
7898 sumnonchebyshev=0.0d0
7900 C to avoid multiple devision by 2
7901 c theti22=0.5d0*theta(i)
7902 C theta 12 is the theta_1 /2
7903 C theta 22 is theta_2 /2
7904 c theti12=0.5d0*theta(i-1)
7905 C and appropriate sinus function
7906 sinthet1=dsin(theta(i-1))
7907 sinthet2=dsin(theta(i))
7908 costhet1=dcos(theta(i-1))
7909 costhet2=dcos(theta(i))
7910 c Cosines of halves thetas
7911 costheti12=0.5d0*(1.0d0+costhet1)
7912 costheti22=0.5d0*(1.0d0+costhet2)
7913 C to speed up lets store its mutliplication
7914 sint1t2=sinthet2*sinthet1
7916 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7917 C +d_n*sin(n*gamma)) *
7918 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7919 C we have two sum 1) Non-Chebyshev which is with n and gamma
7921 do j=1,nterm_kcc(itori,itori1)
7923 nval=nterm_kcc_Tb(itori,itori1)
7924 v1ij=v1_kcc(j,itori,itori1)
7925 v2ij=v2_kcc(j,itori,itori1)
7926 c write (iout,*) "i",i," j",j," v1",v1ij," v2",v2ij
7927 C v1ij is c_n and d_n in euation above
7931 sint1t2n=sint1t2n*sint1t2
7932 sumth1tyb1=tschebyshev(1,nval,v11_chyb(1,j,itori,itori1),
7934 gradth1tyb1=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7935 & v11_chyb(1,j,itori,itori1),costheti12)
7936 c write (iout,*) "v11",(v11_chyb(k,j,itori,itori1),k=1,nval),
7937 c & " sumth1tyb1",sumth1tyb1," gradth1tyb1",gradth1tyb1
7938 sumth2tyb1=tschebyshev(1,nval,v21_chyb(1,j,itori,itori1),
7940 gradth2tyb1=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7941 & v21_chyb(1,j,itori,itori1),costheti22)
7942 c write (iout,*) "v21",(v21_chyb(k,j,itori,itori1),k=1,nval),
7943 c & " sumth2tyb1",sumth2tyb1," gradth2tyb1",gradth2tyb1
7944 sumth1tyb2=tschebyshev(1,nval,v12_chyb(1,j,itori,itori1),
7946 gradth1tyb2=-0.5d0*sinthet1*gradtschebyshev(0,nval-1,
7947 & v12_chyb(1,j,itori,itori1),costheti12)
7948 c write (iout,*) "v12",(v12_chyb(k,j,itori,itori1),k=1,nval),
7949 c & " sumth1tyb2",sumth1tyb2," gradth1tyb2",gradth1tyb2
7950 sumth2tyb2=tschebyshev(1,nval,v22_chyb(1,j,itori,itori1),
7952 gradth2tyb2=-0.5d0*sinthet2*gradtschebyshev(0,nval-1,
7953 & v22_chyb(1,j,itori,itori1),costheti22)
7954 c write (iout,*) "v22",(v22_chyb(k,j,itori,itori1),k=1,nval),
7955 c & " sumth2tyb2",sumth2tyb2," gradth2tyb2",gradth2tyb2
7956 C etors=etors+sint1t2n*(v1ij*cosphi+v2ij*sinphi)
7957 C if (energy_dec) etors_ii=etors_ii+
7958 C & v1ij*cosphi+v2ij*sinphi
7959 C glocig is the gradient local i site in gamma
7960 actval1=v1ij*cosphi*(1.0d0+sumth1tyb1+sumth2tyb1)
7961 actval2=v2ij*sinphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7962 etori=etori+sint1t2n*(actval1+actval2)
7964 & j*sint1t2n*(v2ij*cosphi*(1.0d0+sumth1tyb2+sumth2tyb2)
7965 & -v1ij*sinphi*(1.0d0+sumth1tyb1+sumth2tyb1))
7966 C now gradient over theta_1
7968 & j*sint1t2n1*costhet1*sinthet2*(actval1+actval2)+
7969 & sint1t2n*(v1ij*cosphi*gradth1tyb1+v2ij*sinphi*gradth1tyb2)
7971 & j*sint1t2n1*sinthet1*costhet2*(actval1+actval2)+
7972 & sint1t2n*(v1ij*cosphi*gradth2tyb1+v2ij*sinphi*gradth2tyb2)
7974 C now the Czebyshev polinominal sum
7975 c do k=1,nterm_kcc_Tb(itori,itori1)
7976 c thybt1(k)=v1_chyb(k,j,itori,itori1)
7977 c thybt2(k)=v2_chyb(k,j,itori,itori1)
7981 C print *, sumth1thyb, gradthybt1, sumth2thyb, gradthybt2,
7983 C & (0,nterm_kcc_Tb(itori,itori1)-1,thybt2(1),
7984 C & dcos(theti22)**2),
7987 C now overal sumation
7988 C print *,"sumnon", sumnonchebyshev,sumth1thyb+sumth2thyb
7991 C derivative over gamma
7992 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7993 C derivative over theta1
7994 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7995 C now derivative over theta2
7996 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7998 & write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7999 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
8001 C gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
8002 ! 6/20/98 - dihedral angle constraints
8003 if (tor_mode.ne.2) then
8005 c do i=1,ndih_constr
8006 do i=idihconstr_start,idihconstr_end
8007 itori=idih_constr(i)
8009 difi=pinorm(phii-phi0(i))
8010 if (difi.gt.drange(i)) then
8012 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8013 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8014 else if (difi.lt.-drange(i)) then
8016 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
8017 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
8026 C The rigorous attempt to derive energy function
8027 subroutine ebend_kcc(etheta,ethetacnstr)
8029 implicit real*8 (a-h,o-z)
8030 include 'DIMENSIONS'
8031 include 'COMMON.VAR'
8032 include 'COMMON.GEO'
8033 include 'COMMON.LOCAL'
8034 include 'COMMON.TORSION'
8035 include 'COMMON.INTERACT'
8036 include 'COMMON.DERIV'
8037 include 'COMMON.CHAIN'
8038 include 'COMMON.NAMES'
8039 include 'COMMON.IOUNITS'
8040 include 'COMMON.FFIELD'
8041 include 'COMMON.TORCNSTR'
8042 include 'COMMON.CONTROL'
8044 double precision thybt1(maxtermkcc)
8045 C Set lprn=.true. for debugging
8048 C print *,"wchodze kcc"
8049 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8050 if (tor_mode.ne.2) etheta=0.0D0
8051 do i=ithet_start,ithet_end
8052 c print *,i,itype(i-1),itype(i),itype(i-2)
8053 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8054 & .or.itype(i).eq.ntyp1) cycle
8055 iti=itortyp_kcc(itype(i-1))
8056 sinthet=dsin(theta(i)/2.0d0)
8057 costhet=dcos(theta(i)/2.0d0)
8058 do j=1,nbend_kcc_Tb(iti)
8059 thybt1(j)=v1bend_chyb(j,iti)
8061 sumth1thyb=tschebyshev
8062 & (1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8063 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8065 ihelp=nbend_kcc_Tb(iti)-1
8066 gradthybt1=gradtschebyshev
8067 & (0,ihelp,thybt1(1),costhet)
8068 etheta=etheta+sumth1thyb
8069 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8070 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*
8071 & gradthybt1*sinthet*(-0.5d0)
8073 if (tor_mode.ne.2) then
8075 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8076 do i=ithetaconstr_start,ithetaconstr_end
8077 itheta=itheta_constr(i)
8078 thetiii=theta(itheta)
8079 difi=pinorm(thetiii-theta_constr0(i))
8080 if (difi.gt.theta_drange(i)) then
8081 difi=difi-theta_drange(i)
8082 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8083 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8084 & +for_thet_constr(i)*difi**3
8085 else if (difi.lt.-drange(i)) then
8087 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8088 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8089 & +for_thet_constr(i)*difi**3
8093 if (energy_dec) then
8094 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8095 & i,itheta,rad2deg*thetiii,
8096 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8097 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8098 & gloc(itheta+nphi-2,icg)
8104 c------------------------------------------------------------------------------
8105 subroutine eback_sc_corr(esccor)
8106 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8107 c conformational states; temporarily implemented as differences
8108 c between UNRES torsional potentials (dependent on three types of
8109 c residues) and the torsional potentials dependent on all 20 types
8110 c of residues computed from AM1 energy surfaces of terminally-blocked
8111 c amino-acid residues.
8112 implicit real*8 (a-h,o-z)
8113 include 'DIMENSIONS'
8114 include 'COMMON.VAR'
8115 include 'COMMON.GEO'
8116 include 'COMMON.LOCAL'
8117 include 'COMMON.TORSION'
8118 include 'COMMON.SCCOR'
8119 include 'COMMON.INTERACT'
8120 include 'COMMON.DERIV'
8121 include 'COMMON.CHAIN'
8122 include 'COMMON.NAMES'
8123 include 'COMMON.IOUNITS'
8124 include 'COMMON.FFIELD'
8125 include 'COMMON.CONTROL'
8127 C Set lprn=.true. for debugging
8130 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8132 do i=itau_start,itau_end
8133 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8135 isccori=isccortyp(itype(i-2))
8136 isccori1=isccortyp(itype(i-1))
8137 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8139 do intertyp=1,3 !intertyp
8140 cc Added 09 May 2012 (Adasko)
8141 cc Intertyp means interaction type of backbone mainchain correlation:
8142 c 1 = SC...Ca...Ca...Ca
8143 c 2 = Ca...Ca...Ca...SC
8144 c 3 = SC...Ca...Ca...SCi
8146 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8147 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8148 & (itype(i-1).eq.ntyp1)))
8149 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8150 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8151 & .or.(itype(i).eq.ntyp1)))
8152 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8153 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8154 & (itype(i-3).eq.ntyp1)))) cycle
8155 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8156 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8158 do j=1,nterm_sccor(isccori,isccori1)
8159 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8160 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8161 cosphi=dcos(j*tauangle(intertyp,i))
8162 sinphi=dsin(j*tauangle(intertyp,i))
8163 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8164 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8166 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8167 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8169 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8170 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8171 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8172 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8173 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8179 c----------------------------------------------------------------------------
8180 subroutine multibody(ecorr)
8181 C This subroutine calculates multi-body contributions to energy following
8182 C the idea of Skolnick et al. If side chains I and J make a contact and
8183 C at the same time side chains I+1 and J+1 make a contact, an extra
8184 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8185 implicit real*8 (a-h,o-z)
8186 include 'DIMENSIONS'
8187 include 'COMMON.IOUNITS'
8188 include 'COMMON.DERIV'
8189 include 'COMMON.INTERACT'
8190 include 'COMMON.CONTACTS'
8191 double precision gx(3),gx1(3)
8194 C Set lprn=.true. for debugging
8198 write (iout,'(a)') 'Contact function values:'
8200 write (iout,'(i2,20(1x,i2,f10.5))')
8201 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8216 num_conti=num_cont(i)
8217 num_conti1=num_cont(i1)
8222 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8223 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8224 cd & ' ishift=',ishift
8225 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8226 C The system gains extra energy.
8227 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8228 endif ! j1==j+-ishift
8237 c------------------------------------------------------------------------------
8238 double precision function esccorr(i,j,k,l,jj,kk)
8239 implicit real*8 (a-h,o-z)
8240 include 'DIMENSIONS'
8241 include 'COMMON.IOUNITS'
8242 include 'COMMON.DERIV'
8243 include 'COMMON.INTERACT'
8244 include 'COMMON.CONTACTS'
8245 include 'COMMON.SHIELD'
8246 double precision gx(3),gx1(3)
8251 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8252 C Calculate the multi-body contribution to energy.
8253 C Calculate multi-body contributions to the gradient.
8254 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8255 cd & k,l,(gacont(m,kk,k),m=1,3)
8257 gx(m) =ekl*gacont(m,jj,i)
8258 gx1(m)=eij*gacont(m,kk,k)
8259 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8260 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8261 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8262 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8266 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8271 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8277 c------------------------------------------------------------------------------
8278 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8279 C This subroutine calculates multi-body contributions to hydrogen-bonding
8280 implicit real*8 (a-h,o-z)
8281 include 'DIMENSIONS'
8282 include 'COMMON.IOUNITS'
8285 parameter (max_cont=maxconts)
8286 parameter (max_dim=26)
8287 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8288 double precision zapas(max_dim,maxconts,max_fg_procs),
8289 & zapas_recv(max_dim,maxconts,max_fg_procs)
8290 common /przechowalnia/ zapas
8291 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8292 & status_array(MPI_STATUS_SIZE,maxconts*2)
8294 include 'COMMON.SETUP'
8295 include 'COMMON.FFIELD'
8296 include 'COMMON.DERIV'
8297 include 'COMMON.INTERACT'
8298 include 'COMMON.CONTACTS'
8299 include 'COMMON.CONTROL'
8300 include 'COMMON.LOCAL'
8301 double precision gx(3),gx1(3),time00
8304 C Set lprn=.true. for debugging
8309 if (nfgtasks.le.1) goto 30
8311 write (iout,'(a)') 'Contact function values before RECEIVE:'
8313 write (iout,'(2i3,50(1x,i2,f5.2))')
8314 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8315 & j=1,num_cont_hb(i))
8319 do i=1,ntask_cont_from
8322 do i=1,ntask_cont_to
8325 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8327 C Make the list of contacts to send to send to other procesors
8328 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8330 do i=iturn3_start,iturn3_end
8331 c write (iout,*) "make contact list turn3",i," num_cont",
8333 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8335 do i=iturn4_start,iturn4_end
8336 c write (iout,*) "make contact list turn4",i," num_cont",
8338 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8342 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8344 do j=1,num_cont_hb(i)
8347 iproc=iint_sent_local(k,jjc,ii)
8348 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8349 if (iproc.gt.0) then
8350 ncont_sent(iproc)=ncont_sent(iproc)+1
8351 nn=ncont_sent(iproc)
8353 zapas(2,nn,iproc)=jjc
8354 zapas(3,nn,iproc)=facont_hb(j,i)
8355 zapas(4,nn,iproc)=ees0p(j,i)
8356 zapas(5,nn,iproc)=ees0m(j,i)
8357 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8358 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8359 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8360 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8361 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8362 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8363 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8364 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8365 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8366 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8367 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8368 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8369 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8370 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8371 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8372 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8373 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8374 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8375 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8376 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8377 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8384 & "Numbers of contacts to be sent to other processors",
8385 & (ncont_sent(i),i=1,ntask_cont_to)
8386 write (iout,*) "Contacts sent"
8387 do ii=1,ntask_cont_to
8389 iproc=itask_cont_to(ii)
8390 write (iout,*) nn," contacts to processor",iproc,
8391 & " of CONT_TO_COMM group"
8393 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8401 CorrelID1=nfgtasks+fg_rank+1
8403 C Receive the numbers of needed contacts from other processors
8404 do ii=1,ntask_cont_from
8405 iproc=itask_cont_from(ii)
8407 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8408 & FG_COMM,req(ireq),IERR)
8410 c write (iout,*) "IRECV ended"
8412 C Send the number of contacts needed by other processors
8413 do ii=1,ntask_cont_to
8414 iproc=itask_cont_to(ii)
8416 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8417 & FG_COMM,req(ireq),IERR)
8419 c write (iout,*) "ISEND ended"
8420 c write (iout,*) "number of requests (nn)",ireq
8423 & call MPI_Waitall(ireq,req,status_array,ierr)
8425 c & "Numbers of contacts to be received from other processors",
8426 c & (ncont_recv(i),i=1,ntask_cont_from)
8430 do ii=1,ntask_cont_from
8431 iproc=itask_cont_from(ii)
8433 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8434 c & " of CONT_TO_COMM group"
8438 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8439 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8440 c write (iout,*) "ireq,req",ireq,req(ireq)
8443 C Send the contacts to processors that need them
8444 do ii=1,ntask_cont_to
8445 iproc=itask_cont_to(ii)
8447 c write (iout,*) nn," contacts to processor",iproc,
8448 c & " of CONT_TO_COMM group"
8451 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8452 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8453 c write (iout,*) "ireq,req",ireq,req(ireq)
8455 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8459 c write (iout,*) "number of requests (contacts)",ireq
8460 c write (iout,*) "req",(req(i),i=1,4)
8463 & call MPI_Waitall(ireq,req,status_array,ierr)
8464 do iii=1,ntask_cont_from
8465 iproc=itask_cont_from(iii)
8468 write (iout,*) "Received",nn," contacts from processor",iproc,
8469 & " of CONT_FROM_COMM group"
8472 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8477 ii=zapas_recv(1,i,iii)
8478 c Flag the received contacts to prevent double-counting
8479 jj=-zapas_recv(2,i,iii)
8480 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8482 nnn=num_cont_hb(ii)+1
8485 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8486 ees0p(nnn,ii)=zapas_recv(4,i,iii)
8487 ees0m(nnn,ii)=zapas_recv(5,i,iii)
8488 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8489 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8490 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8491 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8492 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8493 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8494 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8495 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8496 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8497 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8498 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8499 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8500 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8501 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8502 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8503 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8504 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8505 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8506 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8507 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8508 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8513 write (iout,'(a)') 'Contact function values after receive:'
8515 write (iout,'(2i3,50(1x,i3,f5.2))')
8516 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8517 & j=1,num_cont_hb(i))
8524 write (iout,'(a)') 'Contact function values:'
8526 write (iout,'(2i3,50(1x,i3,f5.2))')
8527 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8528 & j=1,num_cont_hb(i))
8532 C Remove the loop below after debugging !!!
8539 C Calculate the local-electrostatic correlation terms
8540 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8542 num_conti=num_cont_hb(i)
8543 num_conti1=num_cont_hb(i+1)
8550 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8551 c & ' jj=',jj,' kk=',kk
8552 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8553 & .or. j.lt.0 .and. j1.gt.0) .and.
8554 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8555 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8556 C The system gains extra energy.
8557 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8558 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8559 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8561 else if (j1.eq.j) then
8562 C Contacts I-J and I-(J+1) occur simultaneously.
8563 C The system loses extra energy.
8564 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8569 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8570 c & ' jj=',jj,' kk=',kk
8572 C Contacts I-J and (I+1)-J occur simultaneously.
8573 C The system loses extra energy.
8574 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8581 c------------------------------------------------------------------------------
8582 subroutine add_hb_contact(ii,jj,itask)
8583 implicit real*8 (a-h,o-z)
8584 include "DIMENSIONS"
8585 include "COMMON.IOUNITS"
8588 parameter (max_cont=maxconts)
8589 parameter (max_dim=26)
8590 include "COMMON.CONTACTS"
8591 double precision zapas(max_dim,maxconts,max_fg_procs),
8592 & zapas_recv(max_dim,maxconts,max_fg_procs)
8593 common /przechowalnia/ zapas
8594 integer i,j,ii,jj,iproc,itask(4),nn
8595 c write (iout,*) "itask",itask
8598 if (iproc.gt.0) then
8599 do j=1,num_cont_hb(ii)
8601 c write (iout,*) "i",ii," j",jj," jjc",jjc
8603 ncont_sent(iproc)=ncont_sent(iproc)+1
8604 nn=ncont_sent(iproc)
8605 zapas(1,nn,iproc)=ii
8606 zapas(2,nn,iproc)=jjc
8607 zapas(3,nn,iproc)=facont_hb(j,ii)
8608 zapas(4,nn,iproc)=ees0p(j,ii)
8609 zapas(5,nn,iproc)=ees0m(j,ii)
8610 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8611 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8612 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8613 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8614 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8615 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8616 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8617 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8618 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8619 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8620 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8621 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8622 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8623 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8624 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8625 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8626 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8627 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8628 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8629 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8630 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8638 c------------------------------------------------------------------------------
8639 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8641 C This subroutine calculates multi-body contributions to hydrogen-bonding
8642 implicit real*8 (a-h,o-z)
8643 include 'DIMENSIONS'
8644 include 'COMMON.IOUNITS'
8647 parameter (max_cont=maxconts)
8648 parameter (max_dim=70)
8649 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8650 double precision zapas(max_dim,maxconts,max_fg_procs),
8651 & zapas_recv(max_dim,maxconts,max_fg_procs)
8652 common /przechowalnia/ zapas
8653 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8654 & status_array(MPI_STATUS_SIZE,maxconts*2)
8656 include 'COMMON.SETUP'
8657 include 'COMMON.FFIELD'
8658 include 'COMMON.DERIV'
8659 include 'COMMON.LOCAL'
8660 include 'COMMON.INTERACT'
8661 include 'COMMON.CONTACTS'
8662 include 'COMMON.CHAIN'
8663 include 'COMMON.CONTROL'
8664 include 'COMMON.SHIELD'
8665 double precision gx(3),gx1(3)
8666 integer num_cont_hb_old(maxres)
8668 double precision eello4,eello5,eelo6,eello_turn6
8669 external eello4,eello5,eello6,eello_turn6
8670 C Set lprn=.true. for debugging
8675 num_cont_hb_old(i)=num_cont_hb(i)
8679 if (nfgtasks.le.1) goto 30
8681 write (iout,'(a)') 'Contact function values before RECEIVE:'
8683 write (iout,'(2i3,50(1x,i2,f5.2))')
8684 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8685 & j=1,num_cont_hb(i))
8689 do i=1,ntask_cont_from
8692 do i=1,ntask_cont_to
8695 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8697 C Make the list of contacts to send to send to other procesors
8698 do i=iturn3_start,iturn3_end
8699 c write (iout,*) "make contact list turn3",i," num_cont",
8701 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8703 do i=iturn4_start,iturn4_end
8704 c write (iout,*) "make contact list turn4",i," num_cont",
8706 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8710 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8712 do j=1,num_cont_hb(i)
8715 iproc=iint_sent_local(k,jjc,ii)
8716 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8717 if (iproc.ne.0) then
8718 ncont_sent(iproc)=ncont_sent(iproc)+1
8719 nn=ncont_sent(iproc)
8721 zapas(2,nn,iproc)=jjc
8722 zapas(3,nn,iproc)=d_cont(j,i)
8726 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8731 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8739 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8750 & "Numbers of contacts to be sent to other processors",
8751 & (ncont_sent(i),i=1,ntask_cont_to)
8752 write (iout,*) "Contacts sent"
8753 do ii=1,ntask_cont_to
8755 iproc=itask_cont_to(ii)
8756 write (iout,*) nn," contacts to processor",iproc,
8757 & " of CONT_TO_COMM group"
8759 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8767 CorrelID1=nfgtasks+fg_rank+1
8769 C Receive the numbers of needed contacts from other processors
8770 do ii=1,ntask_cont_from
8771 iproc=itask_cont_from(ii)
8773 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8774 & FG_COMM,req(ireq),IERR)
8776 c write (iout,*) "IRECV ended"
8778 C Send the number of contacts needed by other processors
8779 do ii=1,ntask_cont_to
8780 iproc=itask_cont_to(ii)
8782 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8783 & FG_COMM,req(ireq),IERR)
8785 c write (iout,*) "ISEND ended"
8786 c write (iout,*) "number of requests (nn)",ireq
8789 & call MPI_Waitall(ireq,req,status_array,ierr)
8791 c & "Numbers of contacts to be received from other processors",
8792 c & (ncont_recv(i),i=1,ntask_cont_from)
8796 do ii=1,ntask_cont_from
8797 iproc=itask_cont_from(ii)
8799 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8800 c & " of CONT_TO_COMM group"
8804 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8805 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8806 c write (iout,*) "ireq,req",ireq,req(ireq)
8809 C Send the contacts to processors that need them
8810 do ii=1,ntask_cont_to
8811 iproc=itask_cont_to(ii)
8813 c write (iout,*) nn," contacts to processor",iproc,
8814 c & " of CONT_TO_COMM group"
8817 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8818 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8819 c write (iout,*) "ireq,req",ireq,req(ireq)
8821 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8825 c write (iout,*) "number of requests (contacts)",ireq
8826 c write (iout,*) "req",(req(i),i=1,4)
8829 & call MPI_Waitall(ireq,req,status_array,ierr)
8830 do iii=1,ntask_cont_from
8831 iproc=itask_cont_from(iii)
8834 write (iout,*) "Received",nn," contacts from processor",iproc,
8835 & " of CONT_FROM_COMM group"
8838 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8843 ii=zapas_recv(1,i,iii)
8844 c Flag the received contacts to prevent double-counting
8845 jj=-zapas_recv(2,i,iii)
8846 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8848 nnn=num_cont_hb(ii)+1
8851 d_cont(nnn,ii)=zapas_recv(3,i,iii)
8855 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8860 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8868 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8877 write (iout,'(a)') 'Contact function values after receive:'
8879 write (iout,'(2i3,50(1x,i3,5f6.3))')
8880 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8881 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8888 write (iout,'(a)') 'Contact function values:'
8890 write (iout,'(2i3,50(1x,i2,5f6.3))')
8891 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8892 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8898 C Remove the loop below after debugging !!!
8905 C Calculate the dipole-dipole interaction energies
8906 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8907 do i=iatel_s,iatel_e+1
8908 num_conti=num_cont_hb(i)
8917 C Calculate the local-electrostatic correlation terms
8918 c write (iout,*) "gradcorr5 in eello5 before loop"
8920 c write (iout,'(i5,3f10.5)')
8921 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8923 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8924 c write (iout,*) "corr loop i",i
8926 num_conti=num_cont_hb(i)
8927 num_conti1=num_cont_hb(i+1)
8934 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8935 c & ' jj=',jj,' kk=',kk
8936 c if (j1.eq.j+1 .or. j1.eq.j-1) then
8937 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8938 & .or. j.lt.0 .and. j1.gt.0) .and.
8939 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8940 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8941 C The system gains extra energy.
8943 sqd1=dsqrt(d_cont(jj,i))
8944 sqd2=dsqrt(d_cont(kk,i1))
8945 sred_geom = sqd1*sqd2
8946 IF (sred_geom.lt.cutoff_corr) THEN
8947 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8949 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8950 cd & ' jj=',jj,' kk=',kk
8951 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8952 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8954 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8955 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8958 cd write (iout,*) 'sred_geom=',sred_geom,
8959 cd & ' ekont=',ekont,' fprim=',fprimcont,
8960 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8961 cd write (iout,*) "g_contij",g_contij
8962 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8963 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8964 call calc_eello(i,jp,i+1,jp1,jj,kk)
8965 if (wcorr4.gt.0.0d0)
8966 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8967 CC & *fac_shield(i)**2*fac_shield(j)**2
8968 if (energy_dec.and.wcorr4.gt.0.0d0)
8969 1 write (iout,'(a6,4i5,0pf7.3)')
8970 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8971 c write (iout,*) "gradcorr5 before eello5"
8973 c write (iout,'(i5,3f10.5)')
8974 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8976 if (wcorr5.gt.0.0d0)
8977 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8978 c write (iout,*) "gradcorr5 after eello5"
8980 c write (iout,'(i5,3f10.5)')
8981 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
8983 if (energy_dec.and.wcorr5.gt.0.0d0)
8984 1 write (iout,'(a6,4i5,0pf7.3)')
8985 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8986 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8987 cd write(2,*)'ijkl',i,jp,i+1,jp1
8988 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8989 & .or. wturn6.eq.0.0d0))then
8990 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8991 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8992 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8993 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8994 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8995 cd & 'ecorr6=',ecorr6
8996 cd write (iout,'(4e15.5)') sred_geom,
8997 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8998 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8999 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9000 else if (wturn6.gt.0.0d0
9001 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9002 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9003 eturn6=eturn6+eello_turn6(i,jj,kk)
9004 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9005 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9006 cd write (2,*) 'multibody_eello:eturn6',eturn6
9015 num_cont_hb(i)=num_cont_hb_old(i)
9017 c write (iout,*) "gradcorr5 in eello5"
9019 c write (iout,'(i5,3f10.5)')
9020 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9024 c------------------------------------------------------------------------------
9025 subroutine add_hb_contact_eello(ii,jj,itask)
9026 implicit real*8 (a-h,o-z)
9027 include "DIMENSIONS"
9028 include "COMMON.IOUNITS"
9031 parameter (max_cont=maxconts)
9032 parameter (max_dim=70)
9033 include "COMMON.CONTACTS"
9034 double precision zapas(max_dim,maxconts,max_fg_procs),
9035 & zapas_recv(max_dim,maxconts,max_fg_procs)
9036 common /przechowalnia/ zapas
9037 integer i,j,ii,jj,iproc,itask(4),nn
9038 c write (iout,*) "itask",itask
9041 if (iproc.gt.0) then
9042 do j=1,num_cont_hb(ii)
9044 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9046 ncont_sent(iproc)=ncont_sent(iproc)+1
9047 nn=ncont_sent(iproc)
9048 zapas(1,nn,iproc)=ii
9049 zapas(2,nn,iproc)=jjc
9050 zapas(3,nn,iproc)=d_cont(j,ii)
9054 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9059 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9067 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9079 c------------------------------------------------------------------------------
9080 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9081 implicit real*8 (a-h,o-z)
9082 include 'DIMENSIONS'
9083 include 'COMMON.IOUNITS'
9084 include 'COMMON.DERIV'
9085 include 'COMMON.INTERACT'
9086 include 'COMMON.CONTACTS'
9087 include 'COMMON.SHIELD'
9088 include 'COMMON.CONTROL'
9089 double precision gx(3),gx1(3)
9092 C print *,"wchodze",fac_shield(i),shield_mode
9100 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9102 C & fac_shield(i)**2*fac_shield(j)**2
9103 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9104 C Following 4 lines for diagnostics.
9109 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9110 c & 'Contacts ',i,j,
9111 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9112 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9114 C Calculate the multi-body contribution to energy.
9115 C ecorr=ecorr+ekont*ees
9116 C Calculate multi-body contributions to the gradient.
9117 coeffpees0pij=coeffp*ees0pij
9118 coeffmees0mij=coeffm*ees0mij
9119 coeffpees0pkl=coeffp*ees0pkl
9120 coeffmees0mkl=coeffm*ees0mkl
9122 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9123 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9124 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9125 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9126 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9127 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9128 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9129 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9130 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9131 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9132 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9133 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9134 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9135 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9136 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9137 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9138 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9139 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9140 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9141 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9142 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9143 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9144 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9145 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9146 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9151 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9152 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9153 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9154 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9159 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9160 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9161 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9162 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9165 c write (iout,*) "ehbcorr",ekont*ees
9166 C print *,ekont,ees,i,k
9168 C now gradient over shielding
9170 if (shield_mode.gt.0) then
9173 C print *,i,j,fac_shield(i),fac_shield(j),
9174 C &fac_shield(k),fac_shield(l)
9175 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9176 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9177 do ilist=1,ishield_list(i)
9178 iresshield=shield_list(ilist,i)
9180 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9182 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9184 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9185 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9189 do ilist=1,ishield_list(j)
9190 iresshield=shield_list(ilist,j)
9192 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9194 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9196 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9197 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9202 do ilist=1,ishield_list(k)
9203 iresshield=shield_list(ilist,k)
9205 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9207 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9209 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9210 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9214 do ilist=1,ishield_list(l)
9215 iresshield=shield_list(ilist,l)
9217 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9219 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9221 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9222 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9226 C print *,gshieldx(m,iresshield)
9228 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9229 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9230 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9231 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9232 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9233 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9234 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9235 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9237 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9238 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9239 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9240 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9241 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9242 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9243 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9244 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9252 C---------------------------------------------------------------------------
9253 subroutine dipole(i,j,jj)
9254 implicit real*8 (a-h,o-z)
9255 include 'DIMENSIONS'
9256 include 'COMMON.IOUNITS'
9257 include 'COMMON.CHAIN'
9258 include 'COMMON.FFIELD'
9259 include 'COMMON.DERIV'
9260 include 'COMMON.INTERACT'
9261 include 'COMMON.CONTACTS'
9262 include 'COMMON.TORSION'
9263 include 'COMMON.VAR'
9264 include 'COMMON.GEO'
9265 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9267 iti1 = itortyp(itype(i+1))
9268 if (j.lt.nres-1) then
9269 itj1 = itype2loc(itype(j+1))
9274 dipi(iii,1)=Ub2(iii,i)
9275 dipderi(iii)=Ub2der(iii,i)
9276 dipi(iii,2)=b1(iii,i+1)
9277 dipj(iii,1)=Ub2(iii,j)
9278 dipderj(iii)=Ub2der(iii,j)
9279 dipj(iii,2)=b1(iii,j+1)
9283 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9286 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9293 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9297 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9302 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9303 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9305 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9307 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9309 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9314 C---------------------------------------------------------------------------
9315 subroutine calc_eello(i,j,k,l,jj,kk)
9317 C This subroutine computes matrices and vectors needed to calculate
9318 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9320 implicit real*8 (a-h,o-z)
9321 include 'DIMENSIONS'
9322 include 'COMMON.IOUNITS'
9323 include 'COMMON.CHAIN'
9324 include 'COMMON.DERIV'
9325 include 'COMMON.INTERACT'
9326 include 'COMMON.CONTACTS'
9327 include 'COMMON.TORSION'
9328 include 'COMMON.VAR'
9329 include 'COMMON.GEO'
9330 include 'COMMON.FFIELD'
9331 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9332 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9335 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9336 cd & ' jj=',jj,' kk=',kk
9337 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9338 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9339 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9342 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9343 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9346 call transpose2(aa1(1,1),aa1t(1,1))
9347 call transpose2(aa2(1,1),aa2t(1,1))
9350 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9351 & aa1tder(1,1,lll,kkk))
9352 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9353 & aa2tder(1,1,lll,kkk))
9357 C parallel orientation of the two CA-CA-CA frames.
9359 iti=itype2loc(itype(i))
9363 itk1=itype2loc(itype(k+1))
9364 itj=itype2loc(itype(j))
9365 if (l.lt.nres-1) then
9366 itl1=itype2loc(itype(l+1))
9370 C A1 kernel(j+1) A2T
9372 cd write (iout,'(3f10.5,5x,3f10.5)')
9373 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9375 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9376 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9377 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9378 C Following matrices are needed only for 6-th order cumulants
9379 IF (wcorr6.gt.0.0d0) THEN
9380 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9381 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9382 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9383 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9384 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9385 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9386 & ADtEAderx(1,1,1,1,1,1))
9388 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9389 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9390 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9391 & ADtEA1derx(1,1,1,1,1,1))
9393 C End 6-th order cumulants
9396 cd write (2,*) 'In calc_eello6'
9398 cd write (2,*) 'iii=',iii
9400 cd write (2,*) 'kkk=',kkk
9402 cd write (2,'(3(2f10.5),5x)')
9403 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9408 call transpose2(EUgder(1,1,k),auxmat(1,1))
9409 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9410 call transpose2(EUg(1,1,k),auxmat(1,1))
9411 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9412 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9416 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9417 & EAEAderx(1,1,lll,kkk,iii,1))
9421 C A1T kernel(i+1) A2
9422 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9423 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9424 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9425 C Following matrices are needed only for 6-th order cumulants
9426 IF (wcorr6.gt.0.0d0) THEN
9427 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9428 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9429 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9430 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9431 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9432 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9433 & ADtEAderx(1,1,1,1,1,2))
9434 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9435 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9436 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9437 & ADtEA1derx(1,1,1,1,1,2))
9439 C End 6-th order cumulants
9440 call transpose2(EUgder(1,1,l),auxmat(1,1))
9441 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9442 call transpose2(EUg(1,1,l),auxmat(1,1))
9443 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9444 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9448 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9449 & EAEAderx(1,1,lll,kkk,iii,2))
9454 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9455 C They are needed only when the fifth- or the sixth-order cumulants are
9457 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9458 call transpose2(AEA(1,1,1),auxmat(1,1))
9459 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9460 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9461 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9462 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9463 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9464 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9465 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9466 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9467 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9468 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9469 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9470 call transpose2(AEA(1,1,2),auxmat(1,1))
9471 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9472 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9473 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9474 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9475 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9476 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9477 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9478 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9479 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9480 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9481 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9482 C Calculate the Cartesian derivatives of the vectors.
9486 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9487 call matvec2(auxmat(1,1),b1(1,i),
9488 & AEAb1derx(1,lll,kkk,iii,1,1))
9489 call matvec2(auxmat(1,1),Ub2(1,i),
9490 & AEAb2derx(1,lll,kkk,iii,1,1))
9491 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9492 & AEAb1derx(1,lll,kkk,iii,2,1))
9493 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9494 & AEAb2derx(1,lll,kkk,iii,2,1))
9495 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9496 call matvec2(auxmat(1,1),b1(1,j),
9497 & AEAb1derx(1,lll,kkk,iii,1,2))
9498 call matvec2(auxmat(1,1),Ub2(1,j),
9499 & AEAb2derx(1,lll,kkk,iii,1,2))
9500 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9501 & AEAb1derx(1,lll,kkk,iii,2,2))
9502 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9503 & AEAb2derx(1,lll,kkk,iii,2,2))
9510 C Antiparallel orientation of the two CA-CA-CA frames.
9512 iti=itype2loc(itype(i))
9516 itk1=itype2loc(itype(k+1))
9517 itl=itype2loc(itype(l))
9518 itj=itype2loc(itype(j))
9519 if (j.lt.nres-1) then
9520 itj1=itype2loc(itype(j+1))
9524 C A2 kernel(j-1)T A1T
9525 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9526 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9527 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9528 C Following matrices are needed only for 6-th order cumulants
9529 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9530 & j.eq.i+4 .and. l.eq.i+3)) THEN
9531 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9532 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9533 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9534 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9535 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9536 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9537 & ADtEAderx(1,1,1,1,1,1))
9538 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9539 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9540 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9541 & ADtEA1derx(1,1,1,1,1,1))
9543 C End 6-th order cumulants
9544 call transpose2(EUgder(1,1,k),auxmat(1,1))
9545 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9546 call transpose2(EUg(1,1,k),auxmat(1,1))
9547 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9548 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9552 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9553 & EAEAderx(1,1,lll,kkk,iii,1))
9557 C A2T kernel(i+1)T A1
9558 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9559 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9560 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9561 C Following matrices are needed only for 6-th order cumulants
9562 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9563 & j.eq.i+4 .and. l.eq.i+3)) THEN
9564 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9565 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9566 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9567 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9568 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9569 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9570 & ADtEAderx(1,1,1,1,1,2))
9571 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9572 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9573 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9574 & ADtEA1derx(1,1,1,1,1,2))
9576 C End 6-th order cumulants
9577 call transpose2(EUgder(1,1,j),auxmat(1,1))
9578 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9579 call transpose2(EUg(1,1,j),auxmat(1,1))
9580 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9581 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9585 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9586 & EAEAderx(1,1,lll,kkk,iii,2))
9591 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9592 C They are needed only when the fifth- or the sixth-order cumulants are
9594 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9595 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9596 call transpose2(AEA(1,1,1),auxmat(1,1))
9597 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9598 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9599 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9600 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9601 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9602 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9603 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9604 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9605 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9606 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9607 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9608 call transpose2(AEA(1,1,2),auxmat(1,1))
9609 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9610 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9611 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9612 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9613 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9614 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9615 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9616 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9617 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9618 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9619 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9620 C Calculate the Cartesian derivatives of the vectors.
9624 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9625 call matvec2(auxmat(1,1),b1(1,i),
9626 & AEAb1derx(1,lll,kkk,iii,1,1))
9627 call matvec2(auxmat(1,1),Ub2(1,i),
9628 & AEAb2derx(1,lll,kkk,iii,1,1))
9629 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9630 & AEAb1derx(1,lll,kkk,iii,2,1))
9631 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9632 & AEAb2derx(1,lll,kkk,iii,2,1))
9633 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9634 call matvec2(auxmat(1,1),b1(1,l),
9635 & AEAb1derx(1,lll,kkk,iii,1,2))
9636 call matvec2(auxmat(1,1),Ub2(1,l),
9637 & AEAb2derx(1,lll,kkk,iii,1,2))
9638 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9639 & AEAb1derx(1,lll,kkk,iii,2,2))
9640 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9641 & AEAb2derx(1,lll,kkk,iii,2,2))
9650 C---------------------------------------------------------------------------
9651 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9652 & KK,KKderg,AKA,AKAderg,AKAderx)
9656 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9657 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9658 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9663 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9665 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9668 cd if (lprn) write (2,*) 'In kernel'
9670 cd if (lprn) write (2,*) 'kkk=',kkk
9672 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9673 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9675 cd write (2,*) 'lll=',lll
9676 cd write (2,*) 'iii=1'
9678 cd write (2,'(3(2f10.5),5x)')
9679 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9682 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9683 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9685 cd write (2,*) 'lll=',lll
9686 cd write (2,*) 'iii=2'
9688 cd write (2,'(3(2f10.5),5x)')
9689 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9696 C---------------------------------------------------------------------------
9697 double precision function eello4(i,j,k,l,jj,kk)
9698 implicit real*8 (a-h,o-z)
9699 include 'DIMENSIONS'
9700 include 'COMMON.IOUNITS'
9701 include 'COMMON.CHAIN'
9702 include 'COMMON.DERIV'
9703 include 'COMMON.INTERACT'
9704 include 'COMMON.CONTACTS'
9705 include 'COMMON.TORSION'
9706 include 'COMMON.VAR'
9707 include 'COMMON.GEO'
9708 double precision pizda(2,2),ggg1(3),ggg2(3)
9709 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9713 cd print *,'eello4:',i,j,k,l,jj,kk
9714 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
9715 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
9716 cold eij=facont_hb(jj,i)
9717 cold ekl=facont_hb(kk,k)
9719 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9720 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9721 gcorr_loc(k-1)=gcorr_loc(k-1)
9722 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9724 gcorr_loc(l-1)=gcorr_loc(l-1)
9725 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9727 gcorr_loc(j-1)=gcorr_loc(j-1)
9728 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9733 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9734 & -EAEAderx(2,2,lll,kkk,iii,1)
9735 cd derx(lll,kkk,iii)=0.0d0
9739 cd gcorr_loc(l-1)=0.0d0
9740 cd gcorr_loc(j-1)=0.0d0
9741 cd gcorr_loc(k-1)=0.0d0
9743 cd write (iout,*)'Contacts have occurred for peptide groups',
9744 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
9745 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9746 if (j.lt.nres-1) then
9753 if (l.lt.nres-1) then
9761 cgrad ggg1(ll)=eel4*g_contij(ll,1)
9762 cgrad ggg2(ll)=eel4*g_contij(ll,2)
9763 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9764 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9765 cgrad ghalf=0.5d0*ggg1(ll)
9766 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9767 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9768 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9769 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9770 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9771 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9772 cgrad ghalf=0.5d0*ggg2(ll)
9773 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9774 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9775 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9776 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9777 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9778 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9782 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9787 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9792 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9797 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9801 cd write (2,*) iii,gcorr_loc(iii)
9804 cd write (2,*) 'ekont',ekont
9805 cd write (iout,*) 'eello4',ekont*eel4
9808 C---------------------------------------------------------------------------
9809 double precision function eello5(i,j,k,l,jj,kk)
9810 implicit real*8 (a-h,o-z)
9811 include 'DIMENSIONS'
9812 include 'COMMON.IOUNITS'
9813 include 'COMMON.CHAIN'
9814 include 'COMMON.DERIV'
9815 include 'COMMON.INTERACT'
9816 include 'COMMON.CONTACTS'
9817 include 'COMMON.TORSION'
9818 include 'COMMON.VAR'
9819 include 'COMMON.GEO'
9820 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9821 double precision ggg1(3),ggg2(3)
9822 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9827 C /l\ / \ \ / \ / \ / C
9828 C / \ / \ \ / \ / \ / C
9829 C j| o |l1 | o | o| o | | o |o C
9830 C \ |/k\| |/ \| / |/ \| |/ \| C
9831 C \i/ \ / \ / / \ / \ C
9833 C (I) (II) (III) (IV) C
9835 C eello5_1 eello5_2 eello5_3 eello5_4 C
9837 C Antiparallel chains C
9840 C /j\ / \ \ / \ / \ / C
9841 C / \ / \ \ / \ / \ / C
9842 C j1| o |l | o | o| o | | o |o C
9843 C \ |/k\| |/ \| / |/ \| |/ \| C
9844 C \i/ \ / \ / / \ / \ C
9846 C (I) (II) (III) (IV) C
9848 C eello5_1 eello5_2 eello5_3 eello5_4 C
9850 C o denotes a local interaction, vertical lines an electrostatic interaction. C
9852 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9853 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9858 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
9860 itk=itype2loc(itype(k))
9861 itl=itype2loc(itype(l))
9862 itj=itype2loc(itype(j))
9867 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9868 cd & eel5_3_num,eel5_4_num)
9872 derx(lll,kkk,iii)=0.0d0
9876 cd eij=facont_hb(jj,i)
9877 cd ekl=facont_hb(kk,k)
9879 cd write (iout,*)'Contacts have occurred for peptide groups',
9880 cd & i,j,' fcont:',eij,' eij',' and ',k,l
9882 C Contribution from the graph I.
9883 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9884 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9885 call transpose2(EUg(1,1,k),auxmat(1,1))
9886 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9887 vv(1)=pizda(1,1)-pizda(2,2)
9888 vv(2)=pizda(1,2)+pizda(2,1)
9889 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9890 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9891 C Explicit gradient in virtual-dihedral angles.
9892 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9893 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9894 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9895 call transpose2(EUgder(1,1,k),auxmat1(1,1))
9896 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9897 vv(1)=pizda(1,1)-pizda(2,2)
9898 vv(2)=pizda(1,2)+pizda(2,1)
9899 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9900 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9901 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9902 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9903 vv(1)=pizda(1,1)-pizda(2,2)
9904 vv(2)=pizda(1,2)+pizda(2,1)
9906 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9907 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9908 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9910 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9911 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9912 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9914 C Cartesian gradient
9918 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9920 vv(1)=pizda(1,1)-pizda(2,2)
9921 vv(2)=pizda(1,2)+pizda(2,1)
9922 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9923 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9924 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9930 C Contribution from graph II
9931 call transpose2(EE(1,1,k),auxmat(1,1))
9932 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9933 vv(1)=pizda(1,1)+pizda(2,2)
9934 vv(2)=pizda(2,1)-pizda(1,2)
9935 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9936 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9937 C Explicit gradient in virtual-dihedral angles.
9938 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9939 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9940 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9941 vv(1)=pizda(1,1)+pizda(2,2)
9942 vv(2)=pizda(2,1)-pizda(1,2)
9944 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9945 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9946 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9948 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9949 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9950 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9952 C Cartesian gradient
9956 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9958 vv(1)=pizda(1,1)+pizda(2,2)
9959 vv(2)=pizda(2,1)-pizda(1,2)
9960 derx(lll,kkk,iii)=derx(lll,kkk,iii)
9961 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9962 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9970 C Parallel orientation
9971 C Contribution from graph III
9972 call transpose2(EUg(1,1,l),auxmat(1,1))
9973 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9974 vv(1)=pizda(1,1)-pizda(2,2)
9975 vv(2)=pizda(1,2)+pizda(2,1)
9976 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9977 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9978 C Explicit gradient in virtual-dihedral angles.
9979 g_corr5_loc(j-1)=g_corr5_loc(j-1)
9980 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9981 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9982 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9983 vv(1)=pizda(1,1)-pizda(2,2)
9984 vv(2)=pizda(1,2)+pizda(2,1)
9985 g_corr5_loc(k-1)=g_corr5_loc(k-1)
9986 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9987 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9988 call transpose2(EUgder(1,1,l),auxmat1(1,1))
9989 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9990 vv(1)=pizda(1,1)-pizda(2,2)
9991 vv(2)=pizda(1,2)+pizda(2,1)
9992 g_corr5_loc(l-1)=g_corr5_loc(l-1)
9993 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9994 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9995 C Cartesian gradient
9999 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10001 vv(1)=pizda(1,1)-pizda(2,2)
10002 vv(2)=pizda(1,2)+pizda(2,1)
10003 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10004 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10005 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10010 C Contribution from graph IV
10012 call transpose2(EE(1,1,l),auxmat(1,1))
10013 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10014 vv(1)=pizda(1,1)+pizda(2,2)
10015 vv(2)=pizda(2,1)-pizda(1,2)
10016 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10017 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10018 C Explicit gradient in virtual-dihedral angles.
10019 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10020 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10021 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10022 vv(1)=pizda(1,1)+pizda(2,2)
10023 vv(2)=pizda(2,1)-pizda(1,2)
10024 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10025 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10026 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10027 C Cartesian gradient
10031 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10033 vv(1)=pizda(1,1)+pizda(2,2)
10034 vv(2)=pizda(2,1)-pizda(1,2)
10035 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10036 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10037 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10042 C Antiparallel orientation
10043 C Contribution from graph III
10045 call transpose2(EUg(1,1,j),auxmat(1,1))
10046 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10047 vv(1)=pizda(1,1)-pizda(2,2)
10048 vv(2)=pizda(1,2)+pizda(2,1)
10049 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10050 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10051 C Explicit gradient in virtual-dihedral angles.
10052 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10053 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10054 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10055 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10056 vv(1)=pizda(1,1)-pizda(2,2)
10057 vv(2)=pizda(1,2)+pizda(2,1)
10058 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10059 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10060 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10061 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10062 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10063 vv(1)=pizda(1,1)-pizda(2,2)
10064 vv(2)=pizda(1,2)+pizda(2,1)
10065 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10066 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10067 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10068 C Cartesian gradient
10072 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10074 vv(1)=pizda(1,1)-pizda(2,2)
10075 vv(2)=pizda(1,2)+pizda(2,1)
10076 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10077 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10078 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10083 C Contribution from graph IV
10085 call transpose2(EE(1,1,j),auxmat(1,1))
10086 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10087 vv(1)=pizda(1,1)+pizda(2,2)
10088 vv(2)=pizda(2,1)-pizda(1,2)
10089 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10090 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10091 C Explicit gradient in virtual-dihedral angles.
10092 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10093 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10094 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10095 vv(1)=pizda(1,1)+pizda(2,2)
10096 vv(2)=pizda(2,1)-pizda(1,2)
10097 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10098 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10099 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10100 C Cartesian gradient
10104 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10106 vv(1)=pizda(1,1)+pizda(2,2)
10107 vv(2)=pizda(2,1)-pizda(1,2)
10108 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10109 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10110 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10116 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10117 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10118 cd write (2,*) 'ijkl',i,j,k,l
10119 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10120 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10122 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10123 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10124 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10125 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10126 if (j.lt.nres-1) then
10133 if (l.lt.nres-1) then
10143 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10144 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10145 C summed up outside the subrouine as for the other subroutines
10146 C handling long-range interactions. The old code is commented out
10147 C with "cgrad" to keep track of changes.
10149 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10150 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10151 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10152 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10153 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10154 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10155 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10156 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10157 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10158 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10160 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10161 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10162 cgrad ghalf=0.5d0*ggg1(ll)
10164 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10165 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10166 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10167 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10168 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10169 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10170 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10171 cgrad ghalf=0.5d0*ggg2(ll)
10173 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10174 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10175 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10176 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10177 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10178 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10183 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10184 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10189 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10190 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10196 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10201 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10205 cd write (2,*) iii,g_corr5_loc(iii)
10208 cd write (2,*) 'ekont',ekont
10209 cd write (iout,*) 'eello5',ekont*eel5
10212 c--------------------------------------------------------------------------
10213 double precision function eello6(i,j,k,l,jj,kk)
10214 implicit real*8 (a-h,o-z)
10215 include 'DIMENSIONS'
10216 include 'COMMON.IOUNITS'
10217 include 'COMMON.CHAIN'
10218 include 'COMMON.DERIV'
10219 include 'COMMON.INTERACT'
10220 include 'COMMON.CONTACTS'
10221 include 'COMMON.TORSION'
10222 include 'COMMON.VAR'
10223 include 'COMMON.GEO'
10224 include 'COMMON.FFIELD'
10225 double precision ggg1(3),ggg2(3)
10226 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10231 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10239 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10240 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10244 derx(lll,kkk,iii)=0.0d0
10248 cd eij=facont_hb(jj,i)
10249 cd ekl=facont_hb(kk,k)
10255 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10256 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10257 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10258 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10259 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10260 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10262 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10263 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10264 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10265 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10266 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10267 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10271 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10273 C If turn contributions are considered, they will be handled separately.
10274 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10275 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10276 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10277 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10278 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10279 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10280 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10282 if (j.lt.nres-1) then
10289 if (l.lt.nres-1) then
10297 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10298 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10299 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10300 cgrad ghalf=0.5d0*ggg1(ll)
10302 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10303 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10304 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10305 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10306 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10307 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10308 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10309 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10310 cgrad ghalf=0.5d0*ggg2(ll)
10311 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10313 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10314 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10315 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10316 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10317 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10318 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10323 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10324 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10329 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10330 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10336 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10341 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10345 cd write (2,*) iii,g_corr6_loc(iii)
10348 cd write (2,*) 'ekont',ekont
10349 cd write (iout,*) 'eello6',ekont*eel6
10352 c--------------------------------------------------------------------------
10353 double precision function eello6_graph1(i,j,k,l,imat,swap)
10354 implicit real*8 (a-h,o-z)
10355 include 'DIMENSIONS'
10356 include 'COMMON.IOUNITS'
10357 include 'COMMON.CHAIN'
10358 include 'COMMON.DERIV'
10359 include 'COMMON.INTERACT'
10360 include 'COMMON.CONTACTS'
10361 include 'COMMON.TORSION'
10362 include 'COMMON.VAR'
10363 include 'COMMON.GEO'
10364 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10367 common /kutas/ lprn
10368 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10370 C Parallel Antiparallel C
10376 C \ j|/k\| / \ |/k\|l / C
10377 C \ / \ / \ / \ / C
10381 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10382 itk=itype2loc(itype(k))
10383 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10384 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10385 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10386 call transpose2(EUgC(1,1,k),auxmat(1,1))
10387 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10388 vv1(1)=pizda1(1,1)-pizda1(2,2)
10389 vv1(2)=pizda1(1,2)+pizda1(2,1)
10390 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10391 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10392 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10393 s5=scalar2(vv(1),Dtobr2(1,i))
10394 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10395 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10396 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10397 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10398 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10399 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10400 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10401 & +scalar2(vv(1),Dtobr2der(1,i)))
10402 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10403 vv1(1)=pizda1(1,1)-pizda1(2,2)
10404 vv1(2)=pizda1(1,2)+pizda1(2,1)
10405 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10406 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10408 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10409 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10410 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10411 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10412 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10414 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10415 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10416 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10417 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10418 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10420 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10421 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10422 vv1(1)=pizda1(1,1)-pizda1(2,2)
10423 vv1(2)=pizda1(1,2)+pizda1(2,1)
10424 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10425 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10426 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10427 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10436 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10437 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10438 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10439 call transpose2(EUgC(1,1,k),auxmat(1,1))
10440 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10442 vv1(1)=pizda1(1,1)-pizda1(2,2)
10443 vv1(2)=pizda1(1,2)+pizda1(2,1)
10444 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10445 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10446 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10447 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10448 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10449 s5=scalar2(vv(1),Dtobr2(1,i))
10450 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10456 c----------------------------------------------------------------------------
10457 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10458 implicit real*8 (a-h,o-z)
10459 include 'DIMENSIONS'
10460 include 'COMMON.IOUNITS'
10461 include 'COMMON.CHAIN'
10462 include 'COMMON.DERIV'
10463 include 'COMMON.INTERACT'
10464 include 'COMMON.CONTACTS'
10465 include 'COMMON.TORSION'
10466 include 'COMMON.VAR'
10467 include 'COMMON.GEO'
10469 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10470 & auxvec1(2),auxvec2(2),auxmat1(2,2)
10472 common /kutas/ lprn
10473 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10475 C Parallel Antiparallel C
10481 C \ j|/k\| \ |/k\|l C
10486 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10487 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10488 C AL 7/4/01 s1 would occur in the sixth-order moment,
10489 C but not in a cluster cumulant
10491 s1=dip(1,jj,i)*dip(1,kk,k)
10493 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10494 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10495 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10496 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10497 call transpose2(EUg(1,1,k),auxmat(1,1))
10498 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10499 vv(1)=pizda(1,1)-pizda(2,2)
10500 vv(2)=pizda(1,2)+pizda(2,1)
10501 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10502 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10504 eello6_graph2=-(s1+s2+s3+s4)
10506 eello6_graph2=-(s2+s3+s4)
10508 c eello6_graph2=-s3
10509 C Derivatives in gamma(i-1)
10512 s1=dipderg(1,jj,i)*dip(1,kk,k)
10514 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10515 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10516 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10517 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10519 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10521 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10523 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10525 C Derivatives in gamma(k-1)
10527 s1=dip(1,jj,i)*dipderg(1,kk,k)
10529 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10530 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10531 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10532 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10533 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10534 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10535 vv(1)=pizda(1,1)-pizda(2,2)
10536 vv(2)=pizda(1,2)+pizda(2,1)
10537 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10539 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10541 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10543 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10544 C Derivatives in gamma(j-1) or gamma(l-1)
10547 s1=dipderg(3,jj,i)*dip(1,kk,k)
10549 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10550 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10551 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10552 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10553 vv(1)=pizda(1,1)-pizda(2,2)
10554 vv(2)=pizda(1,2)+pizda(2,1)
10555 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10558 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10560 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10563 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10564 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10566 C Derivatives in gamma(l-1) or gamma(j-1)
10569 s1=dip(1,jj,i)*dipderg(3,kk,k)
10571 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10572 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10573 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10574 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10575 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10576 vv(1)=pizda(1,1)-pizda(2,2)
10577 vv(2)=pizda(1,2)+pizda(2,1)
10578 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10581 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10583 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10586 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10587 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10589 C Cartesian derivatives.
10591 write (2,*) 'In eello6_graph2'
10593 write (2,*) 'iii=',iii
10595 write (2,*) 'kkk=',kkk
10597 write (2,'(3(2f10.5),5x)')
10598 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10608 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10610 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10613 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10615 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10616 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10618 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10619 call transpose2(EUg(1,1,k),auxmat(1,1))
10620 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10622 vv(1)=pizda(1,1)-pizda(2,2)
10623 vv(2)=pizda(1,2)+pizda(2,1)
10624 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10625 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10627 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10629 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10632 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10634 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10641 c----------------------------------------------------------------------------
10642 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10643 implicit real*8 (a-h,o-z)
10644 include 'DIMENSIONS'
10645 include 'COMMON.IOUNITS'
10646 include 'COMMON.CHAIN'
10647 include 'COMMON.DERIV'
10648 include 'COMMON.INTERACT'
10649 include 'COMMON.CONTACTS'
10650 include 'COMMON.TORSION'
10651 include 'COMMON.VAR'
10652 include 'COMMON.GEO'
10653 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10655 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10657 C Parallel Antiparallel C
10662 C /| o |o o| o |\ C
10663 C j|/k\| / |/k\|l / C
10668 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10670 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10671 C energy moment and not to the cluster cumulant.
10672 iti=itortyp(itype(i))
10673 if (j.lt.nres-1) then
10674 itj1=itype2loc(itype(j+1))
10678 itk=itype2loc(itype(k))
10679 itk1=itype2loc(itype(k+1))
10680 if (l.lt.nres-1) then
10681 itl1=itype2loc(itype(l+1))
10686 s1=dip(4,jj,i)*dip(4,kk,k)
10688 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10689 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10690 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10691 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10692 call transpose2(EE(1,1,k),auxmat(1,1))
10693 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10694 vv(1)=pizda(1,1)+pizda(2,2)
10695 vv(2)=pizda(2,1)-pizda(1,2)
10696 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10697 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10698 cd & "sum",-(s2+s3+s4)
10700 eello6_graph3=-(s1+s2+s3+s4)
10702 eello6_graph3=-(s2+s3+s4)
10704 c eello6_graph3=-s4
10705 C Derivatives in gamma(k-1)
10706 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10707 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10708 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10709 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10710 C Derivatives in gamma(l-1)
10711 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10712 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10713 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10714 vv(1)=pizda(1,1)+pizda(2,2)
10715 vv(2)=pizda(2,1)-pizda(1,2)
10716 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10717 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10718 C Cartesian derivatives.
10724 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10726 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10729 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10731 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10732 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10734 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10735 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10737 vv(1)=pizda(1,1)+pizda(2,2)
10738 vv(2)=pizda(2,1)-pizda(1,2)
10739 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10741 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10743 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10746 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10748 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10750 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10756 c----------------------------------------------------------------------------
10757 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10758 implicit real*8 (a-h,o-z)
10759 include 'DIMENSIONS'
10760 include 'COMMON.IOUNITS'
10761 include 'COMMON.CHAIN'
10762 include 'COMMON.DERIV'
10763 include 'COMMON.INTERACT'
10764 include 'COMMON.CONTACTS'
10765 include 'COMMON.TORSION'
10766 include 'COMMON.VAR'
10767 include 'COMMON.GEO'
10768 include 'COMMON.FFIELD'
10769 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10770 & auxvec1(2),auxmat1(2,2)
10772 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10774 C Parallel Antiparallel C
10779 C /| o |o o| o |\ C
10780 C \ j|/k\| \ |/k\|l C
10785 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10787 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10788 C energy moment and not to the cluster cumulant.
10789 cd write (2,*) 'eello_graph4: wturn6',wturn6
10790 iti=itype2loc(itype(i))
10791 itj=itype2loc(itype(j))
10792 if (j.lt.nres-1) then
10793 itj1=itype2loc(itype(j+1))
10797 itk=itype2loc(itype(k))
10798 if (k.lt.nres-1) then
10799 itk1=itype2loc(itype(k+1))
10803 itl=itype2loc(itype(l))
10804 if (l.lt.nres-1) then
10805 itl1=itype2loc(itype(l+1))
10809 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10810 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10811 cd & ' itl',itl,' itl1',itl1
10813 if (imat.eq.1) then
10814 s1=dip(3,jj,i)*dip(3,kk,k)
10816 s1=dip(2,jj,j)*dip(2,kk,l)
10819 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10820 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10822 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10823 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10825 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10826 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10828 call transpose2(EUg(1,1,k),auxmat(1,1))
10829 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10830 vv(1)=pizda(1,1)-pizda(2,2)
10831 vv(2)=pizda(2,1)+pizda(1,2)
10832 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10833 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10835 eello6_graph4=-(s1+s2+s3+s4)
10837 eello6_graph4=-(s2+s3+s4)
10839 C Derivatives in gamma(i-1)
10842 if (imat.eq.1) then
10843 s1=dipderg(2,jj,i)*dip(3,kk,k)
10845 s1=dipderg(4,jj,j)*dip(2,kk,l)
10848 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10850 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10851 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10853 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10854 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10856 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10857 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10858 cd write (2,*) 'turn6 derivatives'
10860 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10862 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10866 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10868 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10872 C Derivatives in gamma(k-1)
10874 if (imat.eq.1) then
10875 s1=dip(3,jj,i)*dipderg(2,kk,k)
10877 s1=dip(2,jj,j)*dipderg(4,kk,l)
10880 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10881 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10883 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10884 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10886 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10887 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10889 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10890 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10891 vv(1)=pizda(1,1)-pizda(2,2)
10892 vv(2)=pizda(2,1)+pizda(1,2)
10893 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10894 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10896 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10898 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10902 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10904 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10907 C Derivatives in gamma(j-1) or gamma(l-1)
10908 if (l.eq.j+1 .and. l.gt.1) then
10909 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10910 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10911 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10912 vv(1)=pizda(1,1)-pizda(2,2)
10913 vv(2)=pizda(2,1)+pizda(1,2)
10914 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10915 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10916 else if (j.gt.1) then
10917 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10918 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10919 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10920 vv(1)=pizda(1,1)-pizda(2,2)
10921 vv(2)=pizda(2,1)+pizda(1,2)
10922 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10923 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10924 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10926 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10929 C Cartesian derivatives.
10935 if (imat.eq.1) then
10936 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10938 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10941 if (imat.eq.1) then
10942 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10944 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10948 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10950 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10952 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10953 & b1(1,j+1),auxvec(1))
10954 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10956 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10957 & b1(1,l+1),auxvec(1))
10958 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10960 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10962 vv(1)=pizda(1,1)-pizda(2,2)
10963 vv(2)=pizda(2,1)+pizda(1,2)
10964 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10966 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10968 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10971 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10974 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10977 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10979 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10981 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10985 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10987 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10990 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10992 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11000 c----------------------------------------------------------------------------
11001 double precision function eello_turn6(i,jj,kk)
11002 implicit real*8 (a-h,o-z)
11003 include 'DIMENSIONS'
11004 include 'COMMON.IOUNITS'
11005 include 'COMMON.CHAIN'
11006 include 'COMMON.DERIV'
11007 include 'COMMON.INTERACT'
11008 include 'COMMON.CONTACTS'
11009 include 'COMMON.TORSION'
11010 include 'COMMON.VAR'
11011 include 'COMMON.GEO'
11012 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11013 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11015 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11016 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11017 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11018 C the respective energy moment and not to the cluster cumulant.
11027 iti=itype2loc(itype(i))
11028 itk=itype2loc(itype(k))
11029 itk1=itype2loc(itype(k+1))
11030 itl=itype2loc(itype(l))
11031 itj=itype2loc(itype(j))
11032 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11033 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11034 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11039 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11041 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11045 derx_turn(lll,kkk,iii)=0.0d0
11052 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11054 cd write (2,*) 'eello6_5',eello6_5
11056 call transpose2(AEA(1,1,1),auxmat(1,1))
11057 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11058 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11059 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11061 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11062 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11063 s2 = scalar2(b1(1,k),vtemp1(1))
11065 call transpose2(AEA(1,1,2),atemp(1,1))
11066 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11067 call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11068 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11070 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11071 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11072 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11074 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11075 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11076 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11077 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11078 ss13 = scalar2(b1(1,k),vtemp4(1))
11079 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11081 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11087 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11088 C Derivatives in gamma(i+2)
11092 call transpose2(AEA(1,1,1),auxmatd(1,1))
11093 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11094 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11095 call transpose2(AEAderg(1,1,2),atempd(1,1))
11096 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11097 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11099 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11100 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11101 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11107 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11108 C Derivatives in gamma(i+3)
11110 call transpose2(AEA(1,1,1),auxmatd(1,1))
11111 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11112 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11113 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11115 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11116 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11117 s2d = scalar2(b1(1,k),vtemp1d(1))
11119 call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11120 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11122 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11124 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11125 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11126 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11134 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11135 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11137 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11138 & -0.5d0*ekont*(s2d+s12d)
11140 C Derivatives in gamma(i+4)
11141 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11142 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11143 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11145 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11146 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11147 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11155 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11157 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11159 C Derivatives in gamma(i+5)
11161 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11162 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11163 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11165 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11166 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11167 s2d = scalar2(b1(1,k),vtemp1d(1))
11169 call transpose2(AEA(1,1,2),atempd(1,1))
11170 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11171 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11173 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11174 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11176 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11177 ss13d = scalar2(b1(1,k),vtemp4d(1))
11178 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11186 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11187 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11189 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11190 & -0.5d0*ekont*(s2d+s12d)
11192 C Cartesian derivatives
11197 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11198 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11199 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11201 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11202 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11204 s2d = scalar2(b1(1,k),vtemp1d(1))
11206 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11207 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11208 s8d = -(atempd(1,1)+atempd(2,2))*
11209 & scalar2(cc(1,1,itl),vtemp2(1))
11211 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11213 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11214 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11221 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11222 & - 0.5d0*(s1d+s2d)
11224 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11228 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11229 & - 0.5d0*(s8d+s12d)
11231 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11240 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11241 & achuj_tempd(1,1))
11242 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11243 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11244 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11245 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11246 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11248 ss13d = scalar2(b1(1,k),vtemp4d(1))
11249 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11250 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11254 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11255 cd & 16*eel_turn6_num
11257 if (j.lt.nres-1) then
11264 if (l.lt.nres-1) then
11272 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11273 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11274 cgrad ghalf=0.5d0*ggg1(ll)
11276 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11277 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11278 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11279 & +ekont*derx_turn(ll,2,1)
11280 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11281 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11282 & +ekont*derx_turn(ll,4,1)
11283 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11284 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11285 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11286 cgrad ghalf=0.5d0*ggg2(ll)
11288 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11289 & +ekont*derx_turn(ll,2,2)
11290 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11291 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11292 & +ekont*derx_turn(ll,4,2)
11293 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11294 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11295 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11300 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11305 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11311 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11316 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11320 cd write (2,*) iii,g_corr6_loc(iii)
11322 eello_turn6=ekont*eel_turn6
11323 cd write (2,*) 'ekont',ekont
11324 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11328 C-----------------------------------------------------------------------------
11329 double precision function scalar(u,v)
11330 !DIR$ INLINEALWAYS scalar
11332 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11335 double precision u(3),v(3)
11336 cd double precision sc
11344 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11347 crc-------------------------------------------------
11348 SUBROUTINE MATVEC2(A1,V1,V2)
11349 !DIR$ INLINEALWAYS MATVEC2
11351 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11353 implicit real*8 (a-h,o-z)
11354 include 'DIMENSIONS'
11355 DIMENSION A1(2,2),V1(2),V2(2)
11359 c 3 VI=VI+A1(I,K)*V1(K)
11363 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11364 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11369 C---------------------------------------
11370 SUBROUTINE MATMAT2(A1,A2,A3)
11372 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11374 implicit real*8 (a-h,o-z)
11375 include 'DIMENSIONS'
11376 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11377 c DIMENSION AI3(2,2)
11381 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11387 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11388 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11389 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11390 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11398 c-------------------------------------------------------------------------
11399 double precision function scalar2(u,v)
11400 !DIR$ INLINEALWAYS scalar2
11402 double precision u(2),v(2)
11403 double precision sc
11405 scalar2=u(1)*v(1)+u(2)*v(2)
11409 C-----------------------------------------------------------------------------
11411 subroutine transpose2(a,at)
11412 !DIR$ INLINEALWAYS transpose2
11414 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11417 double precision a(2,2),at(2,2)
11424 c--------------------------------------------------------------------------
11425 subroutine transpose(n,a,at)
11428 double precision a(n,n),at(n,n)
11436 C---------------------------------------------------------------------------
11437 subroutine prodmat3(a1,a2,kk,transp,prod)
11438 !DIR$ INLINEALWAYS prodmat3
11440 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11444 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11446 crc double precision auxmat(2,2),prod_(2,2)
11449 crc call transpose2(kk(1,1),auxmat(1,1))
11450 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11451 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11453 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11454 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11455 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11456 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11457 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11458 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11459 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11460 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11463 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11464 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11466 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11467 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11468 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11469 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11470 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11471 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11472 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11473 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11476 c call transpose2(a2(1,1),a2t(1,1))
11479 crc print *,((prod_(i,j),i=1,2),j=1,2)
11480 crc print *,((prod(i,j),i=1,2),j=1,2)
11484 CCC----------------------------------------------
11485 subroutine Eliptransfer(eliptran)
11486 implicit real*8 (a-h,o-z)
11487 include 'DIMENSIONS'
11488 include 'COMMON.GEO'
11489 include 'COMMON.VAR'
11490 include 'COMMON.LOCAL'
11491 include 'COMMON.CHAIN'
11492 include 'COMMON.DERIV'
11493 include 'COMMON.NAMES'
11494 include 'COMMON.INTERACT'
11495 include 'COMMON.IOUNITS'
11496 include 'COMMON.CALC'
11497 include 'COMMON.CONTROL'
11498 include 'COMMON.SPLITELE'
11499 include 'COMMON.SBRIDGE'
11500 C this is done by Adasko
11501 C print *,"wchodze"
11502 C structure of box:
11504 C--bordliptop-- buffore starts
11505 C--bufliptop--- here true lipid starts
11507 C--buflipbot--- lipid ends buffore starts
11508 C--bordlipbot--buffore ends
11510 do i=ilip_start,ilip_end
11512 if (itype(i).eq.ntyp1) cycle
11514 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11515 if (positi.le.0.0) positi=positi+boxzsize
11517 C first for peptide groups
11518 c for each residue check if it is in lipid or lipid water border area
11519 if ((positi.gt.bordlipbot)
11520 &.and.(positi.lt.bordliptop)) then
11521 C the energy transfer exist
11522 if (positi.lt.buflipbot) then
11523 C what fraction I am in
11525 & ((positi-bordlipbot)/lipbufthick)
11526 C lipbufthick is thickenes of lipid buffore
11527 sslip=sscalelip(fracinbuf)
11528 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11529 eliptran=eliptran+sslip*pepliptran
11530 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11531 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11532 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11534 C print *,"doing sccale for lower part"
11535 C print *,i,sslip,fracinbuf,ssgradlip
11536 elseif (positi.gt.bufliptop) then
11537 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11538 sslip=sscalelip(fracinbuf)
11539 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11540 eliptran=eliptran+sslip*pepliptran
11541 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11542 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11543 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11544 C print *, "doing sscalefor top part"
11545 C print *,i,sslip,fracinbuf,ssgradlip
11547 eliptran=eliptran+pepliptran
11548 C print *,"I am in true lipid"
11551 C eliptran=elpitran+0.0 ! I am in water
11554 C print *, "nic nie bylo w lipidzie?"
11555 C now multiply all by the peptide group transfer factor
11556 C eliptran=eliptran*pepliptran
11557 C now the same for side chains
11559 do i=ilip_start,ilip_end
11560 if (itype(i).eq.ntyp1) cycle
11561 positi=(mod(c(3,i+nres),boxzsize))
11562 if (positi.le.0) positi=positi+boxzsize
11563 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11564 c for each residue check if it is in lipid or lipid water border area
11565 C respos=mod(c(3,i+nres),boxzsize)
11566 C print *,positi,bordlipbot,buflipbot
11567 if ((positi.gt.bordlipbot)
11568 & .and.(positi.lt.bordliptop)) then
11569 C the energy transfer exist
11570 if (positi.lt.buflipbot) then
11572 & ((positi-bordlipbot)/lipbufthick)
11573 C lipbufthick is thickenes of lipid buffore
11574 sslip=sscalelip(fracinbuf)
11575 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11576 eliptran=eliptran+sslip*liptranene(itype(i))
11577 gliptranx(3,i)=gliptranx(3,i)
11578 &+ssgradlip*liptranene(itype(i))
11579 gliptranc(3,i-1)= gliptranc(3,i-1)
11580 &+ssgradlip*liptranene(itype(i))
11581 C print *,"doing sccale for lower part"
11582 elseif (positi.gt.bufliptop) then
11584 &((bordliptop-positi)/lipbufthick)
11585 sslip=sscalelip(fracinbuf)
11586 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11587 eliptran=eliptran+sslip*liptranene(itype(i))
11588 gliptranx(3,i)=gliptranx(3,i)
11589 &+ssgradlip*liptranene(itype(i))
11590 gliptranc(3,i-1)= gliptranc(3,i-1)
11591 &+ssgradlip*liptranene(itype(i))
11592 C print *, "doing sscalefor top part",sslip,fracinbuf
11594 eliptran=eliptran+liptranene(itype(i))
11595 C print *,"I am in true lipid"
11597 endif ! if in lipid or buffor
11599 C eliptran=elpitran+0.0 ! I am in water
11603 C---------------------------------------------------------
11604 C AFM soubroutine for constant force
11605 subroutine AFMforce(Eafmforce)
11606 implicit real*8 (a-h,o-z)
11607 include 'DIMENSIONS'
11608 include 'COMMON.GEO'
11609 include 'COMMON.VAR'
11610 include 'COMMON.LOCAL'
11611 include 'COMMON.CHAIN'
11612 include 'COMMON.DERIV'
11613 include 'COMMON.NAMES'
11614 include 'COMMON.INTERACT'
11615 include 'COMMON.IOUNITS'
11616 include 'COMMON.CALC'
11617 include 'COMMON.CONTROL'
11618 include 'COMMON.SPLITELE'
11619 include 'COMMON.SBRIDGE'
11624 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11625 dist=dist+diffafm(i)**2
11628 Eafmforce=-forceAFMconst*(dist-distafminit)
11630 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11631 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11633 C print *,'AFM',Eafmforce
11636 C---------------------------------------------------------
11637 C AFM subroutine with pseudoconstant velocity
11638 subroutine AFMvel(Eafmforce)
11639 implicit real*8 (a-h,o-z)
11640 include 'DIMENSIONS'
11641 include 'COMMON.GEO'
11642 include 'COMMON.VAR'
11643 include 'COMMON.LOCAL'
11644 include 'COMMON.CHAIN'
11645 include 'COMMON.DERIV'
11646 include 'COMMON.NAMES'
11647 include 'COMMON.INTERACT'
11648 include 'COMMON.IOUNITS'
11649 include 'COMMON.CALC'
11650 include 'COMMON.CONTROL'
11651 include 'COMMON.SPLITELE'
11652 include 'COMMON.SBRIDGE'
11654 C Only for check grad COMMENT if not used for checkgrad
11656 C--------------------------------------------------------
11657 C print *,"wchodze"
11661 diffafm(i)=c(i,afmend)-c(i,afmbeg)
11662 dist=dist+diffafm(i)**2
11665 Eafmforce=0.5d0*forceAFMconst
11666 & *(distafminit+totTafm*velAFMconst-dist)**2
11667 C Eafmforce=-forceAFMconst*(dist-distafminit)
11669 gradafm(i,afmend-1)=-forceAFMconst*
11670 &(distafminit+totTafm*velAFMconst-dist)
11672 gradafm(i,afmbeg-1)=forceAFMconst*
11673 &(distafminit+totTafm*velAFMconst-dist)
11676 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11679 C-----------------------------------------------------------
11680 C first for shielding is setting of function of side-chains
11681 subroutine set_shield_fac
11682 implicit real*8 (a-h,o-z)
11683 include 'DIMENSIONS'
11684 include 'COMMON.CHAIN'
11685 include 'COMMON.DERIV'
11686 include 'COMMON.IOUNITS'
11687 include 'COMMON.SHIELD'
11688 include 'COMMON.INTERACT'
11689 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11690 double precision div77_81/0.974996043d0/,
11691 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11693 C the vector between center of side_chain and peptide group
11694 double precision pep_side(3),long,side_calf(3),
11695 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11696 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11697 C the line belowe needs to be changed for FGPROC>1
11699 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11701 Cif there two consequtive dummy atoms there is no peptide group between them
11702 C the line below has to be changed for FGPROC>1
11705 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11709 C first lets set vector conecting the ithe side-chain with kth side-chain
11710 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11711 C pep_side(j)=2.0d0
11712 C and vector conecting the side-chain with its proper calfa
11713 side_calf(j)=c(j,k+nres)-c(j,k)
11714 C side_calf(j)=2.0d0
11715 pept_group(j)=c(j,i)-c(j,i+1)
11716 C lets have their lenght
11717 dist_pep_side=pep_side(j)**2+dist_pep_side
11718 dist_side_calf=dist_side_calf+side_calf(j)**2
11719 dist_pept_group=dist_pept_group+pept_group(j)**2
11721 dist_pep_side=dsqrt(dist_pep_side)
11722 dist_pept_group=dsqrt(dist_pept_group)
11723 dist_side_calf=dsqrt(dist_side_calf)
11725 pep_side_norm(j)=pep_side(j)/dist_pep_side
11726 side_calf_norm(j)=dist_side_calf
11728 C now sscale fraction
11729 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11730 C print *,buff_shield,"buff"
11732 if (sh_frac_dist.le.0.0) cycle
11733 C If we reach here it means that this side chain reaches the shielding sphere
11734 C Lets add him to the list for gradient
11735 ishield_list(i)=ishield_list(i)+1
11736 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11737 C this list is essential otherwise problem would be O3
11738 shield_list(ishield_list(i),i)=k
11739 C Lets have the sscale value
11740 if (sh_frac_dist.gt.1.0) then
11741 scale_fac_dist=1.0d0
11743 sh_frac_dist_grad(j)=0.0d0
11746 scale_fac_dist=-sh_frac_dist*sh_frac_dist
11747 & *(2.0*sh_frac_dist-3.0d0)
11748 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11749 & /dist_pep_side/buff_shield*0.5
11750 C remember for the final gradient multiply sh_frac_dist_grad(j)
11751 C for side_chain by factor -2 !
11753 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11754 C print *,"jestem",scale_fac_dist,fac_help_scale,
11755 C & sh_frac_dist_grad(j)
11758 C if ((i.eq.3).and.(k.eq.2)) then
11759 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11763 C this is what is now we have the distance scaling now volume...
11764 short=short_r_sidechain(itype(k))
11765 long=long_r_sidechain(itype(k))
11766 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11769 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11770 C costhet_fac=0.0d0
11772 costhet_grad(j)=costhet_fac*pep_side(j)
11774 C remember for the final gradient multiply costhet_grad(j)
11775 C for side_chain by factor -2 !
11776 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11777 C pep_side0pept_group is vector multiplication
11778 pep_side0pept_group=0.0
11780 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11782 cosalfa=(pep_side0pept_group/
11783 & (dist_pep_side*dist_side_calf))
11784 fac_alfa_sin=1.0-cosalfa**2
11785 fac_alfa_sin=dsqrt(fac_alfa_sin)
11786 rkprim=fac_alfa_sin*(long-short)+short
11788 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11789 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11792 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11793 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11794 &*(long-short)/fac_alfa_sin*cosalfa/
11795 &((dist_pep_side*dist_side_calf))*
11796 &((side_calf(j))-cosalfa*
11797 &((pep_side(j)/dist_pep_side)*dist_side_calf))
11799 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11800 &*(long-short)/fac_alfa_sin*cosalfa
11801 &/((dist_pep_side*dist_side_calf))*
11803 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11806 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11809 C now the gradient...
11810 C grad_shield is gradient of Calfa for peptide groups
11811 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11813 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11814 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11816 grad_shield(j,i)=grad_shield(j,i)
11817 C gradient po skalowaniu
11818 & +(sh_frac_dist_grad(j)
11819 C gradient po costhet
11820 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11821 &-scale_fac_dist*(cosphi_grad_long(j))
11822 &/(1.0-cosphi) )*div77_81
11824 C grad_shield_side is Cbeta sidechain gradient
11825 grad_shield_side(j,ishield_list(i),i)=
11826 & (sh_frac_dist_grad(j)*-2.0d0
11827 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11828 & +scale_fac_dist*(cosphi_grad_long(j))
11829 & *2.0d0/(1.0-cosphi))
11830 & *div77_81*VofOverlap
11832 grad_shield_loc(j,ishield_list(i),i)=
11833 & scale_fac_dist*cosphi_grad_loc(j)
11834 & *2.0d0/(1.0-cosphi)
11835 & *div77_81*VofOverlap
11837 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11839 fac_shield(i)=VolumeTotal*div77_81+div4_81
11840 C write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11844 C--------------------------------------------------------------------------
11845 double precision function tschebyshev(m,n,x,y)
11847 include "DIMENSIONS"
11849 double precision x(n),y,yy(0:maxvar),aux
11850 c Tschebyshev polynomial. Note that the first term is omitted
11851 c m=0: the constant term is included
11852 c m=1: the constant term is not included
11856 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11865 C--------------------------------------------------------------------------
11866 double precision function gradtschebyshev(m,n,x,y)
11868 include "DIMENSIONS"
11870 double precision x(n+1),y,yy(0:maxvar),aux
11871 c Tschebyshev polynomial. Note that the first term is omitted
11872 c m=0: the constant term is included
11873 c m=1: the constant term is not included
11877 yy(i)=2*y*yy(i-1)-yy(i-2)
11881 aux=aux+x(i+1)*yy(i)*(i+1)
11882 C print *, x(i+1),yy(i),i
11884 gradtschebyshev=aux
11887 C------------------------------------------------------------------------
11888 C first for shielding is setting of function of side-chains
11889 subroutine set_shield_fac2
11890 implicit real*8 (a-h,o-z)
11891 include 'DIMENSIONS'
11892 include 'COMMON.CHAIN'
11893 include 'COMMON.DERIV'
11894 include 'COMMON.IOUNITS'
11895 include 'COMMON.SHIELD'
11896 include 'COMMON.INTERACT'
11897 include 'COMMON.LOCAL'
11899 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11900 double precision div77_81/0.974996043d0/,
11901 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11903 C the vector between center of side_chain and peptide group
11904 double precision pep_side(3),long,side_calf(3),
11905 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11906 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11907 C write(2,*) "ivec",ivec_start,ivec_end
11909 fac_shield(i)=0.0d0
11911 grad_shield(j,i)=0.0d0
11914 C the line belowe needs to be changed for FGPROC>1
11915 do i=ivec_start,ivec_end
11917 C if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11919 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11920 Cif there two consequtive dummy atoms there is no peptide group between them
11921 C the line below has to be changed for FGPROC>1
11924 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11928 C first lets set vector conecting the ithe side-chain with kth side-chain
11929 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11930 C pep_side(j)=2.0d0
11931 C and vector conecting the side-chain with its proper calfa
11932 side_calf(j)=c(j,k+nres)-c(j,k)
11933 C side_calf(j)=2.0d0
11934 pept_group(j)=c(j,i)-c(j,i+1)
11935 C lets have their lenght
11936 dist_pep_side=pep_side(j)**2+dist_pep_side
11937 dist_side_calf=dist_side_calf+side_calf(j)**2
11938 dist_pept_group=dist_pept_group+pept_group(j)**2
11940 dist_pep_side=dsqrt(dist_pep_side)
11941 dist_pept_group=dsqrt(dist_pept_group)
11942 dist_side_calf=dsqrt(dist_side_calf)
11944 pep_side_norm(j)=pep_side(j)/dist_pep_side
11945 side_calf_norm(j)=dist_side_calf
11947 C now sscale fraction
11948 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11949 C print *,buff_shield,"buff"
11951 if (sh_frac_dist.le.0.0) cycle
11952 C print *,ishield_list(i),i
11953 C If we reach here it means that this side chain reaches the shielding sphere
11954 C Lets add him to the list for gradient
11955 ishield_list(i)=ishield_list(i)+1
11956 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11957 C this list is essential otherwise problem would be O3
11958 shield_list(ishield_list(i),i)=k
11959 C Lets have the sscale value
11960 if (sh_frac_dist.gt.1.0) then
11961 scale_fac_dist=1.0d0
11963 sh_frac_dist_grad(j)=0.0d0
11966 scale_fac_dist=-sh_frac_dist*sh_frac_dist
11967 & *(2.0d0*sh_frac_dist-3.0d0)
11968 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11969 & /dist_pep_side/buff_shield*0.5d0
11970 C remember for the final gradient multiply sh_frac_dist_grad(j)
11971 C for side_chain by factor -2 !
11973 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11974 C sh_frac_dist_grad(j)=0.0d0
11975 C scale_fac_dist=1.0d0
11976 C print *,"jestem",scale_fac_dist,fac_help_scale,
11977 C & sh_frac_dist_grad(j)
11980 C this is what is now we have the distance scaling now volume...
11981 short=short_r_sidechain(itype(k))
11982 long=long_r_sidechain(itype(k))
11983 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11984 sinthet=short/dist_pep_side*costhet
11988 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11989 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11990 C & -short/dist_pep_side**2/costhet)
11991 C costhet_fac=0.0d0
11993 costhet_grad(j)=costhet_fac*pep_side(j)
11995 C remember for the final gradient multiply costhet_grad(j)
11996 C for side_chain by factor -2 !
11997 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11998 C pep_side0pept_group is vector multiplication
11999 pep_side0pept_group=0.0d0
12001 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12003 cosalfa=(pep_side0pept_group/
12004 & (dist_pep_side*dist_side_calf))
12005 fac_alfa_sin=1.0d0-cosalfa**2
12006 fac_alfa_sin=dsqrt(fac_alfa_sin)
12007 rkprim=fac_alfa_sin*(long-short)+short
12011 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12013 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12014 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12015 & dist_pep_side**2)
12018 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12019 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12020 &*(long-short)/fac_alfa_sin*cosalfa/
12021 &((dist_pep_side*dist_side_calf))*
12022 &((side_calf(j))-cosalfa*
12023 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12024 C cosphi_grad_long(j)=0.0d0
12025 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12026 &*(long-short)/fac_alfa_sin*cosalfa
12027 &/((dist_pep_side*dist_side_calf))*
12029 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12030 C cosphi_grad_loc(j)=0.0d0
12032 C print *,sinphi,sinthet
12033 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12036 C now the gradient...
12038 grad_shield(j,i)=grad_shield(j,i)
12039 C gradient po skalowaniu
12040 & +(sh_frac_dist_grad(j)*VofOverlap
12041 C gradient po costhet
12042 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12043 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12044 & sinphi/sinthet*costhet*costhet_grad(j)
12045 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12047 C grad_shield_side is Cbeta sidechain gradient
12048 grad_shield_side(j,ishield_list(i),i)=
12049 & (sh_frac_dist_grad(j)*-2.0d0
12051 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12052 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12053 & sinphi/sinthet*costhet*costhet_grad(j)
12054 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12057 grad_shield_loc(j,ishield_list(i),i)=
12058 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12059 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12060 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12064 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12066 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12067 C write(2,*) "TOTAL VOLUME",i,itype(i),fac_shield(i)
12071 C-----------------------------------------------------------------------
12072 C-----------------------------------------------------------
12073 C This subroutine is to mimic the histone like structure but as well can be
12074 C utilizet to nanostructures (infinit) small modification has to be used to
12075 C make it finite (z gradient at the ends has to be changes as well as the x,y
12076 C gradient has to be modified at the ends
12077 C The energy function is Kihara potential
12078 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12079 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12080 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12081 C simple Kihara potential
12082 subroutine calctube(Etube)
12083 implicit real*8 (a-h,o-z)
12084 include 'DIMENSIONS'
12085 include 'COMMON.GEO'
12086 include 'COMMON.VAR'
12087 include 'COMMON.LOCAL'
12088 include 'COMMON.CHAIN'
12089 include 'COMMON.DERIV'
12090 include 'COMMON.NAMES'
12091 include 'COMMON.INTERACT'
12092 include 'COMMON.IOUNITS'
12093 include 'COMMON.CALC'
12094 include 'COMMON.CONTROL'
12095 include 'COMMON.SPLITELE'
12096 include 'COMMON.SBRIDGE'
12097 double precision tub_r,vectube(3),enetube(maxres*2)
12102 C first we calculate the distance from tube center
12103 C first sugare-phosphate group for NARES this would be peptide group
12106 C lets ommit dummy atoms for now
12107 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12108 C now calculate distance from center of tube and direction vectors
12109 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12110 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12111 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12112 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12113 vectube(1)=vectube(1)-tubecenter(1)
12114 vectube(2)=vectube(2)-tubecenter(2)
12116 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12117 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12119 C as the tube is infinity we do not calculate the Z-vector use of Z
12122 C now calculte the distance
12123 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12124 C now normalize vector
12125 vectube(1)=vectube(1)/tub_r
12126 vectube(2)=vectube(2)/tub_r
12127 C calculte rdiffrence between r and r0
12130 rdiff6=rdiff**6.0d0
12131 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12132 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12133 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12134 C print *,rdiff,rdiff6,pep_aa_tube
12135 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12136 C now we calculate gradient
12137 fac=(-12.0d0*pep_aa_tube/rdiff6+
12138 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12139 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12142 C now direction of gg_tube vector
12144 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12145 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12148 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12150 C Lets not jump over memory as we use many times iti
12152 C lets ommit dummy atoms for now
12154 C in UNRES uncomment the line below as GLY has no side-chain...
12157 vectube(1)=c(1,i+nres)
12158 vectube(1)=mod(vectube(1),boxxsize)
12159 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12160 vectube(2)=c(2,i+nres)
12161 vectube(2)=mod(vectube(2),boxysize)
12162 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12164 vectube(1)=vectube(1)-tubecenter(1)
12165 vectube(2)=vectube(2)-tubecenter(2)
12167 C as the tube is infinity we do not calculate the Z-vector use of Z
12170 C now calculte the distance
12171 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12172 C now normalize vector
12173 vectube(1)=vectube(1)/tub_r
12174 vectube(2)=vectube(2)/tub_r
12175 C calculte rdiffrence between r and r0
12178 rdiff6=rdiff**6.0d0
12179 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12180 sc_aa_tube=sc_aa_tube_par(iti)
12181 sc_bb_tube=sc_bb_tube_par(iti)
12182 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12183 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12184 C now we calculate gradient
12185 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12186 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12187 C now direction of gg_tube vector
12189 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12190 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12194 Etube=Etube+enetube(i)
12196 C print *,"ETUBE", etube
12199 C TO DO 1) add to total energy
12200 C 2) add to gradient summation
12201 C 3) add reading parameters (AND of course oppening of PARAM file)
12202 C 4) add reading the center of tube
12204 C 6) add to zerograd
12206 C-----------------------------------------------------------------------
12207 C-----------------------------------------------------------
12208 C This subroutine is to mimic the histone like structure but as well can be
12209 C utilizet to nanostructures (infinit) small modification has to be used to
12210 C make it finite (z gradient at the ends has to be changes as well as the x,y
12211 C gradient has to be modified at the ends
12212 C The energy function is Kihara potential
12213 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12214 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12215 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12216 C simple Kihara potential
12217 subroutine calctube2(Etube)
12218 implicit real*8 (a-h,o-z)
12219 include 'DIMENSIONS'
12220 include 'COMMON.GEO'
12221 include 'COMMON.VAR'
12222 include 'COMMON.LOCAL'
12223 include 'COMMON.CHAIN'
12224 include 'COMMON.DERIV'
12225 include 'COMMON.NAMES'
12226 include 'COMMON.INTERACT'
12227 include 'COMMON.IOUNITS'
12228 include 'COMMON.CALC'
12229 include 'COMMON.CONTROL'
12230 include 'COMMON.SPLITELE'
12231 include 'COMMON.SBRIDGE'
12232 double precision tub_r,vectube(3),enetube(maxres*2)
12237 C first we calculate the distance from tube center
12238 C first sugare-phosphate group for NARES this would be peptide group
12241 C lets ommit dummy atoms for now
12243 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12244 C now calculate distance from center of tube and direction vectors
12245 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12246 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12247 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
12248 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12249 vectube(1)=vectube(1)-tubecenter(1)
12250 vectube(2)=vectube(2)-tubecenter(2)
12252 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12253 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12255 C as the tube is infinity we do not calculate the Z-vector use of Z
12258 C now calculte the distance
12259 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12260 C now normalize vector
12261 vectube(1)=vectube(1)/tub_r
12262 vectube(2)=vectube(2)/tub_r
12263 C calculte rdiffrence between r and r0
12266 rdiff6=rdiff**6.0d0
12267 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12268 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12269 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12270 C print *,rdiff,rdiff6,pep_aa_tube
12271 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12272 C now we calculate gradient
12273 fac=(-12.0d0*pep_aa_tube/rdiff6+
12274 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12275 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12278 C now direction of gg_tube vector
12280 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12281 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12284 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12286 C Lets not jump over memory as we use many times iti
12288 C lets ommit dummy atoms for now
12290 C in UNRES uncomment the line below as GLY has no side-chain...
12293 vectube(1)=c(1,i+nres)
12294 vectube(1)=mod(vectube(1),boxxsize)
12295 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12296 vectube(2)=c(2,i+nres)
12297 vectube(2)=mod(vectube(2),boxysize)
12298 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
12300 vectube(1)=vectube(1)-tubecenter(1)
12301 vectube(2)=vectube(2)-tubecenter(2)
12302 C THIS FRAGMENT MAKES TUBE FINITE
12303 positi=(mod(c(3,i+nres),boxzsize))
12304 if (positi.le.0) positi=positi+boxzsize
12305 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12306 c for each residue check if it is in lipid or lipid water border area
12307 C respos=mod(c(3,i+nres),boxzsize)
12308 print *,positi,bordtubebot,buftubebot,bordtubetop
12309 if ((positi.gt.bordtubebot)
12310 & .and.(positi.lt.bordtubetop)) then
12311 C the energy transfer exist
12312 if (positi.lt.buftubebot) then
12314 & ((positi-bordtubebot)/tubebufthick)
12315 C lipbufthick is thickenes of lipid buffore
12316 sstube=sscalelip(fracinbuf)
12317 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12318 print *,ssgradtube, sstube,tubetranene(itype(i))
12319 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12320 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12321 C &+ssgradtube*tubetranene(itype(i))
12322 C gg_tube(3,i-1)= gg_tube(3,i-1)
12323 C &+ssgradtube*tubetranene(itype(i))
12324 C print *,"doing sccale for lower part"
12325 elseif (positi.gt.buftubetop) then
12327 &((bordtubetop-positi)/tubebufthick)
12328 sstube=sscalelip(fracinbuf)
12329 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12330 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12331 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12332 C &+ssgradtube*tubetranene(itype(i))
12333 C gg_tube(3,i-1)= gg_tube(3,i-1)
12334 C &+ssgradtube*tubetranene(itype(i))
12335 C print *, "doing sscalefor top part",sslip,fracinbuf
12339 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12340 C print *,"I am in true lipid"
12346 endif ! if in lipid or buffor
12347 CEND OF FINITE FRAGMENT
12348 C as the tube is infinity we do not calculate the Z-vector use of Z
12351 C now calculte the distance
12352 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12353 C now normalize vector
12354 vectube(1)=vectube(1)/tub_r
12355 vectube(2)=vectube(2)/tub_r
12356 C calculte rdiffrence between r and r0
12359 rdiff6=rdiff**6.0d0
12360 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12361 sc_aa_tube=sc_aa_tube_par(iti)
12362 sc_bb_tube=sc_bb_tube_par(iti)
12363 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12364 & *sstube+enetube(i+nres)
12365 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12366 C now we calculate gradient
12367 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12368 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12369 C now direction of gg_tube vector
12371 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12372 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12374 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12375 &+ssgradtube*enetube(i+nres)/sstube
12376 gg_tube(3,i-1)= gg_tube(3,i-1)
12377 &+ssgradtube*enetube(i+nres)/sstube
12381 Etube=Etube+enetube(i)
12383 C print *,"ETUBE", etube
12386 C TO DO 1) add to total energy
12387 C 2) add to gradient summation
12388 C 3) add reading parameters (AND of course oppening of PARAM file)
12389 C 4) add reading the center of tube
12391 C 6) add to zerograd