1 subroutine etotal(energia)
7 cMS$ATTRIBUTES C :: proc_proc
12 double precision weights_(n_ene)
13 double precision time00
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.QRESTR'
28 include 'COMMON.CONTROL'
29 include 'COMMON.TIME1'
30 include 'COMMON.SPLITELE'
31 include 'COMMON.TORCNSTR'
34 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
35 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
36 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
37 & eliptran,Eafmforce,Etube,
38 & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
39 integer n_corr,n_corr1
41 c print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
42 c & " nfgtasks",nfgtasks
43 if (nfgtasks.gt.1) then
45 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
46 if (fg_rank.eq.0) then
47 call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
48 c print *,"Processor",myrank," BROADCAST iorder"
49 C FG master sets up the WEIGHTS_ array which will be broadcast to the
50 C FG slaves as WEIGHTS array.
73 weights_(28)=wdfa_dist
76 weights_(31)=wdfa_beta
77 C FG Master broadcasts the WEIGHTS_ array
78 call MPI_Bcast(weights_(1),n_ene,
79 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
81 C FG slaves receive the WEIGHTS array
82 call MPI_Bcast(weights(1),n_ene,
83 & MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
106 wdfa_dist=weights(28)
109 wdfa_beta=weights(31)
111 time_Bcast=time_Bcast+MPI_Wtime()-time00
112 time_Bcastw=time_Bcastw+MPI_Wtime()-time00
113 c call chainbuild_cart
115 if (nfgtasks.gt.1) then
116 call MPI_Bcast(itime_mat,1,MPI_INT,king,FG_COMM,IERROR)
118 c write (iout,*) "itime_mat",itime_mat," imatupdate",imatupdate
119 if (mod(itime_mat,imatupdate).eq.0) then
120 call make_SCp_inter_list
121 c write (iout,*) "Finished make_SCp_inter_list"
123 call make_SCSC_inter_list
124 c write (iout,*) "Finished make_SCSC_inter_list"
126 call make_pp_inter_list
127 c write (iout,*) "Finished make_pp_inter_list"
129 call make_pp_vdw_inter_list
130 c write (iout,*) "Finished make_pp_vdw_inter_list"
133 c print *,'Processor',myrank,' calling etotal ipot=',ipot
134 c print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
136 c if (modecalc.eq.12.or.modecalc.eq.14) then
137 c call int_from_cart1(.false.)
151 C Compute the side-chain and electrostatic interaction energy
154 goto (101,102,103,104,105,106) ipot
155 C Lennard-Jones potential.
157 cd print '(a)','Exit ELJ'
159 C Lennard-Jones-Kihara potential (shifted).
162 C Berne-Pechukas potential (dilated LJ, angular dependence).
165 C Gay-Berne potential (shifted LJ, angular dependence).
167 C print *,"bylem w egb"
169 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
172 C Soft-sphere potential
173 106 call e_softsphere(evdw)
175 C Calculate electrostatic (H-bonding) energy of the main chain.
179 C BARTEK for dfa test!
180 c print *,"Processors",MyRank," wdfa",wdfa_dist
181 if (wdfa_dist.gt.0) then
183 c print *,"Processors",MyRank," edfadis",edfadis
187 c print*, 'edfad is finished!', edfadis
188 if (wdfa_tor.gt.0) then
193 c print*, 'edfat is finished!', edfator
194 if (wdfa_nei.gt.0) then
199 c print*, 'edfan is finished!', edfanei
200 if (wdfa_beta.gt.0) then
207 cmc Sep-06: egb takes care of dynamic ss bonds too
209 c if (dyn_ss) call dyn_set_nss
211 c print *,"Processor",myrank," computed USCSC"
217 time_vec=time_vec+MPI_Wtime()-time01
219 C Introduction of shielding effect first for each peptide group
220 C the shielding factor is set this factor is describing how each
221 C peptide group is shielded by side-chains
222 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
223 C write (iout,*) "shield_mode",shield_mode
224 if (shield_mode.eq.1) then
226 else if (shield_mode.eq.2) then
229 c print *,"Processor",myrank," left VEC_AND_DERIV"
232 if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
233 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
234 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
235 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
237 if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
238 & wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
239 & .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
240 & .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
242 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
251 write (iout,*) "Soft-spheer ELEC potential"
252 c call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
256 c time_enecalc=time_enecalc+MPI_Wtime()-time00
258 c print *,"Processor",myrank," computed UELEC"
260 C Calculate excluded-volume interaction energy between peptide groups
265 call escp(evdw2,evdw2_14)
271 c write (iout,*) "Soft-sphere SCP potential"
272 call escp_soft_sphere(evdw2,evdw2_14)
275 c Calculate the bond-stretching energy
279 C Calculate the disulfide-bridge and other energy and the contributions
280 C from other distance constraints.
281 cd write (iout,*) 'Calling EHPB'
283 cd print *,'EHPB exitted succesfully.'
285 C Calculate the virtual-bond-angle energy.
287 if (wang.gt.0d0) then
288 if (tor_mode.eq.0) then
291 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
299 if (with_theta_constr) call etheta_constr(ethetacnstr)
300 c print *,"Processor",myrank," computed UB"
302 C Calculate the SC local energy.
304 C print *,"TU DOCHODZE?"
306 c print *,"Processor",myrank," computed USC"
308 C Calculate the virtual-bond torsional energy.
310 cd print *,'nterm=',nterm
311 C print *,"tor",tor_mode
312 if (wtor.gt.0.0d0) then
313 if (tor_mode.eq.0) then
316 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
324 if (ndih_constr.gt.0) call etor_constr(edihcnstr)
325 c print *,"Processor",myrank," computed Utor"
326 if (constr_homology.ge.1) then
327 call e_modeller(ehomology_constr)
328 c print *,'iset=',iset,'me=',me,ehomology_constr,
329 c & 'Processor',fg_rank,' CG group',kolor,
330 c & ' absolute rank',MyRank
332 ehomology_constr=0.0d0
335 C 6/23/01 Calculate double-torsional energy
337 if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
342 c print *,"Processor",myrank," computed Utord"
344 C 21/5/07 Calculate local sicdechain correlation energy
346 if (wsccor.gt.0.0d0) then
347 call eback_sc_corr(esccor)
352 C print *,"PRZED MULIt"
353 c print *,"Processor",myrank," computed Usccorr"
355 C 12/1/95 Multi-body terms
359 if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
360 & .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
361 call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
362 c write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
363 c &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
371 if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
372 c write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
375 call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
376 c write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
391 c print *,"Processor",myrank," computed Ucorr"
392 c write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
393 if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
394 call e_saxs(Esaxs_constr)
395 c write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
396 else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
397 call e_saxsC(Esaxs_constr)
398 c write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
403 C If performing constraint dynamics, call the constraint energy
404 C after the equilibration time
405 c if(usampl.and.totT.gt.eq_time) then
406 c write (iout,*) "usampl",usampl
410 call Econstr_back_qlike
418 C 01/27/2015 added by adasko
419 C the energy component below is energy transfer into lipid environment
420 C based on partition function
421 C print *,"przed lipidami"
422 if (wliptran.gt.0) then
423 call Eliptransfer(eliptran)
427 C print *,"za lipidami"
428 if (AFMlog.gt.0) then
429 call AFMforce(Eafmforce)
430 else if (selfguide.gt.0) then
431 call AFMvel(Eafmforce)
435 if (TUBElog.eq.1) then
436 C print *,"just before call"
438 elseif (TUBElog.eq.2) then
439 call calctube2(Etube)
445 time_enecalc=time_enecalc+MPI_Wtime()-time00
447 c print *,"Processor",myrank," computed Uconstr"
456 energia(2)=evdw2-evdw2_14
473 energia(8)=eello_turn3
474 energia(9)=eello_turn4
481 energia(19)=edihcnstr
483 energia(20)=Uconst+Uconst_back
486 energia(23)=Eafmforce
487 energia(24)=ethetacnstr
489 energia(26)=Esaxs_constr
490 energia(27)=ehomology_constr
495 c write (iout,*) "esaxs_constr",energia(26)
496 c Here are the energies showed per procesor if the are more processors
497 c per molecule then we sum it up in sum_energy subroutine
498 c print *," Processor",myrank," calls SUM_ENERGY"
499 call sum_energy(energia,.true.)
500 c write (iout,*) "After sum_energy: esaxs_constr",energia(26)
501 if (dyn_ss) call dyn_set_nss
502 c print *," Processor",myrank," left SUM_ENERGY"
504 time_sumene=time_sumene+MPI_Wtime()-time00
508 c-------------------------------------------------------------------------------
509 subroutine sum_energy(energia,reduce)
515 cMS$ATTRIBUTES C :: proc_proc
521 double precision time00
523 include 'COMMON.SETUP'
524 include 'COMMON.IOUNITS'
525 double precision energia(0:n_ene),enebuff(0:n_ene+1)
526 include 'COMMON.FFIELD'
527 include 'COMMON.DERIV'
528 include 'COMMON.INTERACT'
529 include 'COMMON.SBRIDGE'
530 include 'COMMON.CHAIN'
532 include 'COMMON.CONTROL'
533 include 'COMMON.TIME1'
536 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
537 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
538 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,eturn6,
539 & eliptran,Eafmforce,Etube,
540 & esaxs_constr,ehomology_constr,edfator,edfanei,edfabet
541 double precision Uconst,etot
543 if (nfgtasks.gt.1 .and. reduce) then
545 write (iout,*) "energies before REDUCE"
546 call enerprint(energia)
550 enebuff(i)=energia(i)
553 call MPI_Barrier(FG_COMM,IERR)
554 time_barrier_e=time_barrier_e+MPI_Wtime()-time00
556 call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
557 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
559 write (iout,*) "energies after REDUCE"
560 call enerprint(energia)
563 time_Reduce=time_Reduce+MPI_Wtime()-time00
565 if (fg_rank.eq.0) then
569 evdw2=energia(2)+energia(18)
585 eello_turn3=energia(8)
586 eello_turn4=energia(9)
593 edihcnstr=energia(19)
598 Eafmforce=energia(23)
599 ethetacnstr=energia(24)
601 esaxs_constr=energia(26)
602 ehomology_constr=energia(27)
608 etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
609 & +wang*ebe+wtor*etors+wscloc*escloc
610 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
611 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
612 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
613 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
614 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
615 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
618 etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
619 & +wang*ebe+wtor*etors+wscloc*escloc
620 & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
621 & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
622 & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
623 & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
625 & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr+ehomology_constr
626 & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
633 if (isnan(etot).ne.0) energia(0)=1.0d+99
635 if (isnan(etot)) energia(0)=1.0d+99
640 idumm=proc_proc(etot,i)
642 call proc_proc(etot,i)
644 if(i.eq.1)energia(0)=1.0d+99
651 c-------------------------------------------------------------------------------
652 subroutine sum_gradient
658 cMS$ATTRIBUTES C :: proc_proc
664 double precision time00,time01
666 double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
667 & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
668 & ,gloc_scbuf(3,-1:maxres)
669 include 'COMMON.SETUP'
670 include 'COMMON.IOUNITS'
671 include 'COMMON.FFIELD'
672 include 'COMMON.DERIV'
673 include 'COMMON.INTERACT'
674 include 'COMMON.SBRIDGE'
675 include 'COMMON.CHAIN'
677 include 'COMMON.CONTROL'
678 include 'COMMON.TIME1'
679 include 'COMMON.MAXGRAD'
680 include 'COMMON.SCCOR'
681 c include 'COMMON.MD'
682 include 'COMMON.QRESTR'
684 double precision scalar
685 double precision gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,
686 &gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,gcorr3_turn_norm,
687 &gcorr4_turn_norm,gradcorr5_norm,gradcorr6_norm,
688 &gcorr6_turn_norm,gsccorrc_norm,gscloc_norm,gvdwx_norm,
689 &gradx_scp_norm,ghpbx_norm,gradxorr_norm,gsccorrx_norm,
695 write (iout,*) "sum_gradient gvdwc, gvdwx"
697 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
698 & i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
703 write (iout,*) "sum_gradient gsaxsc, gsaxsx"
705 write (iout,'(i3,3e15.5,5x,3e15.5)')
706 & i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
711 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
712 if (nfgtasks.gt.1 .and. fg_rank.eq.0)
713 & call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
716 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
717 C in virtual-bond-vector coordinates
720 c write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
722 c write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
723 c & i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
725 c write (iout,*) "gel_loc_tur3 gel_loc_turn4"
727 c write (iout,'(i5,3f10.5,2x,f10.5)')
728 c & i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
730 write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
732 write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
733 & i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
739 write (iout,*) "gsaxsc"
741 write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
748 gradbufc(j,i)=wsc*gvdwc(j,i)+
749 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
750 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
751 & wel_loc*gel_loc_long(j,i)+
752 & wcorr*gradcorr_long(j,i)+
753 & wcorr5*gradcorr5_long(j,i)+
754 & wcorr6*gradcorr6_long(j,i)+
755 & wturn6*gcorr6_turn_long(j,i)+
757 & +wliptran*gliptranc(j,i)
759 & +welec*gshieldc(j,i)
760 & +wcorr*gshieldc_ec(j,i)
761 & +wturn3*gshieldc_t3(j,i)
762 & +wturn4*gshieldc_t4(j,i)
763 & +wel_loc*gshieldc_ll(j,i)
764 & +wtube*gg_tube(j,i)
771 gradbufc(j,i)=wsc*gvdwc(j,i)+
772 & wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
773 & welec*gelc_long(j,i)+
775 & wel_loc*gel_loc_long(j,i)+
776 & wcorr*gradcorr_long(j,i)+
777 & wcorr5*gradcorr5_long(j,i)+
778 & wcorr6*gradcorr6_long(j,i)+
779 & wturn6*gcorr6_turn_long(j,i)+
781 & +wliptran*gliptranc(j,i)
783 & +welec*gshieldc(j,i)
784 & +wcorr*gshieldc_ec(j,i)
785 & +wturn4*gshieldc_t4(j,i)
786 & +wel_loc*gshieldc_ll(j,i)
787 & +wtube*gg_tube(j,i)
794 gradbufc(j,i)=gradbufc(j,i)+
795 & wdfa_dist*gdfad(j,i)+
796 & wdfa_tor*gdfat(j,i)+
797 & wdfa_nei*gdfan(j,i)+
798 & wdfa_beta*gdfab(j,i)
802 write (iout,*) "gradc from gradbufc"
804 write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
809 if (nfgtasks.gt.1) then
812 write (iout,*) "gradbufc before allreduce"
814 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
820 gradbufc_sum(j,i)=gradbufc(j,i)
823 c call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
824 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
825 c time_reduce=time_reduce+MPI_Wtime()-time00
827 c write (iout,*) "gradbufc_sum after allreduce"
829 c write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
834 c time_allreduce=time_allreduce+MPI_Wtime()-time00
843 write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
844 write (iout,*) (i," jgrad_start",jgrad_start(i),
845 & " jgrad_end ",jgrad_end(i),
846 & i=igrad_start,igrad_end)
849 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
850 c do not parallelize this part.
852 c do i=igrad_start,igrad_end
853 c do j=jgrad_start(i),jgrad_end(i)
855 c gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
860 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
865 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
869 write (iout,*) "gradbufc after summing"
871 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
878 write (iout,*) "gradbufc"
880 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
887 gradbufc_sum(j,i)=gradbufc(j,i)
892 gradbufc(j,nres-1)=gradbufc_sum(j,nres)
897 gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
902 c gradbufc(k,i)=0.0d0
906 c gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
911 write (iout,*) "gradbufc after summing"
913 write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
921 gradbufc(k,nres)=0.0d0
927 C print *,gradbufc(1,13)
928 C print *,welec*gelc(1,13)
929 C print *,wel_loc*gel_loc(1,13)
930 C print *,0.5d0*(wscp*gvdwc_scpp(1,13))
931 C print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
932 C print *,wel_loc*gel_loc_long(1,13)
933 C print *,gradafm(1,13),"AFM"
934 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
935 & wel_loc*gel_loc(j,i)+
936 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
937 & welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
938 & wel_loc*gel_loc_long(j,i)+
939 & wcorr*gradcorr_long(j,i)+
940 & wcorr5*gradcorr5_long(j,i)+
941 & wcorr6*gradcorr6_long(j,i)+
942 & wturn6*gcorr6_turn_long(j,i))+
944 & wcorr*gradcorr(j,i)+
945 & wturn3*gcorr3_turn(j,i)+
946 & wturn4*gcorr4_turn(j,i)+
947 & wcorr5*gradcorr5(j,i)+
948 & wcorr6*gradcorr6(j,i)+
949 & wturn6*gcorr6_turn(j,i)+
950 & wsccor*gsccorc(j,i)
951 & +wscloc*gscloc(j,i)
952 & +wliptran*gliptranc(j,i)
954 & +welec*gshieldc(j,i)
955 & +welec*gshieldc_loc(j,i)
956 & +wcorr*gshieldc_ec(j,i)
957 & +wcorr*gshieldc_loc_ec(j,i)
958 & +wturn3*gshieldc_t3(j,i)
959 & +wturn3*gshieldc_loc_t3(j,i)
960 & +wturn4*gshieldc_t4(j,i)
961 & +wturn4*gshieldc_loc_t4(j,i)
962 & +wel_loc*gshieldc_ll(j,i)
963 & +wel_loc*gshieldc_loc_ll(j,i)
964 & +wtube*gg_tube(j,i)
967 gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
968 & wel_loc*gel_loc(j,i)+
969 & 0.5d0*(wscp*gvdwc_scpp(j,i)+
970 & welec*gelc_long(j,i)+
971 & wel_loc*gel_loc_long(j,i)+
972 & wcorr*gcorr_long(j,i)+
973 & wcorr5*gradcorr5_long(j,i)+
974 & wcorr6*gradcorr6_long(j,i)+
975 & wturn6*gcorr6_turn_long(j,i))+
977 & wcorr*gradcorr(j,i)+
978 & wturn3*gcorr3_turn(j,i)+
979 & wturn4*gcorr4_turn(j,i)+
980 & wcorr5*gradcorr5(j,i)+
981 & wcorr6*gradcorr6(j,i)+
982 & wturn6*gcorr6_turn(j,i)+
983 & wsccor*gsccorc(j,i)
984 & +wscloc*gscloc(j,i)
985 & +wliptran*gliptranc(j,i)
987 & +welec*gshieldc(j,i)
988 & +welec*gshieldc_loc(j,i)
989 & +wcorr*gshieldc_ec(j,i)
990 & +wcorr*gshieldc_loc_ec(j,i)
991 & +wturn3*gshieldc_t3(j,i)
992 & +wturn3*gshieldc_loc_t3(j,i)
993 & +wturn4*gshieldc_t4(j,i)
994 & +wturn4*gshieldc_loc_t4(j,i)
995 & +wel_loc*gshieldc_ll(j,i)
996 & +wel_loc*gshieldc_loc_ll(j,i)
997 & +wtube*gg_tube(j,i)
1001 gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
1002 & wbond*gradbx(j,i)+
1003 & wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
1004 & wsccor*gsccorx(j,i)
1005 & +wscloc*gsclocx(j,i)
1006 & +wliptran*gliptranx(j,i)
1007 & +welec*gshieldx(j,i)
1008 & +wcorr*gshieldx_ec(j,i)
1009 & +wturn3*gshieldx_t3(j,i)
1010 & +wturn4*gshieldx_t4(j,i)
1011 & +wel_loc*gshieldx_ll(j,i)
1012 & +wtube*gg_tube_sc(j,i)
1013 & +wsaxs*gsaxsx(j,i)
1019 if (constr_homology.gt.0) then
1022 gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
1023 gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
1028 write (iout,*) "gradc gradx gloc after adding"
1029 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1030 & i,(gradc(j,0,icg),j=1,3),(gradx(j,0,icg),j=1,3)
1032 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1033 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1037 write (iout,*) "gloc before adding corr"
1039 write (iout,*) i,gloc(i,icg)
1043 gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
1044 & +wcorr5*g_corr5_loc(i)
1045 & +wcorr6*g_corr6_loc(i)
1046 & +wturn4*gel_loc_turn4(i)
1047 & +wturn3*gel_loc_turn3(i)
1048 & +wturn6*gel_loc_turn6(i)
1049 & +wel_loc*gel_loc_loc(i)
1052 write (iout,*) "gloc after adding corr"
1054 write (iout,*) i,gloc(i,icg)
1058 if (nfgtasks.gt.1) then
1061 gradbufc(j,i)=gradc(j,i,icg)
1062 gradbufx(j,i)=gradx(j,i,icg)
1066 glocbuf(i)=gloc(i,icg)
1070 write (iout,*) "gloc_sc before reduce"
1073 write (iout,*) i,j,gloc_sc(j,i,icg)
1080 gloc_scbuf(j,i)=gloc_sc(j,i,icg)
1084 call MPI_Barrier(FG_COMM,IERR)
1085 time_barrier_g=time_barrier_g+MPI_Wtime()-time00
1087 call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*(nres+1),
1088 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1089 call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*(nres+1),
1090 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1091 call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
1092 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1093 time_reduce=time_reduce+MPI_Wtime()-time00
1094 call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
1095 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1096 time_reduce=time_reduce+MPI_Wtime()-time00
1098 write (iout,*) "gradc after reduce"
1101 write (iout,*) i,j,gradc(j,i,icg)
1106 write (iout,*) "gloc_sc after reduce"
1109 write (iout,*) i,j,gloc_sc(j,i,icg)
1114 write (iout,*) "gloc after reduce"
1116 write (iout,*) i,gloc(i,icg)
1121 if (gnorm_check) then
1123 c Compute the maximum elements of the gradient
1133 gcorr3_turn_max=0.0d0
1134 gcorr4_turn_max=0.0d0
1137 gcorr6_turn_max=0.0d0
1147 gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
1148 if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
1149 gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
1150 if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1151 & gvdwc_scp_max=gvdwc_scp_norm
1152 gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1153 if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1154 gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1155 if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1156 gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1157 if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1158 ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1159 if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1160 gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1161 if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1162 gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1163 if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1164 gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1165 & gcorr3_turn(1,i)))
1166 if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1167 & gcorr3_turn_max=gcorr3_turn_norm
1168 gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1169 & gcorr4_turn(1,i)))
1170 if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1171 & gcorr4_turn_max=gcorr4_turn_norm
1172 gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1173 if (gradcorr5_norm.gt.gradcorr5_max)
1174 & gradcorr5_max=gradcorr5_norm
1175 gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1176 if (gradcorr6_norm.gt.gradcorr6_max)gradcorr6_max=gradcorr6_norm
1177 gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1178 & gcorr6_turn(1,i)))
1179 if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1180 & gcorr6_turn_max=gcorr6_turn_norm
1181 gsccorrc_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1182 if (gsccorrc_norm.gt.gsccorrc_max) gsccorrc_max=gsccorrc_norm
1183 gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1184 if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1185 gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1186 if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1187 gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1188 if (gradx_scp_norm.gt.gradx_scp_max)
1189 & gradx_scp_max=gradx_scp_norm
1190 ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1191 if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1192 gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1193 if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1194 gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1195 if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1196 gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1197 if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1200 #if (defined AIX || defined CRAY)
1201 open(istat,file=statname,position="append")
1203 open(istat,file=statname,access="append")
1205 write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1206 & gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1207 & gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1208 & gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorrc_max,
1209 & gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1210 & gsccorrx_max,gsclocx_max
1212 if (gvdwc_max.gt.1.0d4) then
1213 write (iout,*) "gvdwc gvdwx gradb gradbx"
1215 write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1216 & gradb(j,i),gradbx(j,i),j=1,3)
1218 call pdbout(0.0d0,'cipiszcze',iout)
1224 write (iout,*) "gradc gradx gloc"
1226 write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1227 & i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1231 time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1235 c-------------------------------------------------------------------------------
1236 subroutine rescale_weights(t_bath)
1242 include 'DIMENSIONS'
1243 include 'COMMON.IOUNITS'
1244 include 'COMMON.FFIELD'
1245 include 'COMMON.SBRIDGE'
1246 include 'COMMON.CONTROL'
1247 double precision t_bath
1248 double precision facT,facT2,facT3,facT4,facT5
1249 double precision kfac /2.4d0/
1250 double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1252 c facT=2*temp0/(t_bath+temp0)
1253 if (rescale_mode.eq.0) then
1259 else if (rescale_mode.eq.1) then
1260 facT=kfac/(kfac-1.0d0+t_bath/temp0)
1261 facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1262 facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1263 facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1264 facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1265 else if (rescale_mode.eq.2) then
1271 facT=licznik/dlog(dexp(x)+dexp(-x))
1272 facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1273 facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1274 facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1275 facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1277 write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1278 write (*,*) "Wrong RESCALE_MODE",rescale_mode
1280 call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1284 if (shield_mode.gt.0) then
1285 wscp=weights(2)*fact
1287 wvdwpp=weights(16)*fact
1289 welec=weights(3)*fact
1290 wcorr=weights(4)*fact3
1291 wcorr5=weights(5)*fact4
1292 wcorr6=weights(6)*fact5
1293 wel_loc=weights(7)*fact2
1294 wturn3=weights(8)*fact2
1295 wturn4=weights(9)*fact3
1296 wturn6=weights(10)*fact5
1297 wtor=weights(13)*fact
1298 wtor_d=weights(14)*fact2
1299 wsccor=weights(21)*fact
1300 if (scale_umb) wumb=t_bath/temp0
1301 c write (iout,*) "scale_umb",scale_umb
1302 c write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1306 C------------------------------------------------------------------------
1307 subroutine enerprint(energia)
1309 include 'DIMENSIONS'
1310 include 'COMMON.IOUNITS'
1311 include 'COMMON.FFIELD'
1312 include 'COMMON.SBRIDGE'
1313 include 'COMMON.QRESTR'
1314 double precision energia(0:n_ene)
1315 double precision evdw,evdw1,evdw2,evdw2_14,ees,eel_loc,
1316 & eello_turn3,eello_turn4,edfadis,estr,ehpb,ebe,ethetacnstr,
1317 & escloc,etors,edihcnstr,etors_d,esccor,ecorr,ecorr5,ecorr6,
1319 & eliptran,Eafmforce,Etube,
1320 & esaxs,ehomology_constr,edfator,edfanei,edfabet,etot
1325 evdw2=energia(2)+energia(18)
1337 eello_turn3=energia(8)
1338 eello_turn4=energia(9)
1339 eello_turn6=energia(10)
1345 edihcnstr=energia(19)
1349 eliptran=energia(22)
1350 Eafmforce=energia(23)
1351 ethetacnstr=energia(24)
1354 ehomology_constr=energia(27)
1356 edfadis = energia(28)
1357 edfator = energia(29)
1358 edfanei = energia(30)
1359 edfabet = energia(31)
1361 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1362 & estr,wbond,ebe,wang,
1363 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1366 & ecorr5,wcorr5,ecorr6,wcorr6,
1368 & eel_loc,wel_loc,eello_turn3,wturn3,
1369 & eello_turn4,wturn4,
1371 & eello_turn6,wturn6,
1373 & esccor,wsccor,edihcnstr,
1374 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforce,
1375 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1376 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1377 & edfabet,wdfa_beta,
1379 10 format (/'Virtual-chain energies:'//
1380 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1381 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1382 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1383 & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1384 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1385 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1386 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1387 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1388 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1389 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1390 & ' (SS bridges & dist. cnstr.)'/
1392 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1393 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1394 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1396 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1397 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1398 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1400 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1402 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1403 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1404 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1405 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1406 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1407 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1408 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1409 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1410 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1411 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1412 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1413 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1414 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1415 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1416 & 'ETOT= ',1pE16.6,' (total)')
1419 write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1420 & estr,wbond,ebe,wang,
1421 & escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1424 & ecorr5,wcorr5,ecorr6,wcorr6,
1426 & eel_loc,wel_loc,eello_turn3,wturn3,
1427 & eello_turn4,wturn4,
1429 & eello_turn6,wturn6,
1431 & esccor,wsccor,edihcnstr,
1432 & ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1433 & etube,wtube,esaxs,wsaxs,ehomology_constr,
1434 & edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1435 & edfabet,wdfa_beta,
1437 10 format (/'Virtual-chain energies:'//
1438 & 'EVDW= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1439 & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1440 & 'EES= ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1441 & 'ESTR= ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1442 & 'EBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1443 & 'ESC= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1444 & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1445 & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1446 & 'EHBP= ',1pE16.6,' WEIGHT=',1pE16.6,
1447 & ' (SS bridges & dist. restr.)'/
1449 & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1450 & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1451 & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1453 & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1454 & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1455 & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1457 & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1459 & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1460 & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1461 & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1462 & 'ESS= ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1463 & 'UCONST=',1pE16.6,' WEIGHT=',1pE16.6' (umbrella restraints)'/
1464 & 'ELT= ',1pE16.6,' WEIGHT=',1pE16.6,' (Lipid transfer)'/
1465 & 'EAFM= ',1pE16.6,' (atomic-force microscopy)'/
1466 & 'ETUBE= ',1pE16.6,' WEIGHT=',1pE16.6,' (tube confinment)'/
1467 & 'E_SAXS=',1pE16.6,' WEIGHT=',1pE16.6,' (SAXS restraints)'/
1468 & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1469 & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1470 & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1471 & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1472 & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1473 & 'ETOT= ',1pE16.6,' (total)')
1477 C-----------------------------------------------------------------------
1478 subroutine elj(evdw)
1480 C This subroutine calculates the interaction energy of nonbonded side chains
1481 C assuming the LJ potential of interaction.
1484 double precision accur
1485 include 'DIMENSIONS'
1486 parameter (accur=1.0d-10)
1487 include 'COMMON.GEO'
1488 include 'COMMON.VAR'
1489 include 'COMMON.LOCAL'
1490 include 'COMMON.CHAIN'
1491 include 'COMMON.DERIV'
1492 include 'COMMON.INTERACT'
1493 include 'COMMON.TORSION'
1494 include 'COMMON.SBRIDGE'
1495 include 'COMMON.NAMES'
1496 include 'COMMON.IOUNITS'
1497 include 'COMMON.SPLITELE'
1499 include 'COMMON.CONTACTS'
1500 include 'COMMON.CONTMAT'
1502 double precision gg(3)
1503 double precision evdw,evdwij
1504 integer i,j,k,itypi,itypj,itypi1,num_conti,iint,ikont
1505 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1506 & sigij,r0ij,rcut,sqrij,sss1,sssgrad1
1507 double precision fcont,fprimcont
1508 double precision fracinbuf,sslipi,sslipj,ssgradlipj,ssgradlipi,
1510 double precision sscale,sscagrad,sscagradlip,sscalelip
1511 double precision gg_lipi(3),gg_lipj(3)
1512 double precision boxshift
1513 c write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1517 c do i=iatsc_s,iatsc_e
1518 do ikont=g_listscsc_start,g_listscsc_end
1519 i=newcontlisti(ikont)
1520 j=newcontlistj(ikont)
1521 itypi=iabs(itype(i))
1522 if (itypi.eq.ntyp1) cycle
1523 itypi1=iabs(itype(i+1))
1527 call to_box(xi,yi,zi)
1528 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1532 C Calculate SC interaction energy.
1534 c do iint=1,nint_gr(i)
1535 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1536 cd & 'iend=',iend(i,iint)
1537 c do j=istart(i,iint),iend(i,iint)
1538 itypj=iabs(itype(j))
1539 if (itypj.eq.ntyp1) cycle
1543 call to_box(xj,yj,zj)
1544 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1545 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1546 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1547 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1548 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1549 xj=boxshift(xj-xi,boxxsize)
1550 yj=boxshift(yj-yi,boxysize)
1551 zj=boxshift(zj-zi,boxzsize)
1552 C Change 12/1/95 to calculate four-body interactions
1553 rij=xj*xj+yj*yj+zj*zj
1556 sss1=sscale(sqrij,r_cut_int)
1557 if (sss1.eq.0.0d0) cycle
1558 sssgrad1=sscagrad(sqrij,r_cut_int)
1560 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1561 eps0ij=eps(itypi,itypj)
1564 C have you changed here?
1568 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1569 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1570 cd write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1571 cd & restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1572 cd & bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1573 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1574 evdw=evdw+sss1*evdwij
1576 C Calculate the components of the gradient in DC and X
1578 fac=-rrij*(e1+evdwij)*sss1
1579 & +evdwij*sssgrad1/sqrij/expon
1583 gg_lipi(3)=(sss1/2.0d0*(faclip*faclip*
1584 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1585 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj))))/expon
1586 gg_lipj(3)=ssgradlipj*gg_lipi(3)
1587 gg_lipi(3)=gg_lipi(3)*ssgradlipi
1589 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1590 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
1591 gvdwc(k,i)=gvdwc(k,i)-gg(k)+gg_lipi(k)
1592 gvdwc(k,j)=gvdwc(k,j)+gg(k)+gg_lipj(k)
1596 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1601 C 12/1/95, revised on 5/20/97
1603 C Calculate the contact function. The ith column of the array JCONT will
1604 C contain the numbers of atoms that make contacts with the atom I (of numbers
1605 C greater than I). The arrays FACONT and GACONT will contain the values of
1606 C the contact function and its derivative.
1608 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1609 c if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1610 C Uncomment next line, if the correlation interactions are contact function only
1611 if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1613 sigij=sigma(itypi,itypj)
1614 r0ij=rs0(itypi,itypj)
1616 C Check whether the SC's are not too far to make a contact.
1619 call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1620 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1622 if (fcont.gt.0.0D0) then
1623 C If the SC-SC distance if close to sigma, apply spline.
1624 cAdam call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1625 cAdam & fcont1,fprimcont1)
1626 cAdam fcont1=1.0d0-fcont1
1627 cAdam if (fcont1.gt.0.0d0) then
1628 cAdam fprimcont=fprimcont*fcont1+fcont*fprimcont1
1629 cAdam fcont=fcont*fcont1
1631 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1632 cga eps0ij=1.0d0/dsqrt(eps0ij)
1634 cga gg(k)=gg(k)*eps0ij
1636 cga eps0ij=-evdwij*eps0ij
1637 C Uncomment for AL's type of SC correlation interactions.
1638 cadam eps0ij=-evdwij
1639 num_conti=num_conti+1
1640 jcont(num_conti,i)=j
1641 facont(num_conti,i)=fcont*eps0ij
1642 fprimcont=eps0ij*fprimcont/rij
1644 cAdam gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1645 cAdam gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1646 cAdam gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1647 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1648 gacont(1,num_conti,i)=-fprimcont*xj
1649 gacont(2,num_conti,i)=-fprimcont*yj
1650 gacont(3,num_conti,i)=-fprimcont*zj
1651 cd write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1652 cd write (iout,'(2i3,3f10.5)')
1653 cd & i,j,(gacont(kk,num_conti,i),kk=1,3)
1661 num_cont(i)=num_conti
1666 gvdwc(j,i)=expon*gvdwc(j,i)
1667 gvdwx(j,i)=expon*gvdwx(j,i)
1670 C******************************************************************************
1674 C To save time, the factor of EXPON has been extracted from ALL components
1675 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1678 C******************************************************************************
1681 C-----------------------------------------------------------------------------
1682 subroutine eljk(evdw)
1684 C This subroutine calculates the interaction energy of nonbonded side chains
1685 C assuming the LJK potential of interaction.
1688 include 'DIMENSIONS'
1689 include 'COMMON.GEO'
1690 include 'COMMON.VAR'
1691 include 'COMMON.LOCAL'
1692 include 'COMMON.CHAIN'
1693 include 'COMMON.DERIV'
1694 include 'COMMON.INTERACT'
1695 include 'COMMON.IOUNITS'
1696 include 'COMMON.NAMES'
1697 include 'COMMON.SPLITELE'
1698 double precision gg(3)
1699 double precision evdw,evdwij
1700 integer i,j,k,itypi,itypj,itypi1,iint,ikont
1701 double precision xi,yi,zi,xj,yj,zj,rij,eps0ij,fac,e1,e2,rrij,
1702 & fac_augm,e_augm,r_inv_ij,r_shift_inv,sss1,sssgrad1
1704 double precision boxshift
1705 double precision fracinbuf,sslipi,sslipj,ssgradlipj,ssgradlipi,
1707 double precision gg_lipi(3),gg_lipj(3)
1708 double precision sscale,sscagrad,sscagradlip,sscalelip
1709 c print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1713 c do i=iatsc_s,iatsc_e
1714 do ikont=g_listscsc_start,g_listscsc_end
1715 i=newcontlisti(ikont)
1716 j=newcontlistj(ikont)
1717 itypi=iabs(itype(i))
1718 if (itypi.eq.ntyp1) cycle
1719 itypi1=iabs(itype(i+1))
1723 call to_box(xi,yi,zi)
1724 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1726 C Calculate SC interaction energy.
1728 c do iint=1,nint_gr(i)
1729 c do j=istart(i,iint),iend(i,iint)
1730 itypj=iabs(itype(j))
1731 if (itypj.eq.ntyp1) cycle
1735 call to_box(xj,yj,zj)
1736 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1737 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1738 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1739 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1740 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1741 xj=boxshift(xj-xi,boxxsize)
1742 yj=boxshift(yj-yi,boxysize)
1743 zj=boxshift(zj-zi,boxzsize)
1744 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1745 fac_augm=rrij**expon
1746 e_augm=augm(itypi,itypj)*fac_augm
1747 r_inv_ij=dsqrt(rrij)
1749 sss1=sscale(rij,r_cut_int)
1750 if (sss1.eq.0.0d0) cycle
1751 sssgrad1=sscagrad(rij,r_cut_int)
1752 r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1753 fac=r_shift_inv**expon
1755 C have you changed here?
1759 cd sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1760 cd epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1761 cd write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1762 cd & restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1763 cd & bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1764 cd & sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1765 cd & (c(k,i),k=1,3),(c(k,j),k=1,3)
1766 evdw=evdw+evdwij*sss1
1768 C Calculate the components of the gradient in DC and X
1770 fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1771 & +evdwij*sssgrad1*r_inv_ij/expon
1775 gg_lipi(3)=(sss1/2.0d0*(faclip*faclip*
1776 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1777 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj))))/expon
1778 gg_lipj(3)=ssgradlipj*gg_lipi(3)
1779 gg_lipi(3)=gg_lipi(3)*ssgradlipi
1781 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1782 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
1783 gvdwc(k,i)=gvdwc(k,i)-gg(k)+gg_lipi(k)
1784 gvdwc(k,j)=gvdwc(k,j)+gg(k)+gg_lipj(k)
1788 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
1796 gvdwc(j,i)=expon*gvdwc(j,i)
1797 gvdwx(j,i)=expon*gvdwx(j,i)
1802 C-----------------------------------------------------------------------------
1803 subroutine ebp(evdw)
1805 C This subroutine calculates the interaction energy of nonbonded side chains
1806 C assuming the Berne-Pechukas potential of interaction.
1809 include 'DIMENSIONS'
1810 include 'COMMON.GEO'
1811 include 'COMMON.VAR'
1812 include 'COMMON.LOCAL'
1813 include 'COMMON.CHAIN'
1814 include 'COMMON.DERIV'
1815 include 'COMMON.NAMES'
1816 include 'COMMON.INTERACT'
1817 include 'COMMON.IOUNITS'
1818 include 'COMMON.CALC'
1819 include 'COMMON.SPLITELE'
1821 common /srutu/ icall
1822 double precision evdw
1823 integer itypi,itypj,itypi1,iint,ind,ikont
1824 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi,
1826 double precision fracinbuf,sslipi,sslipj,ssgradlipj,ssgradlipi,
1828 double precision sscale,sscagrad,sscagradlip,sscalelip
1829 double precision boxshift
1830 c double precision rrsave(maxdim)
1833 c print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1836 c if (icall.eq.0) then
1842 c do i=iatsc_s,iatsc_e
1843 do ikont=g_listscsc_start,g_listscsc_end
1844 i=newcontlisti(ikont)
1845 j=newcontlistj(ikont)
1846 itypi=iabs(itype(i))
1847 if (itypi.eq.ntyp1) cycle
1848 itypi1=iabs(itype(i+1))
1852 call to_box(xi,yi,zi)
1853 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1854 dxi=dc_norm(1,nres+i)
1855 dyi=dc_norm(2,nres+i)
1856 dzi=dc_norm(3,nres+i)
1857 c dsci_inv=dsc_inv(itypi)
1858 dsci_inv=vbld_inv(i+nres)
1860 C Calculate SC interaction energy.
1862 c do iint=1,nint_gr(i)
1863 c do j=istart(i,iint),iend(i,iint)
1865 itypj=iabs(itype(j))
1866 if (itypj.eq.ntyp1) cycle
1867 c dscj_inv=dsc_inv(itypj)
1868 dscj_inv=vbld_inv(j+nres)
1869 chi1=chi(itypi,itypj)
1870 chi2=chi(itypj,itypi)
1877 alf12=0.5D0*(alf1+alf2)
1878 C For diagnostics only!!!
1891 call to_box(xj,yj,zj)
1892 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1893 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1894 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1895 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1896 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1897 xj=boxshift(xj-xi,boxxsize)
1898 yj=boxshift(yj-yi,boxysize)
1899 zj=boxshift(zj-zi,boxzsize)
1900 dxj=dc_norm(1,nres+j)
1901 dyj=dc_norm(2,nres+j)
1902 dzj=dc_norm(3,nres+j)
1903 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1904 cd if (icall.eq.0) then
1910 sss1=sscale(1.0d0/rij,r_cut_int)
1911 if (sss1.eq.0.0d0) cycle
1912 sssgrad1=sscagrad(1.0d0/rij,r_cut_int)
1913 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1915 C Calculate whole angle-dependent part of epsilon and contributions
1916 C to its derivatives
1917 C have you changed here?
1918 fac=(rrij*sigsq)**expon2
1922 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1923 eps2der=evdwij*eps3rt
1924 eps3der=evdwij*eps2rt
1925 evdwij=evdwij*eps2rt*eps3rt
1926 evdw=evdw+sss1*evdwij
1928 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1930 cd write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1931 cd & restyp(itypi),i,restyp(itypj),j,
1932 cd & epsi,sigm,chi1,chi2,chip1,chip2,
1933 cd & eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1934 cd & om1,om2,om12,1.0D0/dsqrt(rrij),
1937 C Calculate gradient components.
1938 e1=e1*eps1*eps2rt**2*eps3rt**2
1939 fac=-expon*(e1+evdwij)
1942 & +evdwij*sssgrad1/sss1*rij
1943 C Calculate radial part of the gradient
1947 gg_lipi(3)=eps1*(eps2rt*eps2rt)
1948 & *(eps3rt*eps3rt)*sss1/2.0d0*(faclip*faclip*
1949 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1950 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1951 gg_lipj(3)=ssgradlipj*gg_lipi(3)
1952 gg_lipi(3)=gg_lipi(3)*ssgradlipi
1953 C Calculate the angular part of the gradient and sum add the contributions
1954 C to the appropriate components of the Cartesian gradient.
1962 C-----------------------------------------------------------------------------
1963 subroutine egb(evdw)
1965 C This subroutine calculates the interaction energy of nonbonded side chains
1966 C assuming the Gay-Berne potential of interaction.
1969 include 'DIMENSIONS'
1970 include 'COMMON.GEO'
1971 include 'COMMON.VAR'
1972 include 'COMMON.LOCAL'
1973 include 'COMMON.CHAIN'
1974 include 'COMMON.DERIV'
1975 include 'COMMON.NAMES'
1976 include 'COMMON.INTERACT'
1977 include 'COMMON.IOUNITS'
1978 include 'COMMON.CALC'
1979 include 'COMMON.CONTROL'
1980 include 'COMMON.SPLITELE'
1981 include 'COMMON.SBRIDGE'
1983 double precision evdw
1984 integer itypi,itypj,itypi1,iint,ind,ikont
1985 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,xi,yi,zi
1986 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
1987 & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip
1988 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
1989 double precision boxshift
1991 ccccc energy_dec=.false.
1992 C print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1996 c if (icall.eq.0) lprn=.false.
1998 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1999 C we have the original box)
2003 c do i=iatsc_s,iatsc_e
2004 do ikont=g_listscsc_start,g_listscsc_end
2005 i=newcontlisti(ikont)
2006 j=newcontlistj(ikont)
2007 itypi=iabs(itype(i))
2008 if (itypi.eq.ntyp1) cycle
2009 itypi1=iabs(itype(i+1))
2013 call to_box(xi,yi,zi)
2014 C define scaling factor for lipids
2016 C if (positi.le.0) positi=positi+boxzsize
2018 C first for peptide groups
2019 c for each residue check if it is in lipid or lipid water border area
2020 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2021 C xi=xi+xshift*boxxsize
2022 C yi=yi+yshift*boxysize
2023 C zi=zi+zshift*boxzsize
2025 dxi=dc_norm(1,nres+i)
2026 dyi=dc_norm(2,nres+i)
2027 dzi=dc_norm(3,nres+i)
2028 c dsci_inv=dsc_inv(itypi)
2029 dsci_inv=vbld_inv(i+nres)
2030 c write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
2031 c write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
2033 C Calculate SC interaction energy.
2035 c do iint=1,nint_gr(i)
2036 c do j=istart(i,iint),iend(i,iint)
2037 IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
2039 c write(iout,*) "PRZED ZWYKLE", evdwij
2040 call dyn_ssbond_ene(i,j,evdwij)
2041 c write(iout,*) "PO ZWYKLE", evdwij
2044 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2045 & 'evdw',i,j,evdwij,' ss'
2046 C triple bond artifac removal
2047 c do k=j+1,iend(i,iint)
2049 C search over all next residues
2050 if (dyn_ss_mask(k)) then
2051 C check if they are cysteins
2052 C write(iout,*) 'k=',k
2054 c write(iout,*) "PRZED TRI", evdwij
2055 evdwij_przed_tri=evdwij
2056 call triple_ssbond_ene(i,j,k,evdwij)
2057 c if(evdwij_przed_tri.ne.evdwij) then
2058 c write (iout,*) "TRI:", evdwij, evdwij_przed_tri
2061 c write(iout,*) "PO TRI", evdwij
2062 C call the energy function that removes the artifical triple disulfide
2063 C bond the soubroutine is located in ssMD.F
2065 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
2066 & 'evdw',i,j,evdwij,'tss'
2067 endif!dyn_ss_mask(k)
2071 itypj=iabs(itype(j))
2072 if (itypj.eq.ntyp1) cycle
2073 c dscj_inv=dsc_inv(itypj)
2074 dscj_inv=vbld_inv(j+nres)
2075 c write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
2076 c & 1.0d0/vbld(j+nres)
2077 c write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
2078 sig0ij=sigma(itypi,itypj)
2079 chi1=chi(itypi,itypj)
2080 chi2=chi(itypj,itypi)
2087 alf12=0.5D0*(alf1+alf2)
2088 C For diagnostics only!!!
2101 call to_box(xj,yj,zj)
2102 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2103 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2104 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2105 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2106 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2107 c write (iout,*) "aa bb",aa_lip(itypi,itypj),
2108 c & bb_lip(itypi,itypj),aa_aq(itypi,itypj),
2109 c & bb_aq(itypi,itypj),aa,bb
2110 c write (iout,*) (sslipi+sslipj)/2.0d0,
2111 c & (2.0d0-sslipi-sslipj)/2.0d0
2113 c write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
2114 c if (aa.ne.aa_aq(itypi,itypj)) write(iout,'(2e15.5)')
2115 c &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2116 C if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
2117 C print *,sslipi,sslipj,bordlipbot,zi,zj
2118 xj=boxshift(xj-xi,boxxsize)
2119 yj=boxshift(yj-yi,boxysize)
2120 zj=boxshift(zj-zi,boxzsize)
2121 dxj=dc_norm(1,nres+j)
2122 dyj=dc_norm(2,nres+j)
2123 dzj=dc_norm(3,nres+j)
2127 c write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2128 c write (iout,*) "j",j," dc_norm",
2129 c & dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2130 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2132 sss=sscale(1.0d0/rij,r_cut_int)
2133 c write (iout,'(a7,4f8.3)')
2134 c & "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
2135 if (sss.eq.0.0d0) cycle
2136 sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2137 C Calculate angle-dependent terms of energy and contributions to their
2141 sig=sig0ij*dsqrt(sigsq)
2142 rij_shift=1.0D0/rij-sig+sig0ij
2144 c & write (iout,*) "rij",1.0d0/rij," rij_shift",rij_shift,
2145 c & " sig",sig," sig0ij",sig0ij
2146 c for diagnostics; uncomment
2147 c rij_shift=1.2*sig0ij
2148 C I hate to put IF's in the loops, but here don't have another choice!!!!
2149 if (rij_shift.le.0.0D0) then
2151 cd write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2152 cd & restyp(itypi),i,restyp(itypj),j,
2153 cd & rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2157 c---------------------------------------------------------------
2158 rij_shift=1.0D0/rij_shift
2159 fac=rij_shift**expon
2160 C here to start with
2165 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2166 eps2der=evdwij*eps3rt
2167 eps3der=evdwij*eps2rt
2168 C write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
2169 C &((sslipi+sslipj)/2.0d0+
2170 C &(2.0d0-sslipi-sslipj)/2.0d0)
2171 c write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
2172 c & " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
2173 evdwij=evdwij*eps2rt*eps3rt
2174 evdw=evdw+evdwij*sss
2176 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2178 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2179 & restyp(itypi),i,restyp(itypj),j,
2180 & epsi,sigm,chi1,chi2,chip1,chip2,
2181 & eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
2182 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2186 if (energy_dec) write (iout,'(a,2i5,4f10.5,e15.5)')
2187 & 'r sss evdw',i,j,1.0d0/rij,sss,sslipi,sslipj,evdwij
2189 C Calculate gradient components.
2190 e1=e1*eps1*eps2rt**2*eps3rt**2
2191 fac=-expon*(e1+evdwij)*rij_shift
2194 c print '(2i4,6f8.4)',i,j,sss,sssgrad*
2195 c & evdwij,fac,sigma(itypi,itypj),expon
2196 fac=fac+evdwij*sssgrad/sss*rij
2198 C Calculate the radial part of the gradient
2199 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2200 & *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2201 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2202 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2203 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2204 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2210 C Calculate angular part of the gradient.
2211 c call sc_grad_scale(sss)
2220 c write (iout,*) "Number of loop steps in EGB:",ind
2221 cccc energy_dec=.false.
2224 C-----------------------------------------------------------------------------
2225 subroutine egbv(evdw)
2227 C This subroutine calculates the interaction energy of nonbonded side chains
2228 C assuming the Gay-Berne-Vorobjev potential of interaction.
2231 include 'DIMENSIONS'
2232 include 'COMMON.GEO'
2233 include 'COMMON.VAR'
2234 include 'COMMON.LOCAL'
2235 include 'COMMON.CHAIN'
2236 include 'COMMON.DERIV'
2237 include 'COMMON.NAMES'
2238 include 'COMMON.INTERACT'
2239 include 'COMMON.IOUNITS'
2240 include 'COMMON.CALC'
2241 include 'COMMON.SPLITELE'
2242 double precision boxshift
2244 common /srutu/ icall
2246 double precision evdw
2247 integer itypi,itypj,itypi1,iint,ind,ikont
2248 double precision eps0ij,epsi,sigm,fac,e1,e2,rrij,r0ij,
2249 & xi,yi,zi,fac_augm,e_augm
2250 double precision fracinbuf,sslipi,evdwij_przed_tri,sig0ij,
2251 & sslipj,ssgradlipj,ssgradlipi,sig,rij_shift,faclip,sssgrad1
2252 double precision dist,sscale,sscagrad,sscagradlip,sscalelip
2254 c print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2258 c if (icall.eq.0) lprn=.true.
2260 c do i=iatsc_s,iatsc_e
2261 do ikont=g_listscsc_start,g_listscsc_end
2262 i=newcontlisti(ikont)
2263 j=newcontlistj(ikont)
2264 itypi=iabs(itype(i))
2265 if (itypi.eq.ntyp1) cycle
2266 itypi1=iabs(itype(i+1))
2270 call to_box(xi,yi,zi)
2271 C define scaling factor for lipids
2273 C if (positi.le.0) positi=positi+boxzsize
2275 C first for peptide groups
2276 c for each residue check if it is in lipid or lipid water border area
2277 call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2278 dxi=dc_norm(1,nres+i)
2279 dyi=dc_norm(2,nres+i)
2280 dzi=dc_norm(3,nres+i)
2281 c dsci_inv=dsc_inv(itypi)
2282 dsci_inv=vbld_inv(i+nres)
2284 C Calculate SC interaction energy.
2286 c do iint=1,nint_gr(i)
2287 c do j=istart(i,iint),iend(i,iint)
2289 itypj=iabs(itype(j))
2290 if (itypj.eq.ntyp1) cycle
2291 c dscj_inv=dsc_inv(itypj)
2292 dscj_inv=vbld_inv(j+nres)
2293 sig0ij=sigma(itypi,itypj)
2294 r0ij=r0(itypi,itypj)
2295 chi1=chi(itypi,itypj)
2296 chi2=chi(itypj,itypi)
2303 alf12=0.5D0*(alf1+alf2)
2304 C For diagnostics only!!!
2317 call to_box(xj,yj,zj)
2318 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2319 aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2320 & +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2321 bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2322 & +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2323 C if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2324 C &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2325 C write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2326 xj=boxshift(xj-xi,boxxsize)
2327 yj=boxshift(yj-yi,boxysize)
2328 zj=boxshift(zj-zi,boxzsize)
2329 dxj=dc_norm(1,nres+j)
2330 dyj=dc_norm(2,nres+j)
2331 dzj=dc_norm(3,nres+j)
2332 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2334 sss=sscale(1.0d0/rij,r_cut_int)
2335 if (sss.eq.0.0d0) cycle
2336 sssgrad=sscagrad(1.0d0/rij,r_cut_int)
2337 C Calculate angle-dependent terms of energy and contributions to their
2341 sig=sig0ij*dsqrt(sigsq)
2342 rij_shift=1.0D0/rij-sig+r0ij
2343 C I hate to put IF's in the loops, but here don't have another choice!!!!
2344 if (rij_shift.le.0.0D0) then
2349 c---------------------------------------------------------------
2350 rij_shift=1.0D0/rij_shift
2351 fac=rij_shift**expon
2355 evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2356 eps2der=evdwij*eps3rt
2357 eps3der=evdwij*eps2rt
2358 fac_augm=rrij**expon
2359 e_augm=augm(itypi,itypj)*fac_augm
2360 evdwij=evdwij*eps2rt*eps3rt
2361 evdw=evdw+evdwij+e_augm
2363 sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2365 write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2366 & restyp(itypi),i,restyp(itypj),j,
2367 & epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2368 & chi1,chi2,chip1,chip2,
2369 & eps1,eps2rt**2,eps3rt**2,
2370 & om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2373 C Calculate gradient components.
2374 e1=e1*eps1*eps2rt**2*eps3rt**2
2375 fac=-expon*(e1+evdwij)*rij_shift
2377 fac=rij*fac-2*expon*rrij*e_augm
2378 fac=fac+(evdwij+e_augm)*sssgrad/sss*rij
2379 C Calculate the radial part of the gradient
2380 gg_lipi(3)=eps1*(eps2rt*eps2rt)
2381 & *(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
2382 & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
2383 & +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2384 gg_lipj(3)=ssgradlipj*gg_lipi(3)
2385 gg_lipi(3)=gg_lipi(3)*ssgradlipi
2389 C Calculate angular part of the gradient.
2390 c call sc_grad_scale(sss)
2396 C-----------------------------------------------------------------------------
2397 subroutine sc_angular
2398 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2399 C om12. Called by ebp, egb, and egbv.
2401 include 'COMMON.CALC'
2402 include 'COMMON.IOUNITS'
2406 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2407 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2408 om12=dxi*dxj+dyi*dyj+dzi*dzj
2410 C Calculate eps1(om12) and its derivative in om12
2411 faceps1=1.0D0-om12*chiom12
2412 faceps1_inv=1.0D0/faceps1
2413 eps1=dsqrt(faceps1_inv)
2414 C Following variable is eps1*deps1/dom12
2415 eps1_om12=faceps1_inv*chiom12
2420 c write (iout,*) "om12",om12," eps1",eps1
2421 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2426 facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2427 sigsq=1.0D0-facsig*faceps1_inv
2428 sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2429 sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2430 sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2436 c write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2437 c write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2439 C Calculate eps2 and its derivatives in om1, om2, and om12.
2442 chipom12=chip12*om12
2443 facp=1.0D0-om12*chipom12
2445 facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2446 c write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2447 c & " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2448 C Following variable is the square root of eps2
2449 eps2rt=1.0D0-facp1*facp_inv
2450 C Following three variables are the derivatives of the square root of eps
2451 C in om1, om2, and om12.
2452 eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2453 eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2454 eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2455 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2456 eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2457 c write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2458 c write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2459 c & " eps2rt_om12",eps2rt_om12
2460 C Calculate whole angle-dependent part of epsilon and contributions
2461 C to its derivatives
2464 C----------------------------------------------------------------------------
2466 implicit real*8 (a-h,o-z)
2467 include 'DIMENSIONS'
2468 include 'COMMON.CHAIN'
2469 include 'COMMON.DERIV'
2470 include 'COMMON.CALC'
2471 include 'COMMON.IOUNITS'
2472 double precision dcosom1(3),dcosom2(3)
2473 cc print *,'sss=',sss
2474 eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2475 eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2476 eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2477 & -2.0D0*alf12*eps3der+sigder*sigsq_om12
2481 c eom12=evdwij*eps1_om12
2483 c write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2484 c & " sigder",sigder
2485 c write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2486 c write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2488 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2489 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2492 gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2494 c write (iout,*) "gg",(gg(k),k=1,3)
2496 gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2497 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2498 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2499 gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2500 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2501 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2502 c write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2503 c & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2504 c write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2505 c & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2508 C Calculate the components of the gradient in DC and X
2512 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2516 gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2517 gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2521 C-----------------------------------------------------------------------
2522 subroutine e_softsphere(evdw)
2524 C This subroutine calculates the interaction energy of nonbonded side chains
2525 C assuming the LJ potential of interaction.
2527 implicit real*8 (a-h,o-z)
2528 include 'DIMENSIONS'
2529 parameter (accur=1.0d-10)
2530 include 'COMMON.GEO'
2531 include 'COMMON.VAR'
2532 include 'COMMON.LOCAL'
2533 include 'COMMON.CHAIN'
2534 include 'COMMON.DERIV'
2535 include 'COMMON.INTERACT'
2536 include 'COMMON.TORSION'
2537 include 'COMMON.SBRIDGE'
2538 include 'COMMON.NAMES'
2539 include 'COMMON.IOUNITS'
2540 c include 'COMMON.CONTACTS'
2542 double precision boxshift
2543 cd print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2545 c do i=iatsc_s,iatsc_e
2546 do ikont=g_listscsc_start,g_listscsc_end
2547 i=newcontlisti(ikont)
2548 j=newcontlistj(ikont)
2549 itypi=iabs(itype(i))
2550 if (itypi.eq.ntyp1) cycle
2551 itypi1=iabs(itype(i+1))
2555 call to_box(xi,yi,zi)
2557 C Calculate SC interaction energy.
2559 c do iint=1,nint_gr(i)
2560 cd write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2561 cd & 'iend=',iend(i,iint)
2562 c do j=istart(i,iint),iend(i,iint)
2563 itypj=iabs(itype(j))
2564 if (itypj.eq.ntyp1) cycle
2565 xj=boxshift(c(1,nres+j)-xi,boxxsize)
2566 yj=boxshift(c(2,nres+j)-yi,boxysize)
2567 zj=boxshift(c(3,nres+j)-zi,boxzsize)
2568 rij=xj*xj+yj*yj+zj*zj
2569 c write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2570 r0ij=r0(itypi,itypj)
2572 c print *,i,j,r0ij,dsqrt(rij)
2573 if (rij.lt.r0ijsq) then
2574 evdwij=0.25d0*(rij-r0ijsq)**2
2582 C Calculate the components of the gradient in DC and X
2588 gvdwx(k,i)=gvdwx(k,i)-gg(k)
2589 gvdwx(k,j)=gvdwx(k,j)+gg(k)
2590 gvdwc(k,i)=gvdwc(k,i)-gg(k)
2591 gvdwc(k,j)=gvdwc(k,j)+gg(k)
2595 cgrad gvdwc(l,k)=gvdwc(l,k)+gg(l)
2603 C--------------------------------------------------------------------------
2604 subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2607 C Soft-sphere potential of p-p interaction
2609 implicit real*8 (a-h,o-z)
2610 include 'DIMENSIONS'
2611 include 'COMMON.CONTROL'
2612 include 'COMMON.IOUNITS'
2613 include 'COMMON.GEO'
2614 include 'COMMON.VAR'
2615 include 'COMMON.LOCAL'
2616 include 'COMMON.CHAIN'
2617 include 'COMMON.DERIV'
2618 include 'COMMON.INTERACT'
2619 c include 'COMMON.CONTACTS'
2620 include 'COMMON.TORSION'
2621 include 'COMMON.VECTORS'
2622 include 'COMMON.FFIELD'
2624 double precision boxshift
2625 C write(iout,*) 'In EELEC_soft_sphere'
2632 do i=iatel_s,iatel_e
2633 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2637 xmedi=c(1,i)+0.5d0*dxi
2638 ymedi=c(2,i)+0.5d0*dyi
2639 zmedi=c(3,i)+0.5d0*dzi
2640 call to_box(xmedi,ymedi,zmedi)
2642 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2643 do j=ielstart(i),ielend(i)
2644 if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2648 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2649 r0ij=rpp(iteli,itelj)
2657 call to_box(xj,yj,zj)
2658 xj=boxshift(xj-xmedi,boxxsize)
2659 yj=boxshift(yj-ymedi,boxysize)
2660 zj=boxshift(zj-zmedi,boxzsize)
2661 rij=xj*xj+yj*yj+zj*zj
2662 sss=sscale(sqrt(rij),r_cut_int)
2663 sssgrad=sscagrad(sqrt(rij),r_cut_int)
2664 if (rij.lt.r0ijsq) then
2665 evdw1ij=0.25d0*(rij-r0ijsq)**2
2671 evdw1=evdw1+evdw1ij*sss
2673 C Calculate contributions to the Cartesian gradient.
2675 ggg(1)=fac*xj*sssgrad
2676 ggg(2)=fac*yj*sssgrad
2677 ggg(3)=fac*zj*sssgrad
2679 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2680 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2683 * Loop over residues i+1 thru j-1.
2687 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
2692 cgrad do i=nnt,nct-1
2694 cgrad gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2696 cgrad do j=i+1,nct-1
2698 cgrad gelc(k,i)=gelc(k,i)+gelc(k,j)
2704 c------------------------------------------------------------------------------
2705 subroutine vec_and_deriv
2706 implicit real*8 (a-h,o-z)
2707 include 'DIMENSIONS'
2711 include 'COMMON.IOUNITS'
2712 include 'COMMON.GEO'
2713 include 'COMMON.VAR'
2714 include 'COMMON.LOCAL'
2715 include 'COMMON.CHAIN'
2716 include 'COMMON.VECTORS'
2717 include 'COMMON.SETUP'
2718 include 'COMMON.TIME1'
2719 dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2720 C Compute the local reference systems. For reference system (i), the
2721 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2722 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2724 do i=ivec_start,ivec_end
2728 if (i.eq.nres-1) then
2729 C Case of the last full residue
2730 C Compute the Z-axis
2731 call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2732 costh=dcos(pi-theta(nres))
2733 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2737 C Compute the derivatives of uz
2739 uzder(2,1,1)=-dc_norm(3,i-1)
2740 uzder(3,1,1)= dc_norm(2,i-1)
2741 uzder(1,2,1)= dc_norm(3,i-1)
2743 uzder(3,2,1)=-dc_norm(1,i-1)
2744 uzder(1,3,1)=-dc_norm(2,i-1)
2745 uzder(2,3,1)= dc_norm(1,i-1)
2748 uzder(2,1,2)= dc_norm(3,i)
2749 uzder(3,1,2)=-dc_norm(2,i)
2750 uzder(1,2,2)=-dc_norm(3,i)
2752 uzder(3,2,2)= dc_norm(1,i)
2753 uzder(1,3,2)= dc_norm(2,i)
2754 uzder(2,3,2)=-dc_norm(1,i)
2756 C Compute the Y-axis
2759 uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2761 C Compute the derivatives of uy
2764 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2765 & -dc_norm(k,i)*dc_norm(j,i-1)
2766 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2768 uyder(j,j,1)=uyder(j,j,1)-costh
2769 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2774 uygrad(l,k,j,i)=uyder(l,k,j)
2775 uzgrad(l,k,j,i)=uzder(l,k,j)
2779 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2780 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2781 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2782 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2785 C Compute the Z-axis
2786 call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2787 costh=dcos(pi-theta(i+2))
2788 fac=1.0d0/dsqrt(1.0d0-costh*costh)
2792 C Compute the derivatives of uz
2794 uzder(2,1,1)=-dc_norm(3,i+1)
2795 uzder(3,1,1)= dc_norm(2,i+1)
2796 uzder(1,2,1)= dc_norm(3,i+1)
2798 uzder(3,2,1)=-dc_norm(1,i+1)
2799 uzder(1,3,1)=-dc_norm(2,i+1)
2800 uzder(2,3,1)= dc_norm(1,i+1)
2803 uzder(2,1,2)= dc_norm(3,i)
2804 uzder(3,1,2)=-dc_norm(2,i)
2805 uzder(1,2,2)=-dc_norm(3,i)
2807 uzder(3,2,2)= dc_norm(1,i)
2808 uzder(1,3,2)= dc_norm(2,i)
2809 uzder(2,3,2)=-dc_norm(1,i)
2811 C Compute the Y-axis
2814 uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2816 C Compute the derivatives of uy
2819 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2820 & -dc_norm(k,i)*dc_norm(j,i+1)
2821 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2823 uyder(j,j,1)=uyder(j,j,1)-costh
2824 uyder(j,j,2)=1.0d0+uyder(j,j,2)
2829 uygrad(l,k,j,i)=uyder(l,k,j)
2830 uzgrad(l,k,j,i)=uzder(l,k,j)
2834 call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2835 call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2836 call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2837 call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2841 vbld_inv_temp(1)=vbld_inv(i+1)
2842 if (i.lt.nres-1) then
2843 vbld_inv_temp(2)=vbld_inv(i+2)
2845 vbld_inv_temp(2)=vbld_inv(i)
2850 uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2851 uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2856 #if defined(PARVEC) && defined(MPI)
2857 if (nfgtasks1.gt.1) then
2859 c print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2860 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2861 c & " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2862 call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2863 & MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2865 call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2866 & MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2868 call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2869 & ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2870 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2871 call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2872 & ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2873 & ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2874 time_gather=time_gather+MPI_Wtime()-time00
2878 if (fg_rank.eq.0) then
2879 write (iout,*) "Arrays UY and UZ"
2881 write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2888 C--------------------------------------------------------------------------
2889 subroutine set_matrices
2890 implicit real*8 (a-h,o-z)
2891 include 'DIMENSIONS'
2894 include "COMMON.SETUP"
2896 integer status(MPI_STATUS_SIZE)
2898 include 'COMMON.IOUNITS'
2899 include 'COMMON.GEO'
2900 include 'COMMON.VAR'
2901 include 'COMMON.LOCAL'
2902 include 'COMMON.CHAIN'
2903 include 'COMMON.DERIV'
2904 include 'COMMON.INTERACT'
2905 include 'COMMON.CORRMAT'
2906 include 'COMMON.TORSION'
2907 include 'COMMON.VECTORS'
2908 include 'COMMON.FFIELD'
2909 double precision auxvec(2),auxmat(2,2)
2911 C Compute the virtual-bond-torsional-angle dependent quantities needed
2912 C to calculate the el-loc multibody terms of various order.
2914 c write(iout,*) 'nphi=',nphi,nres
2915 c write(iout,*) "itype2loc",itype2loc
2917 do i=ivec_start+2,ivec_end+2
2922 c write (iout,*) "i",i,i-2," ii",ii
2924 innt=chain_border(1,ii)
2925 inct=chain_border(2,ii)
2926 c write (iout,*) "i",i,i-2," ii",ii," innt",innt," inct",inct
2927 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
2928 if (i.gt. innt+2 .and. i.lt.inct+2) then
2929 iti = itype2loc(itype(i-2))
2933 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2934 if (i.gt. innt+1 .and. i.lt.inct+1) then
2935 iti1 = itype2loc(itype(i-1))
2939 c write(iout,*),"i",i,i-2," iti",itype(i-2),iti,
2940 c & " iti1",itype(i-1),iti1
2942 cost1=dcos(theta(i-1))
2943 sint1=dsin(theta(i-1))
2945 sint1cub=sint1sq*sint1
2946 sint1cost1=2*sint1*cost1
2947 c write (iout,*) "bnew1",i,iti
2948 c write (iout,*) (bnew1(k,1,iti),k=1,3)
2949 c write (iout,*) (bnew1(k,2,iti),k=1,3)
2950 c write (iout,*) "bnew2",i,iti
2951 c write (iout,*) (bnew2(k,1,iti),k=1,3)
2952 c write (iout,*) (bnew2(k,2,iti),k=1,3)
2954 b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2956 gtb1(k,i-2)=cost1*b1k-sint1sq*
2957 & (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2958 b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2960 gtb2(k,i-2)=cost1*b2k-sint1sq*
2961 & (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2964 aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2965 cc(1,k,i-2)=sint1sq*aux
2966 gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2967 & (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2968 aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2969 dd(1,k,i-2)=sint1sq*aux
2970 gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2971 & (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2973 cc(2,1,i-2)=cc(1,2,i-2)
2974 cc(2,2,i-2)=-cc(1,1,i-2)
2975 gtcc(2,1,i-2)=gtcc(1,2,i-2)
2976 gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2977 dd(2,1,i-2)=dd(1,2,i-2)
2978 dd(2,2,i-2)=-dd(1,1,i-2)
2979 gtdd(2,1,i-2)=gtdd(1,2,i-2)
2980 gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2983 aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2984 EE(l,k,i-2)=sint1sq*aux
2985 gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2988 EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2989 EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2990 EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2991 EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2992 gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2993 gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2994 gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2995 c b1tilde(1,i-2)=b1(1,i-2)
2996 c b1tilde(2,i-2)=-b1(2,i-2)
2997 c b2tilde(1,i-2)=b2(1,i-2)
2998 c b2tilde(2,i-2)=-b2(2,i-2)
3000 write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3001 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3002 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3003 write (iout,*) 'theta=', theta(i-1)
3006 if (i.gt. innt+2 .and. i.lt.inct+2) then
3007 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3008 iti = itype2loc(itype(i-2))
3012 c write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
3013 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3014 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3015 iti1 = itype2loc(itype(i-1))
3025 CC(k,l,i-2)=ccold(k,l,iti)
3026 DD(k,l,i-2)=ddold(k,l,iti)
3027 EE(k,l,i-2)=eeold(k,l,iti)
3032 b1tilde(1,i-2)= b1(1,i-2)
3033 b1tilde(2,i-2)=-b1(2,i-2)
3034 b2tilde(1,i-2)= b2(1,i-2)
3035 b2tilde(2,i-2)=-b2(2,i-2)
3037 Ctilde(1,1,i-2)= CC(1,1,i-2)
3038 Ctilde(1,2,i-2)= CC(1,2,i-2)
3039 Ctilde(2,1,i-2)=-CC(2,1,i-2)
3040 Ctilde(2,2,i-2)=-CC(2,2,i-2)
3042 Dtilde(1,1,i-2)= DD(1,1,i-2)
3043 Dtilde(1,2,i-2)= DD(1,2,i-2)
3044 Dtilde(2,1,i-2)=-DD(2,1,i-2)
3045 Dtilde(2,2,i-2)=-DD(2,2,i-2)
3047 write(iout,*) "i",i," iti",iti
3048 write(iout,*) 'b1=',(b1(k,i-2),k=1,2)
3049 write(iout,*) 'b2=',(b2(k,i-2),k=1,2)
3054 do i=ivec_start+2,ivec_end+2
3058 c if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
3059 if (i .lt. nres+1 .and. itype(i-1).lt.ntyp1) then
3097 obrot_der(1,i-2)=-sin1
3098 obrot_der(2,i-2)= cos1
3099 Ugder(1,1,i-2)= sin1
3100 Ugder(1,2,i-2)=-cos1
3101 Ugder(2,1,i-2)=-cos1
3102 Ugder(2,2,i-2)=-sin1
3105 obrot2_der(1,i-2)=-dwasin2
3106 obrot2_der(2,i-2)= dwacos2
3107 Ug2der(1,1,i-2)= dwasin2
3108 Ug2der(1,2,i-2)=-dwacos2
3109 Ug2der(2,1,i-2)=-dwacos2
3110 Ug2der(2,2,i-2)=-dwasin2
3112 obrot_der(1,i-2)=0.0d0
3113 obrot_der(2,i-2)=0.0d0
3114 Ugder(1,1,i-2)=0.0d0
3115 Ugder(1,2,i-2)=0.0d0
3116 Ugder(2,1,i-2)=0.0d0
3117 Ugder(2,2,i-2)=0.0d0
3118 obrot2_der(1,i-2)=0.0d0
3119 obrot2_der(2,i-2)=0.0d0
3120 Ug2der(1,1,i-2)=0.0d0
3121 Ug2der(1,2,i-2)=0.0d0
3122 Ug2der(2,1,i-2)=0.0d0
3123 Ug2der(2,2,i-2)=0.0d0
3125 c if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3126 c if (i.gt. nnt+2 .and. i.lt.nct+2) then
3127 if (i.gt.nnt+2 .and.i.lt.nct+2) then
3128 iti = itype2loc(itype(i-2))
3132 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3133 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3134 iti1 = itype2loc(itype(i-1))
3138 cd write (iout,*) '*******i',i,' iti1',iti
3139 cd write (iout,*) 'b1',b1(:,iti)
3140 cd write (iout,*) 'b2',b2(:,iti)
3141 cd write (iout,*) 'Ug',Ug(:,:,i-2)
3142 c if (i .gt. iatel_s+2) then
3143 if (i .gt. nnt+2) then
3144 call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3146 call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3147 c write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3149 c write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3150 c & EE(1,2,iti),EE(2,2,i)
3151 call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3152 call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3153 c write(iout,*) "Macierz EUG",
3154 c & eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3157 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3159 call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3160 call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3161 call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3162 call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3163 call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3175 DtUg2(l,k,i-2)=0.0d0
3179 call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3180 call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3182 muder(k,i-2)=Ub2der(k,i-2)
3184 c if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3185 if (i.gt. nnt+1 .and. i.lt.nct+1) then
3186 if (itype(i-1).le.ntyp) then
3187 iti1 = itype2loc(itype(i-1))
3195 mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3196 c mu(k,i-2)=b1(k,i-1)
3197 c mu(k,i-2)=Ub2(k,i-2)
3200 write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3201 & rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3202 & -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3203 & dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3204 & +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3205 & ((ee(l,k,i-2),l=1,2),k=1,2)
3207 cd write (iout,*) 'mu1',mu1(:,i-2)
3208 cd write (iout,*) 'mu2',mu2(:,i-2)
3209 cd write (iout,*) 'mu',i-2,mu(:,i-2)
3211 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3213 call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3214 call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3215 call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3216 call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3217 call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3218 C Vectors and matrices dependent on a single virtual-bond dihedral.
3219 call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3220 call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3221 call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3222 call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3223 call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3224 call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3225 call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3226 call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3227 call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3232 C Matrices dependent on two consecutive virtual-bond dihedrals.
3233 C The order of matrices is from left to right.
3234 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3236 c do i=max0(ivec_start,2),ivec_end
3238 call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3239 call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3240 call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3241 call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3242 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3243 call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3244 call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3245 call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3249 #if defined(MPI) && defined(PARMAT)
3251 c if (fg_rank.eq.0) then
3252 write (iout,*) "Arrays UG and UGDER before GATHER"
3254 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3255 & ((ug(l,k,i),l=1,2),k=1,2),
3256 & ((ugder(l,k,i),l=1,2),k=1,2)
3258 write (iout,*) "Arrays UG2 and UG2DER"
3260 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3261 & ((ug2(l,k,i),l=1,2),k=1,2),
3262 & ((ug2der(l,k,i),l=1,2),k=1,2)
3264 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3266 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3267 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3268 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3270 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3272 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3273 & costab(i),sintab(i),costab2(i),sintab2(i)
3275 write (iout,*) "Array MUDER"
3277 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3281 if (nfgtasks.gt.1) then
3283 c write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3284 c & " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3285 c & " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3287 call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3288 & MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3290 call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3291 & MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3293 call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3294 & MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3296 call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3297 & MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3299 call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3300 & MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3302 call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3303 & MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3305 call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3306 & MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3307 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3308 call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3309 & MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3310 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3311 call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3312 & MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3313 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3314 call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3315 & MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3316 & MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3318 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3320 call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3321 & MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3323 call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3324 & MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3326 call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3327 & MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3329 call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3330 & MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3332 call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3333 & MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3335 call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3336 & ivec_count(fg_rank1),
3337 & MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3339 call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3340 & MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3342 call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3343 & MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3345 call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3346 & MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3348 call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3349 & MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3351 call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3352 & MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3354 call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3355 & MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3357 call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3358 & MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3360 call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3361 & ivec_count(fg_rank1),
3362 & MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3364 call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3365 & MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3367 call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3368 & MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3370 call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3371 & MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3373 call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3374 & MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3376 call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3377 & ivec_count(fg_rank1),
3378 & MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3380 call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3381 & ivec_count(fg_rank1),
3382 & MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3384 call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3385 & ivec_count(fg_rank1),
3386 & MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3387 & MPI_MAT2,FG_COMM1,IERR)
3388 call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3389 & ivec_count(fg_rank1),
3390 & MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3391 & MPI_MAT2,FG_COMM1,IERR)
3395 c Passes matrix info through the ring
3398 if (irecv.lt.0) irecv=nfgtasks1-1
3401 if (inext.ge.nfgtasks1) inext=0
3403 c write (iout,*) "isend",isend," irecv",irecv
3405 lensend=lentyp(isend)
3406 lenrecv=lentyp(irecv)
3407 c write (iout,*) "lensend",lensend," lenrecv",lenrecv
3408 c call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3409 c & MPI_ROTAT1(lensend),inext,2200+isend,
3410 c & ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3411 c & iprev,2200+irecv,FG_COMM,status,IERR)
3412 c write (iout,*) "Gather ROTAT1"
3414 c call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3415 c & MPI_ROTAT2(lensend),inext,3300+isend,
3416 c & obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3417 c & iprev,3300+irecv,FG_COMM,status,IERR)
3418 c write (iout,*) "Gather ROTAT2"
3420 call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3421 & MPI_ROTAT_OLD(lensend),inext,4400+isend,
3422 & costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3423 & iprev,4400+irecv,FG_COMM,status,IERR)
3424 c write (iout,*) "Gather ROTAT_OLD"
3426 call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3427 & MPI_PRECOMP11(lensend),inext,5500+isend,
3428 & mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3429 & iprev,5500+irecv,FG_COMM,status,IERR)
3430 c write (iout,*) "Gather PRECOMP11"
3432 call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3433 & MPI_PRECOMP12(lensend),inext,6600+isend,
3434 & Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3435 & iprev,6600+irecv,FG_COMM,status,IERR)
3436 c write (iout,*) "Gather PRECOMP12"
3439 if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3441 call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3442 & MPI_ROTAT2(lensend),inext,7700+isend,
3443 & ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3444 & iprev,7700+irecv,FG_COMM,status,IERR)
3445 c write (iout,*) "Gather PRECOMP21"
3447 call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3448 & MPI_PRECOMP22(lensend),inext,8800+isend,
3449 & EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3450 & iprev,8800+irecv,FG_COMM,status,IERR)
3451 c write (iout,*) "Gather PRECOMP22"
3453 call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3454 & MPI_PRECOMP23(lensend),inext,9900+isend,
3455 & Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3456 & MPI_PRECOMP23(lenrecv),
3457 & iprev,9900+irecv,FG_COMM,status,IERR)
3459 c write (iout,*) "Gather PRECOMP23"
3464 if (irecv.lt.0) irecv=nfgtasks1-1
3467 time_gather=time_gather+MPI_Wtime()-time00
3470 c if (fg_rank.eq.0) then
3471 write (iout,*) "Arrays UG and UGDER"
3473 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3474 & ((ug(l,k,i),l=1,2),k=1,2),
3475 & ((ugder(l,k,i),l=1,2),k=1,2)
3477 write (iout,*) "Arrays UG2 and UG2DER"
3479 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3480 & ((ug2(l,k,i),l=1,2),k=1,2),
3481 & ((ug2der(l,k,i),l=1,2),k=1,2)
3483 write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3485 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3486 & (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3487 & (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3489 write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3491 write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3492 & costab(i),sintab(i),costab2(i),sintab2(i)
3494 write (iout,*) "Array MUDER"
3496 write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3502 cd iti = itype2loc(itype(i))
3505 cd write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3506 cd & (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3511 C-----------------------------------------------------------------------------
3512 subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3514 C This subroutine calculates the average interaction energy and its gradient
3515 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3516 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3517 C The potential depends both on the distance of peptide-group centers and on
3518 C the orientation of the CA-CA virtual bonds.
3520 implicit real*8 (a-h,o-z)
3524 include 'DIMENSIONS'
3525 include 'COMMON.CONTROL'
3526 include 'COMMON.SETUP'
3527 include 'COMMON.IOUNITS'
3528 include 'COMMON.GEO'
3529 include 'COMMON.VAR'
3530 include 'COMMON.LOCAL'
3531 include 'COMMON.CHAIN'
3532 include 'COMMON.DERIV'
3533 include 'COMMON.INTERACT'
3535 include 'COMMON.CONTACTS'
3536 include 'COMMON.CONTMAT'
3538 include 'COMMON.CORRMAT'
3539 include 'COMMON.TORSION'
3540 include 'COMMON.VECTORS'
3541 include 'COMMON.FFIELD'
3542 include 'COMMON.TIME1'
3543 include 'COMMON.SPLITELE'
3544 dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3545 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3546 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3547 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3548 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3549 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3551 double precision sslipi,sslipj,ssgradlipi,ssgradlipj
3552 common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj
3553 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3555 double precision scal_el /1.0d0/
3557 double precision scal_el /0.5d0/
3560 C 13-go grudnia roku pamietnego...
3561 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3562 & 0.0d0,1.0d0,0.0d0,
3563 & 0.0d0,0.0d0,1.0d0/
3564 cd write(iout,*) 'In EELEC'
3566 cd write(iout,*) 'Type',i
3567 cd write(iout,*) 'B1',B1(:,i)
3568 cd write(iout,*) 'B2',B2(:,i)
3569 cd write(iout,*) 'CC',CC(:,:,i)
3570 cd write(iout,*) 'DD',DD(:,:,i)
3571 cd write(iout,*) 'EE',EE(:,:,i)
3573 cd call check_vecgrad
3575 if (icheckgrad.eq.1) then
3577 fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3579 dc_norm(k,i)=dc(k,i)*fac
3581 c write (iout,*) 'i',i,' fac',fac
3584 if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3585 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3586 & wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3587 c call vec_and_deriv
3593 time_mat=time_mat+MPI_Wtime()-time01
3597 cd write (iout,*) 'i=',i
3599 cd write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3602 cd write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3603 cd & uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3618 cd print '(a)','Enter EELEC'
3619 cd write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3621 gel_loc_loc(i)=0.0d0
3626 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3628 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3630 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3631 do i=iturn3_start,iturn3_end
3633 C write(iout,*) "tu jest i",i
3634 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3635 C changes suggested by Ana to avoid out of bounds
3636 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3637 c & .or.((i+4).gt.nres)
3638 c & .or.((i-1).le.0)
3639 C end of changes by Ana
3640 & .or. itype(i+2).eq.ntyp1
3641 & .or. itype(i+3).eq.ntyp1) cycle
3642 C Adam: Instructions below will switch off existing interactions
3644 c if(itype(i-1).eq.ntyp1)cycle
3646 c if(i.LT.nres-3)then
3647 c if (itype(i+4).eq.ntyp1) cycle
3652 dx_normi=dc_norm(1,i)
3653 dy_normi=dc_norm(2,i)
3654 dz_normi=dc_norm(3,i)
3655 xmedi=c(1,i)+0.5d0*dxi
3656 ymedi=c(2,i)+0.5d0*dyi
3657 zmedi=c(3,i)+0.5d0*dzi
3658 call to_box(xmedi,ymedi,zmedi)
3659 call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3661 call eelecij(i,i+2,ees,evdw1,eel_loc)
3662 if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3664 num_cont_hb(i)=num_conti
3667 do i=iturn4_start,iturn4_end
3669 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3670 C changes suggested by Ana to avoid out of bounds
3671 c & .or.((i+5).gt.nres)
3672 c & .or.((i-1).le.0)
3673 C end of changes suggested by Ana
3674 & .or. itype(i+3).eq.ntyp1
3675 & .or. itype(i+4).eq.ntyp1
3676 c & .or. itype(i+5).eq.ntyp1
3677 c & .or. itype(i).eq.ntyp1
3678 c & .or. itype(i-1).eq.ntyp1
3683 dx_normi=dc_norm(1,i)
3684 dy_normi=dc_norm(2,i)
3685 dz_normi=dc_norm(3,i)
3686 xmedi=c(1,i)+0.5d0*dxi
3687 ymedi=c(2,i)+0.5d0*dyi
3688 zmedi=c(3,i)+0.5d0*dzi
3689 C Return atom into box, boxxsize is size of box in x dimension
3691 c if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3692 c if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3693 C Condition for being inside the proper box
3694 c if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3695 c & (xmedi.lt.((-0.5d0)*boxxsize))) then
3699 c if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3700 c if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3701 C Condition for being inside the proper box
3702 c if ((ymedi.gt.((0.5d0)*boxysize)).or.
3703 c & (ymedi.lt.((-0.5d0)*boxysize))) then
3707 c if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3708 c if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3709 C Condition for being inside the proper box
3710 c if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3711 c & (zmedi.lt.((-0.5d0)*boxzsize))) then
3714 call to_box(xmedi,ymedi,zmedi)
3715 call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3717 num_conti=num_cont_hb(i)
3719 c write(iout,*) "JESTEM W PETLI"
3720 call eelecij(i,i+3,ees,evdw1,eel_loc)
3721 if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3722 & call eturn4(i,eello_turn4)
3724 num_cont_hb(i)=num_conti
3727 C Loop over all neighbouring boxes
3732 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3735 c do i=iatel_s,iatel_e
3736 do ikont=g_listpp_start,g_listpp_end
3737 i=newcontlistppi(ikont)
3738 j=newcontlistppj(ikont)
3741 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3742 C changes suggested by Ana to avoid out of bounds
3743 c & .or.((i+2).gt.nres)
3744 c & .or.((i-1).le.0)
3745 C end of changes by Ana
3746 c & .or. itype(i+2).eq.ntyp1
3747 c & .or. itype(i-1).eq.ntyp1
3752 dx_normi=dc_norm(1,i)
3753 dy_normi=dc_norm(2,i)
3754 dz_normi=dc_norm(3,i)
3755 xmedi=c(1,i)+0.5d0*dxi
3756 ymedi=c(2,i)+0.5d0*dyi
3757 zmedi=c(3,i)+0.5d0*dzi
3758 call to_box(xmedi,ymedi,zmedi)
3759 call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3760 C xmedi=xmedi+xshift*boxxsize
3761 C ymedi=ymedi+yshift*boxysize
3762 C zmedi=zmedi+zshift*boxzsize
3764 C Return tom into box, boxxsize is size of box in x dimension
3766 c if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3767 c if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3768 C Condition for being inside the proper box
3769 c if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3770 c & (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3774 c if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3775 c if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3776 C Condition for being inside the proper box
3777 c if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3778 c & (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3782 c if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3783 c if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3784 cC Condition for being inside the proper box
3785 c if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3786 c & (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3790 c write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3792 num_conti=num_cont_hb(i)
3795 c do j=ielstart(i),ielend(i)
3797 C write (iout,*) i,j
3799 if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3800 C changes suggested by Ana to avoid out of bounds
3801 c & .or.((j+2).gt.nres)
3802 c & .or.((j-1).le.0)
3803 C end of changes by Ana
3804 c & .or.itype(j+2).eq.ntyp1
3805 c & .or.itype(j-1).eq.ntyp1
3807 call eelecij(i,j,ees,evdw1,eel_loc)
3810 num_cont_hb(i)=num_conti
3817 c write (iout,*) "Number of loop steps in EELEC:",ind
3819 cd write (iout,'(i3,3f10.5,5x,3f10.5)')
3820 cd & i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3822 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3823 ccc eel_loc=eel_loc+eello_turn3
3824 cd print *,"Processor",fg_rank," t_eelecij",t_eelecij
3827 C-------------------------------------------------------------------------------
3828 subroutine eelecij(i,j,ees,evdw1,eel_loc)
3830 include 'DIMENSIONS'
3834 include 'COMMON.CONTROL'
3835 include 'COMMON.IOUNITS'
3836 include 'COMMON.GEO'
3837 include 'COMMON.VAR'
3838 include 'COMMON.LOCAL'
3839 include 'COMMON.CHAIN'
3840 include 'COMMON.DERIV'
3841 include 'COMMON.INTERACT'
3843 include 'COMMON.CONTACTS'
3844 include 'COMMON.CONTMAT'
3846 include 'COMMON.CORRMAT'
3847 include 'COMMON.TORSION'
3848 include 'COMMON.VECTORS'
3849 include 'COMMON.FFIELD'
3850 include 'COMMON.TIME1'
3851 include 'COMMON.SPLITELE'
3852 include 'COMMON.SHIELD'
3853 double precision ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3854 & erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3855 double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3856 & aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3857 & gmuij2(4),gmuji2(4)
3858 double precision dxi,dyi,dzi
3859 double precision dx_normi,dy_normi,dz_normi,aux
3860 integer j1,j2,lll,num_conti
3861 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3862 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3864 integer k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap,ilist,iresshield
3865 double precision ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3866 double precision ees,evdw1,eel_loc,aaa,bbb,ael3i
3867 double precision dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,
3868 & rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,
3869 & evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,
3870 & ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,
3871 & a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,
3872 & ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,
3873 & ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,
3874 & ecosgp,ecosam,ecosbm,ecosgm,ghalf,rlocshield
3875 double precision a22,a23,a32,a33,geel_loc_ij,geel_loc_ji
3876 double precision xmedi,ymedi,zmedi
3877 double precision sscale,sscagrad,scalar
3878 double precision boxshift
3879 double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij,
3881 common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
3882 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3884 double precision scal_el /1.0d0/
3886 double precision scal_el /0.5d0/
3889 C 13-go grudnia roku pamietnego...
3890 double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3891 & 0.0d0,1.0d0,0.0d0,
3892 & 0.0d0,0.0d0,1.0d0/
3893 c time00=MPI_Wtime()
3894 cd write (iout,*) "eelecij",i,j
3896 c write (iout,*) "lipscale",lipscale
3899 if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3900 aaa=app(iteli,itelj)
3901 bbb=bpp(iteli,itelj)
3902 ael6i=ael6(iteli,itelj)
3903 ael3i=ael3(iteli,itelj)
3907 dx_normj=dc_norm(1,j)
3908 dy_normj=dc_norm(2,j)
3909 dz_normj=dc_norm(3,j)
3910 C xj=c(1,j)+0.5D0*dxj-xmedi
3911 C yj=c(2,j)+0.5D0*dyj-ymedi
3912 C zj=c(3,j)+0.5D0*dzj-zmedi
3916 call to_box(xj,yj,zj)
3917 call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3918 faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3919 faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3920 xj=boxshift(xj-xmedi,boxxsize)
3921 yj=boxshift(yj-ymedi,boxysize)
3922 zj=boxshift(zj-zmedi,boxzsize)
3923 C if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3925 rij=xj*xj+yj*yj+zj*zj
3927 sss=sscale(dsqrt(rij),r_cut_int)
3928 if (sss.eq.0.0d0) return
3929 sssgrad=sscagrad(dsqrt(rij),r_cut_int)
3930 c if (sss.gt.0.0d0) then
3936 cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3937 cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3938 cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3939 fac=cosa-3.0D0*cosb*cosg
3941 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3942 if (j.eq.i+2) ev1=scal_el*ev1
3947 el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3951 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3952 ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3953 if (shield_mode.gt.0) then
3956 el1=el1*fac_shield(i)**2*fac_shield(j)**2
3957 el2=el2*fac_shield(i)**2*fac_shield(j)**2
3959 ees=ees+eesij*sss*faclipij2
3964 ees=ees+eesij*sss*faclipij2
3967 evdw1=evdw1+evdwij*sss*faclipij2
3968 cd write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3969 cd & iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3970 cd & 1.0D0/dsqrt(rrmij),evdwij,eesij,
3971 cd & xmedi,ymedi,zmedi,xj,yj,zj
3973 if (energy_dec) then
3974 write (iout,'(a6,2i5,0pf7.3,2i5,e11.3,3f10.5)')
3975 & 'evdw1',i,j,evdwij,iteli,itelj,aaa,evdw1,sss,rij
3976 write (iout,'(a6,2i5,0pf7.3,6f8.5)') 'ees',i,j,eesij,
3977 & fac_shield(i),fac_shield(j),sslipi,sslipj,faclipij,
3982 C Calculate contributions to the Cartesian gradient.
3985 facvdw=-6*rrmij*(ev1+evdwij)*sss
3986 facel=-3*rrmij*(el1+eesij)
3993 * Radial derivatives. First process both termini of the fragment (i,j)
3995 aux=(facel*sss+rmij*sssgrad*eesij)*faclipij2
3999 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4000 & (shield_mode.gt.0)) then
4002 do ilist=1,ishield_list(i)
4003 iresshield=shield_list(ilist,i)
4005 rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4007 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4009 & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4010 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4011 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4012 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4013 C if (iresshield.gt.i) then
4014 C do ishi=i+1,iresshield-1
4015 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4016 C & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4020 C do ishi=iresshield,i
4021 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4022 C & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4028 do ilist=1,ishield_list(j)
4029 iresshield=shield_list(ilist,j)
4031 rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4033 gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4035 & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0*sss
4036 gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4038 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4039 C gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4040 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4041 C if (iresshield.gt.j) then
4042 C do ishi=j+1,iresshield-1
4043 C gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4044 C & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4048 C do ishi=iresshield,j
4049 C gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4050 C & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4057 gshieldc(k,i)=gshieldc(k,i)+
4058 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4059 gshieldc(k,j)=gshieldc(k,j)+
4060 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4061 gshieldc(k,i-1)=gshieldc(k,i-1)+
4062 & grad_shield(k,i)*eesij/fac_shield(i)*2.0*sss
4063 gshieldc(k,j-1)=gshieldc(k,j-1)+
4064 & grad_shield(k,j)*eesij/fac_shield(j)*2.0*sss
4069 c ghalf=0.5D0*ggg(k)
4070 c gelc(k,i)=gelc(k,i)+ghalf
4071 c gelc(k,j)=gelc(k,j)+ghalf
4073 c 9/28/08 AL Gradient compotents will be summed only at the end
4074 C print *,"before", gelc_long(1,i), gelc_long(1,j)
4076 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4077 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4079 gelc_long(3,j)=gelc_long(3,j)+
4080 & ssgradlipj*eesij/2.0d0*lipscale**2*sss
4082 gelc_long(3,i)=gelc_long(3,i)+
4083 & ssgradlipi*eesij/2.0d0*lipscale**2*sss
4087 * Loop over residues i+1 thru j-1.
4091 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4094 facvdw=(facvdw+sssgrad*rmij*evdwij)*faclipij2
4099 c ghalf=0.5D0*ggg(k)
4100 c gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4101 c gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4103 c 9/28/08 AL Gradient compotents will be summed only at the end
4105 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4106 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4108 !C Lipidic part for scaling weight
4109 gvdwpp(3,j)=gvdwpp(3,j)+
4110 & sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4111 gvdwpp(3,i)=gvdwpp(3,i)+
4112 & sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4114 * Loop over residues i+1 thru j-1.
4118 cgrad gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4123 facvdw=(ev1+evdwij)*faclipij2
4126 fac=-3*rrmij*(facvdw+facvdw+facel)*sss
4127 & +(evdwij+eesij)*sssgrad*rrmij
4132 * Radial derivatives. First process both termini of the fragment (i,j)
4135 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4137 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4139 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4141 c ghalf=0.5D0*ggg(k)
4142 c gelc(k,i)=gelc(k,i)+ghalf
4143 c gelc(k,j)=gelc(k,j)+ghalf
4145 c 9/28/08 AL Gradient compotents will be summed only at the end
4147 gelc_long(k,j)=gelc(k,j)+ggg(k)
4148 gelc_long(k,i)=gelc(k,i)-ggg(k)
4151 * Loop over residues i+1 thru j-1.
4155 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4158 c 9/28/08 AL Gradient compotents will be summed only at the end
4159 ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4160 ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4161 ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4163 gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4164 gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4166 gvdwpp(3,j)=gvdwpp(3,j)+
4167 & sss*ssgradlipj*evdwij/2.0d0*lipscale**2
4168 gvdwpp(3,i)=gvdwpp(3,i)+
4169 & sss*ssgradlipi*evdwij/2.0d0*lipscale**2
4174 ecosa=2.0D0*fac3*fac1+fac4
4177 ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4178 ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4180 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4181 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4183 cd print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4184 cd & (dcosg(k),k=1,3)
4186 ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4187 & fac_shield(i)**2*fac_shield(j)**2*sss*faclipij2
4190 c ghalf=0.5D0*ggg(k)
4191 c gelc(k,i)=gelc(k,i)+ghalf
4192 c & +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4193 c & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4194 c gelc(k,j)=gelc(k,j)+ghalf
4195 c & +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4196 c & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4200 cgrad gelc(l,k)=gelc(l,k)+ggg(l)
4203 C print *,"before22", gelc_long(1,i), gelc_long(1,j)
4206 & +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4207 & + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))*sss
4208 & *fac_shield(i)**2*fac_shield(j)**2*faclipij2
4210 & +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4211 & + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))*sss
4212 & *fac_shield(i)**2*fac_shield(j)**2*faclipij2
4213 gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4214 gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4216 C print *,"before33", gelc_long(1,i), gelc_long(1,j)
4220 IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4221 & .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4222 & .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4224 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4225 C energy of a peptide unit is assumed in the form of a second-order
4226 C Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4227 C Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4228 C are computed for EVERY pair of non-contiguous peptide groups.
4231 if (j.lt.nres-1) then
4243 muij(kkk)=mu(k,i)*mu(l,j)
4244 c write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4246 gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4247 c write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4248 gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4249 gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4250 c write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4251 gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4256 write (iout,*) 'EELEC: i',i,' j',j
4257 write (iout,*) 'j',j,' j1',j1,' j2',j2
4258 write(iout,*) 'muij',muij
4260 ury=scalar(uy(1,i),erij)
4261 urz=scalar(uz(1,i),erij)
4262 vry=scalar(uy(1,j),erij)
4263 vrz=scalar(uz(1,j),erij)
4264 a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4265 a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4266 a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4267 a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4268 fac=dsqrt(-ael6i)*r3ij
4270 write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4271 write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4272 & "uyvz",scalar(uy(1,i),uz(1,j)),
4273 & "uzvy",scalar(uz(1,i),uy(1,j)),
4274 & "uzvz",scalar(uz(1,i),uz(1,j))
4275 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4276 write (iout,*) "fac",fac
4283 write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4286 cd write (iout,'(4i5,4f10.5)')
4287 cd & i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4288 cd write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4289 cd write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4290 cd & uy(:,j),uz(:,j)
4291 cd write (iout,'(4f10.5)')
4292 cd & scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4293 cd & scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4294 cd write (iout,'(4f10.5)') ury,urz,vry,vrz
4295 cd write (iout,'(9f10.5/)')
4296 cd & fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4297 C Derivatives of the elements of A in virtual-bond vectors
4298 call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4300 uryg(k,1)=scalar(erder(1,k),uy(1,i))
4301 uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4302 uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4303 urzg(k,1)=scalar(erder(1,k),uz(1,i))
4304 urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4305 urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4306 vryg(k,1)=scalar(erder(1,k),uy(1,j))
4307 vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4308 vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4309 vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4310 vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4311 vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4313 C Compute radial contributions to the gradient
4331 C Add the contributions coming from er
4334 agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4335 agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4336 agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4337 agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4340 C Derivatives in DC(i)
4341 cgrad ghalf1=0.5d0*agg(k,1)
4342 cgrad ghalf2=0.5d0*agg(k,2)
4343 cgrad ghalf3=0.5d0*agg(k,3)
4344 cgrad ghalf4=0.5d0*agg(k,4)
4345 aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4346 & -3.0d0*uryg(k,2)*vry)!+ghalf1
4347 aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4348 & -3.0d0*uryg(k,2)*vrz)!+ghalf2
4349 aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4350 & -3.0d0*urzg(k,2)*vry)!+ghalf3
4351 aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4352 & -3.0d0*urzg(k,2)*vrz)!+ghalf4
4353 C Derivatives in DC(i+1)
4354 aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4355 & -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4356 aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4357 & -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4358 aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4359 & -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4360 aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4361 & -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4362 C Derivatives in DC(j)
4363 aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4364 & -3.0d0*vryg(k,2)*ury)!+ghalf1
4365 aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4366 & -3.0d0*vrzg(k,2)*ury)!+ghalf2
4367 aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4368 & -3.0d0*vryg(k,2)*urz)!+ghalf3
4369 aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4370 & -3.0d0*vrzg(k,2)*urz)!+ghalf4
4371 C Derivatives in DC(j+1) or DC(nres-1)
4372 aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4373 & -3.0d0*vryg(k,3)*ury)
4374 aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4375 & -3.0d0*vrzg(k,3)*ury)
4376 aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4377 & -3.0d0*vryg(k,3)*urz)
4378 aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4379 & -3.0d0*vrzg(k,3)*urz)
4380 cgrad if (j.eq.nres-1 .and. i.lt.j-2) then
4382 cgrad aggj1(k,l)=aggj1(k,l)+agg(k,l)
4395 aggi(k,l)=-aggi(k,l)
4396 aggi1(k,l)=-aggi1(k,l)
4397 aggj(k,l)=-aggj(k,l)
4398 aggj1(k,l)=-aggj1(k,l)
4401 if (j.lt.nres-1) then
4407 aggi(k,l)=-aggi(k,l)
4408 aggi1(k,l)=-aggi1(k,l)
4409 aggj(k,l)=-aggj(k,l)
4410 aggj1(k,l)=-aggj1(k,l)
4421 aggi(k,l)=-aggi(k,l)
4422 aggi1(k,l)=-aggi1(k,l)
4423 aggj(k,l)=-aggj(k,l)
4424 aggj1(k,l)=-aggj1(k,l)
4429 IF (wel_loc.gt.0.0d0) THEN
4430 C Contribution to the local-electrostatic energy coming from the i-j pair
4431 eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4434 write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4436 write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4437 & " wel_loc",wel_loc
4439 if (shield_mode.eq.0) then
4446 eel_loc_ij=eel_loc_ij
4447 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4448 c if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4449 c & 'eelloc',i,j,eel_loc_ij
4450 C Now derivative over eel_loc
4451 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4452 & (shield_mode.gt.0)) then
4455 do ilist=1,ishield_list(i)
4456 iresshield=shield_list(ilist,i)
4458 rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4461 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4463 & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4464 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4468 do ilist=1,ishield_list(j)
4469 iresshield=shield_list(ilist,j)
4471 rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4474 gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4476 & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4477 gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4484 gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4485 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4486 gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4487 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4488 gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4489 & grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4490 gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4491 & grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4496 c write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4497 c & ' eel_loc_ij',eel_loc_ij
4498 C write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4499 C Calculate patrial derivative for theta angle
4501 geel_loc_ij=(a22*gmuij1(1)
4505 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4506 c write(iout,*) "derivative over thatai"
4507 c write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4509 gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4510 & geel_loc_ij*wel_loc
4511 c write(iout,*) "derivative over thatai-1"
4512 c write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4519 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4520 & geel_loc_ij*wel_loc
4521 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4523 c Derivative over j residue
4524 geel_loc_ji=a22*gmuji1(1)
4528 c write(iout,*) "derivative over thataj"
4529 c write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4532 gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4533 & geel_loc_ji*wel_loc
4534 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4541 c write(iout,*) "derivative over thataj-1"
4542 c write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4544 gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4545 & geel_loc_ji*wel_loc
4546 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4548 cd write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4550 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4551 & 'eelloc',i,j,eel_loc_ij
4552 c if (eel_loc_ij.ne.0)
4553 c & write (iout,'(a4,2i4,8f9.5)')'chuj',
4554 c & i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4556 eel_loc=eel_loc+eel_loc_ij
4557 C Partial derivatives in virtual-bond dihedral angles gamma
4559 & gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4560 & (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4561 & +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4562 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4564 gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4565 & (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4566 & +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4567 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4568 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4569 aux=eel_loc_ij/sss*sssgrad*rmij
4574 ggg(l)=ggg(l)+(agg(l,1)*muij(1)+
4575 & agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4576 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4577 gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4578 gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4579 cgrad ghalf=0.5d0*ggg(l)
4580 cgrad gel_loc(l,i)=gel_loc(l,i)+ghalf
4581 cgrad gel_loc(l,j)=gel_loc(l,j)+ghalf
4583 gel_loc_long(3,j)=gel_loc_long(3,j)+
4584 & ssgradlipj*eel_loc_ij/2.0d0*lipscale/faclipij
4586 gel_loc_long(3,i)=gel_loc_long(3,i)+
4587 & ssgradlipi*eel_loc_ij/2.0d0*lipscale/faclipij
4591 cgrad gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4594 C Remaining derivatives of eello
4596 gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4597 & aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4598 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4600 gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4601 & aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4602 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4604 gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4605 & aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4606 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4608 gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4609 & aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4610 & *fac_shield(i)*fac_shield(j)*sss*faclipij
4614 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4615 c if (j.gt.i+1 .and. num_conti.le.maxconts) then
4617 if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4618 & .and. num_conti.le.maxconts) then
4619 c write (iout,*) i,j," entered corr"
4621 C Calculate the contact function. The ith column of the array JCONT will
4622 C contain the numbers of atoms that make contacts with the atom I (of numbers
4623 C greater than I). The arrays FACONT and GACONT will contain the values of
4624 C the contact function and its derivative.
4625 c r0ij=1.02D0*rpp(iteli,itelj)
4626 c r0ij=1.11D0*rpp(iteli,itelj)
4627 r0ij=2.20D0*rpp(iteli,itelj)
4628 c r0ij=1.55D0*rpp(iteli,itelj)
4629 call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4630 if (fcont.gt.0.0D0) then
4631 num_conti=num_conti+1
4632 if (num_conti.gt.maxconts) then
4633 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4634 & ' will skip next contacts for this conf.'
4636 jcont_hb(num_conti,i)=j
4637 cd write (iout,*) "i",i," j",j," num_conti",num_conti,
4638 cd & " jcont_hb",jcont_hb(num_conti,i)
4639 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4640 & wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4641 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4643 d_cont(num_conti,i)=rij
4644 cd write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4645 C --- Electrostatic-interaction matrix ---
4646 a_chuj(1,1,num_conti,i)=a22
4647 a_chuj(1,2,num_conti,i)=a23
4648 a_chuj(2,1,num_conti,i)=a32
4649 a_chuj(2,2,num_conti,i)=a33
4650 C --- Gradient of rij
4652 grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4659 a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4660 a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4661 a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4662 a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4663 a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4668 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4669 C Calculate contact energies
4671 wij=cosa-3.0D0*cosb*cosg
4674 c fac3=dsqrt(-ael6i)/r0ij**3
4675 fac3=dsqrt(-ael6i)*r3ij
4676 c ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4677 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4678 if (ees0tmp.gt.0) then
4679 ees0pij=dsqrt(ees0tmp)
4683 c ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4684 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4685 if (ees0tmp.gt.0) then
4686 ees0mij=dsqrt(ees0tmp)
4691 if (shield_mode.eq.0) then
4695 ees0plist(num_conti,i)=j
4696 C fac_shield(i)=0.4d0
4697 C fac_shield(j)=0.6d0
4699 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4700 & *fac_shield(i)*fac_shield(j)*sss
4701 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4702 & *fac_shield(i)*fac_shield(j)*sss
4703 C Diagnostics. Comment out or remove after debugging!
4704 c ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4705 c ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4706 c ees0m(num_conti,i)=0.0D0
4708 c write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4709 c & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4710 C Angular derivatives of the contact function
4711 ees0pij1=fac3/ees0pij
4712 ees0mij1=fac3/ees0mij
4713 fac3p=-3.0D0*fac3*rrmij
4714 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4715 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4717 ecosa1= ees0pij1*( 1.0D0+0.5D0*wij)
4718 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4719 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4720 ecosa2= ees0mij1*(-1.0D0+0.5D0*wij)
4721 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4722 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4723 ecosap=ecosa1+ecosa2
4724 ecosbp=ecosb1+ecosb2
4725 ecosgp=ecosg1+ecosg2
4726 ecosam=ecosa1-ecosa2
4727 ecosbm=ecosb1-ecosb2
4728 ecosgm=ecosg1-ecosg2
4737 facont_hb(num_conti,i)=fcont
4738 fprimcont=fprimcont/rij
4739 cd facont_hb(num_conti,i)=1.0D0
4740 C Following line is for diagnostics.
4743 dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4744 dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4747 gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4748 gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4750 gggp(1)=gggp(1)+ees0pijp*xj
4751 & +ees0p(num_conti,i)/sss*rmij*xj*sssgrad
4752 gggp(2)=gggp(2)+ees0pijp*yj
4753 & +ees0p(num_conti,i)/sss*rmij*yj*sssgrad
4754 gggp(3)=gggp(3)+ees0pijp*zj
4755 & +ees0p(num_conti,i)/sss*rmij*zj*sssgrad
4756 gggm(1)=gggm(1)+ees0mijp*xj
4757 & +ees0m(num_conti,i)/sss*rmij*xj*sssgrad
4758 gggm(2)=gggm(2)+ees0mijp*yj
4759 & +ees0m(num_conti,i)/sss*rmij*yj*sssgrad
4760 gggm(3)=gggm(3)+ees0mijp*zj
4761 & +ees0m(num_conti,i)/sss*rmij*zj*sssgrad
4762 C Derivatives due to the contact function
4763 gacont_hbr(1,num_conti,i)=fprimcont*xj
4764 gacont_hbr(2,num_conti,i)=fprimcont*yj
4765 gacont_hbr(3,num_conti,i)=fprimcont*zj
4768 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4769 c following the change of gradient-summation algorithm.
4771 cgrad ghalfp=0.5D0*gggp(k)
4772 cgrad ghalfm=0.5D0*gggm(k)
4773 gacontp_hb1(k,num_conti,i)=!ghalfp
4774 & +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4775 & + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4776 & *fac_shield(i)*fac_shield(j)*sss
4778 gacontp_hb2(k,num_conti,i)=!ghalfp
4779 & +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4780 & + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4781 & *fac_shield(i)*fac_shield(j)*sss
4783 gacontp_hb3(k,num_conti,i)=gggp(k)
4784 & *fac_shield(i)*fac_shield(j)*sss
4786 gacontm_hb1(k,num_conti,i)=!ghalfm
4787 & +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4788 & + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4789 & *fac_shield(i)*fac_shield(j)*sss
4791 gacontm_hb2(k,num_conti,i)=!ghalfm
4792 & +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4793 & + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4794 & *fac_shield(i)*fac_shield(j)*sss
4796 gacontm_hb3(k,num_conti,i)=gggm(k)
4797 & *fac_shield(i)*fac_shield(j)*sss
4800 C Diagnostics. Comment out or remove after debugging!
4802 cdiag gacontp_hb1(k,num_conti,i)=0.0D0
4803 cdiag gacontp_hb2(k,num_conti,i)=0.0D0
4804 cdiag gacontp_hb3(k,num_conti,i)=0.0D0
4805 cdiag gacontm_hb1(k,num_conti,i)=0.0D0
4806 cdiag gacontm_hb2(k,num_conti,i)=0.0D0
4807 cdiag gacontm_hb3(k,num_conti,i)=0.0D0
4810 endif ! num_conti.le.maxconts
4814 if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4817 ghalf=0.5d0*agg(l,k)
4818 aggi(l,k)=aggi(l,k)+ghalf
4819 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4820 aggj(l,k)=aggj(l,k)+ghalf
4823 if (j.eq.nres-1 .and. i.lt.j-2) then
4826 aggj1(l,k)=aggj1(l,k)+agg(l,k)
4831 c t_eelecij=t_eelecij+MPI_Wtime()-time00
4834 C-----------------------------------------------------------------------------
4835 subroutine eturn3(i,eello_turn3)
4836 C Third- and fourth-order contributions from turns
4837 implicit real*8 (a-h,o-z)
4838 include 'DIMENSIONS'
4839 include 'COMMON.IOUNITS'
4840 include 'COMMON.GEO'
4841 include 'COMMON.VAR'
4842 include 'COMMON.LOCAL'
4843 include 'COMMON.CHAIN'
4844 include 'COMMON.DERIV'
4845 include 'COMMON.INTERACT'
4846 include 'COMMON.CORRMAT'
4847 include 'COMMON.TORSION'
4848 include 'COMMON.VECTORS'
4849 include 'COMMON.FFIELD'
4850 include 'COMMON.CONTROL'
4851 include 'COMMON.SHIELD'
4853 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4854 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4855 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4856 & gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4857 & auxgmat2(2,2),auxgmatt2(2,2)
4858 double precision agg(3,4),aggi(3,4),aggi1(3,4),
4859 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4860 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4861 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4863 double precision sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
4864 common /lipcalc/ sslipi,sslipj,ssgradlipi,ssgradlipj,faclipij
4866 c write (iout,*) "eturn3",i,j,j1,j2
4871 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4873 C Third-order contributions
4880 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4881 cd call checkint_turn3(i,a_temp,eello_turn3_num)
4882 call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4883 c auxalary matices for theta gradient
4884 c auxalary matrix for i+1 and constant i+2
4885 call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4886 c auxalary matrix for i+2 and constant i+1
4887 call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4888 call transpose2(auxmat(1,1),auxmat1(1,1))
4889 call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4890 call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4891 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4892 call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4893 call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4894 if (shield_mode.eq.0) then
4901 eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4902 & *fac_shield(i)*fac_shield(j)*faclipij
4903 eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4904 & *fac_shield(i)*fac_shield(j)
4905 if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4908 C Derivatives in theta
4909 gloc(nphi+i,icg)=gloc(nphi+i,icg)
4910 & +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4911 & *fac_shield(i)*fac_shield(j)*faclipij
4912 gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4913 & +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4914 & *fac_shield(i)*fac_shield(j)*faclipij
4917 C Derivatives in shield mode
4918 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4919 & (shield_mode.gt.0)) then
4922 do ilist=1,ishield_list(i)
4923 iresshield=shield_list(ilist,i)
4925 rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4927 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4929 & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4930 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4934 do ilist=1,ishield_list(j)
4935 iresshield=shield_list(ilist,j)
4937 rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4939 gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4941 & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4942 gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4949 gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4950 & grad_shield(k,i)*eello_t3/fac_shield(i)
4951 gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4952 & grad_shield(k,j)*eello_t3/fac_shield(j)
4953 gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4954 & grad_shield(k,i)*eello_t3/fac_shield(i)
4955 gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4956 & grad_shield(k,j)*eello_t3/fac_shield(j)
4960 C if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4961 cd write (2,*) 'i,',i,' j',j,'eello_turn3',
4962 cd & 0.5d0*(pizda(1,1)+pizda(2,2)),
4963 cd & ' eello_turn3_num',4*eello_turn3_num
4964 C Derivatives in gamma(i)
4965 call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4966 call transpose2(auxmat2(1,1),auxmat3(1,1))
4967 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4968 gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4969 & *fac_shield(i)*fac_shield(j)*faclipij
4970 C Derivatives in gamma(i+1)
4971 call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4972 call transpose2(auxmat2(1,1),auxmat3(1,1))
4973 call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4974 gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4975 & +0.5d0*(pizda(1,1)+pizda(2,2))
4976 & *fac_shield(i)*fac_shield(j)*faclipij
4977 C Cartesian derivatives
4979 c ghalf1=0.5d0*agg(l,1)
4980 c ghalf2=0.5d0*agg(l,2)
4981 c ghalf3=0.5d0*agg(l,3)
4982 c ghalf4=0.5d0*agg(l,4)
4983 a_temp(1,1)=aggi(l,1)!+ghalf1
4984 a_temp(1,2)=aggi(l,2)!+ghalf2
4985 a_temp(2,1)=aggi(l,3)!+ghalf3
4986 a_temp(2,2)=aggi(l,4)!+ghalf4
4987 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4988 gcorr3_turn(l,i)=gcorr3_turn(l,i)
4989 & +0.5d0*(pizda(1,1)+pizda(2,2))
4990 & *fac_shield(i)*fac_shield(j)*faclipij
4992 a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4993 a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4994 a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4995 a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4996 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4997 gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4998 & +0.5d0*(pizda(1,1)+pizda(2,2))
4999 & *fac_shield(i)*fac_shield(j)*faclipij
5000 a_temp(1,1)=aggj(l,1)!+ghalf1
5001 a_temp(1,2)=aggj(l,2)!+ghalf2
5002 a_temp(2,1)=aggj(l,3)!+ghalf3
5003 a_temp(2,2)=aggj(l,4)!+ghalf4
5004 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5005 gcorr3_turn(l,j)=gcorr3_turn(l,j)
5006 & +0.5d0*(pizda(1,1)+pizda(2,2))
5007 & *fac_shield(i)*fac_shield(j)*faclipij
5008 a_temp(1,1)=aggj1(l,1)
5009 a_temp(1,2)=aggj1(l,2)
5010 a_temp(2,1)=aggj1(l,3)
5011 a_temp(2,2)=aggj1(l,4)
5012 call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5013 gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5014 & +0.5d0*(pizda(1,1)+pizda(2,2))
5015 & *fac_shield(i)*fac_shield(j)*faclipij
5017 gshieldc_t3(3,i)=gshieldc_t3(3,i)+
5018 & ssgradlipi*eello_t3/4.0d0*lipscale
5019 gshieldc_t3(3,j)=gshieldc_t3(3,j)+
5020 & ssgradlipj*eello_t3/4.0d0*lipscale
5021 gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+
5022 & ssgradlipi*eello_t3/4.0d0*lipscale
5023 gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+
5024 & ssgradlipj*eello_t3/4.0d0*lipscale
5028 C-------------------------------------------------------------------------------
5029 subroutine eturn4(i,eello_turn4)
5030 C Third- and fourth-order contributions from turns
5031 implicit real*8 (a-h,o-z)
5032 include 'DIMENSIONS'
5033 include 'COMMON.IOUNITS'
5034 include 'COMMON.GEO'
5035 include 'COMMON.VAR'
5036 include 'COMMON.LOCAL'
5037 include 'COMMON.CHAIN'
5038 include 'COMMON.DERIV'
5039 include 'COMMON.INTERACT'
5040 include 'COMMON.CORRMAT'
5041 include 'COMMON.TORSION'
5042 include 'COMMON.VECTORS'
5043 include 'COMMON.FFIELD'
5044 include 'COMMON.CONTROL'
5045 include 'COMMON.SHIELD'
5047 double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5048 & e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5049 & e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5050 & auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5051 & gte1t(2,2),gte2t(2,2),gte3t(2,2),
5052 & gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5053 & gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5054 double precision agg(3,4),aggi(3,4),aggi1(3,4),
5055 & aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5056 common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5057 & dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5060 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5062 C Fourth-order contributions
5070 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5071 cd call checkint_turn4(i,a_temp,eello_turn4_num)
5072 c write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5073 c write(iout,*)"WCHODZE W PROGRAM"
5078 iti1=itype2loc(itype(i+1))
5079 iti2=itype2loc(itype(i+2))
5080 iti3=itype2loc(itype(i+3))
5081 c write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5082 call transpose2(EUg(1,1,i+1),e1t(1,1))
5083 call transpose2(Eug(1,1,i+2),e2t(1,1))
5084 call transpose2(Eug(1,1,i+3),e3t(1,1))
5085 C Ematrix derivative in theta
5086 call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5087 call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5088 call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5089 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5090 c eta1 in derivative theta
5091 call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5092 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5093 c auxgvec is derivative of Ub2 so i+3 theta
5094 call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5095 c auxalary matrix of E i+1
5096 call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5099 s1=scalar2(b1(1,i+2),auxvec(1))
5100 c derivative of theta i+2 with constant i+3
5101 gs23=scalar2(gtb1(1,i+2),auxvec(1))
5102 c derivative of theta i+2 with constant i+2
5103 gs32=scalar2(b1(1,i+2),auxgvec(1))
5104 c derivative of E matix in theta of i+1
5105 gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5107 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5108 c ea31 in derivative theta
5109 call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5110 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5111 c auxilary matrix auxgvec of Ub2 with constant E matirx
5112 call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5113 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5114 call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5118 s2=scalar2(b1(1,i+1),auxvec(1))
5119 c derivative of theta i+1 with constant i+3
5120 gs13=scalar2(gtb1(1,i+1),auxvec(1))
5121 c derivative of theta i+2 with constant i+1
5122 gs21=scalar2(b1(1,i+1),auxgvec(1))
5123 c derivative of theta i+3 with constant i+1
5124 gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5125 c write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5127 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5128 c two derivatives over diffetent matrices
5129 c gtae3e2 is derivative over i+3
5130 call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5131 c ae3gte2 is derivative over i+2
5132 call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5133 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5134 c three possible derivative over theta E matices
5136 call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5138 call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5140 call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5141 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5143 gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5144 gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5145 gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5146 if (shield_mode.eq.0) then
5153 eello_turn4=eello_turn4-(s1+s2+s3)
5154 & *fac_shield(i)*fac_shield(j)*faclipij
5155 eello_t4=-(s1+s2+s3)
5156 & *fac_shield(i)*fac_shield(j)
5157 c write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5158 if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5159 & 'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5160 C Now derivative over shield:
5161 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5162 & (shield_mode.gt.0)) then
5165 do ilist=1,ishield_list(i)
5166 iresshield=shield_list(ilist,i)
5168 rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5170 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5172 & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5173 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5177 do ilist=1,ishield_list(j)
5178 iresshield=shield_list(ilist,j)
5180 rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5182 gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5184 & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5185 gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5192 gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5193 & grad_shield(k,i)*eello_t4/fac_shield(i)
5194 gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5195 & grad_shield(k,j)*eello_t4/fac_shield(j)
5196 gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5197 & grad_shield(k,i)*eello_t4/fac_shield(i)
5198 gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5199 & grad_shield(k,j)*eello_t4/fac_shield(j)
5202 cd write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5203 cd & ' eello_turn4_num',8*eello_turn4_num
5205 gloc(nphi+i,icg)=gloc(nphi+i,icg)
5206 & -(gs13+gsE13+gsEE1)*wturn4
5207 & *fac_shield(i)*fac_shield(j)
5208 gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5209 & -(gs23+gs21+gsEE2)*wturn4
5210 & *fac_shield(i)*fac_shield(j)
5212 gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5213 & -(gs32+gsE31+gsEE3)*wturn4
5214 & *fac_shield(i)*fac_shield(j)
5216 c gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5219 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5220 & 'eturn4',i,j,-(s1+s2+s3)
5221 c write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5222 c & ' eello_turn4_num',8*eello_turn4_num
5223 C Derivatives in gamma(i)
5224 call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5225 call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5226 call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5227 s1=scalar2(b1(1,i+2),auxvec(1))
5228 call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5229 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5230 gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5231 & *fac_shield(i)*fac_shield(j)*faclipij
5232 C Derivatives in gamma(i+1)
5233 call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5234 call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5235 s2=scalar2(b1(1,i+1),auxvec(1))
5236 call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5237 call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5238 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5239 gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5240 & *fac_shield(i)*fac_shield(j)*faclipij
5241 C Derivatives in gamma(i+2)
5242 call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5243 call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5244 s1=scalar2(b1(1,i+2),auxvec(1))
5245 call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5246 call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5247 s2=scalar2(b1(1,i+1),auxvec(1))
5248 call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5249 call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5250 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5251 gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5252 & *fac_shield(i)*fac_shield(j)*faclipij
5253 C Cartesian derivatives
5254 C Derivatives of this turn contributions in DC(i+2)
5255 if (j.lt.nres-1) then
5257 a_temp(1,1)=agg(l,1)
5258 a_temp(1,2)=agg(l,2)
5259 a_temp(2,1)=agg(l,3)
5260 a_temp(2,2)=agg(l,4)
5261 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5262 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5263 s1=scalar2(b1(1,i+2),auxvec(1))
5264 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5265 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5266 s2=scalar2(b1(1,i+1),auxvec(1))
5267 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5268 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5269 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5271 gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5272 & *fac_shield(i)*fac_shield(j)*faclipij
5275 C Remaining derivatives of this turn contribution
5277 a_temp(1,1)=aggi(l,1)
5278 a_temp(1,2)=aggi(l,2)
5279 a_temp(2,1)=aggi(l,3)
5280 a_temp(2,2)=aggi(l,4)
5281 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5282 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5283 s1=scalar2(b1(1,i+2),auxvec(1))
5284 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5285 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5286 s2=scalar2(b1(1,i+1),auxvec(1))
5287 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5288 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5289 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5290 gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5291 & *fac_shield(i)*fac_shield(j)*faclipij
5292 a_temp(1,1)=aggi1(l,1)
5293 a_temp(1,2)=aggi1(l,2)
5294 a_temp(2,1)=aggi1(l,3)
5295 a_temp(2,2)=aggi1(l,4)
5296 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5297 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5298 s1=scalar2(b1(1,i+2),auxvec(1))
5299 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5300 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5301 s2=scalar2(b1(1,i+1),auxvec(1))
5302 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5303 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5304 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5305 gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5306 & *fac_shield(i)*fac_shield(j)*faclipij
5307 a_temp(1,1)=aggj(l,1)
5308 a_temp(1,2)=aggj(l,2)
5309 a_temp(2,1)=aggj(l,3)
5310 a_temp(2,2)=aggj(l,4)
5311 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5312 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5313 s1=scalar2(b1(1,i+2),auxvec(1))
5314 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5315 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5316 s2=scalar2(b1(1,i+1),auxvec(1))
5317 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5318 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5319 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5320 gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5321 & *fac_shield(i)*fac_shield(j)*faclipij
5322 a_temp(1,1)=aggj1(l,1)
5323 a_temp(1,2)=aggj1(l,2)
5324 a_temp(2,1)=aggj1(l,3)
5325 a_temp(2,2)=aggj1(l,4)
5326 call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5327 call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5328 s1=scalar2(b1(1,i+2),auxvec(1))
5329 call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5330 call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5331 s2=scalar2(b1(1,i+1),auxvec(1))
5332 call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5333 call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5334 s3=0.5d0*(pizda(1,1)+pizda(2,2))
5335 c write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5336 gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5337 & *fac_shield(i)*fac_shield(j)*faclipij
5339 gshieldc_t4(3,i)=gshieldc_t4(3,i)+
5340 & ssgradlipi*eello_t4/4.0d0*lipscale
5341 gshieldc_t4(3,j)=gshieldc_t4(3,j)+
5342 & ssgradlipj*eello_t4/4.0d0*lipscale
5343 gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+
5344 & ssgradlipi*eello_t4/4.0d0*lipscale
5345 gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+
5346 & ssgradlipj*eello_t4/4.0d0*lipscale
5349 C-----------------------------------------------------------------------------
5350 subroutine vecpr(u,v,w)
5351 implicit real*8(a-h,o-z)
5352 dimension u(3),v(3),w(3)
5353 w(1)=u(2)*v(3)-u(3)*v(2)
5354 w(2)=-u(1)*v(3)+u(3)*v(1)
5355 w(3)=u(1)*v(2)-u(2)*v(1)
5358 C-----------------------------------------------------------------------------
5359 subroutine unormderiv(u,ugrad,unorm,ungrad)
5360 C This subroutine computes the derivatives of a normalized vector u, given
5361 C the derivatives computed without normalization conditions, ugrad. Returns
5364 double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5365 double precision vec(3)
5366 double precision scalar
5368 c write (2,*) 'ugrad',ugrad
5371 vec(i)=scalar(ugrad(1,i),u(1))
5373 c write (2,*) 'vec',vec
5376 ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5379 c write (2,*) 'ungrad',ungrad
5382 C-----------------------------------------------------------------------------
5383 subroutine escp_soft_sphere(evdw2,evdw2_14)
5385 C This subroutine calculates the excluded-volume interaction energy between
5386 C peptide-group centers and side chains and its gradient in virtual-bond and
5387 C side-chain vectors.
5389 implicit real*8 (a-h,o-z)
5390 include 'DIMENSIONS'
5391 include 'COMMON.GEO'
5392 include 'COMMON.VAR'
5393 include 'COMMON.LOCAL'
5394 include 'COMMON.CHAIN'
5395 include 'COMMON.DERIV'
5396 include 'COMMON.INTERACT'
5397 include 'COMMON.FFIELD'
5398 include 'COMMON.IOUNITS'
5399 include 'COMMON.CONTROL'
5401 double precision boxshift
5405 cd print '(a)','Enter ESCP'
5406 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5410 c do i=iatscp_s,iatscp_e
5411 do ikont=g_listscp_start,g_listscp_end
5412 i=newcontlistscpi(ikont)
5413 j=newcontlistscpj(ikont)
5414 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5416 xi=0.5D0*(c(1,i)+c(1,i+1))
5417 yi=0.5D0*(c(2,i)+c(2,i+1))
5418 zi=0.5D0*(c(3,i)+c(3,i+1))
5419 C Return atom into box, boxxsize is size of box in x dimension
5421 c if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5422 c if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5423 C Condition for being inside the proper box
5424 c if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5425 c & (xi.lt.((xshift-0.5d0)*boxxsize))) then
5429 c if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5430 c if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5431 C Condition for being inside the proper box
5432 c if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5433 c & (yi.lt.((yshift-0.5d0)*boxysize))) then
5437 c if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5438 c if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5439 cC Condition for being inside the proper box
5440 c if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5441 c & (zi.lt.((zshift-0.5d0)*boxzsize))) then
5444 call to_box(xi,yi,zi)
5445 C xi=xi+xshift*boxxsize
5446 C yi=yi+yshift*boxysize
5447 C zi=zi+zshift*boxzsize
5448 c do iint=1,nscp_gr(i)
5450 c do j=iscpstart(i,iint),iscpend(i,iint)
5451 if (itype(j).eq.ntyp1) cycle
5452 itypj=iabs(itype(j))
5453 C Uncomment following three lines for SC-p interactions
5457 C Uncomment following three lines for Ca-p interactions
5461 call to_box(xj,yj,zj)
5462 xj=boxshift(xj-xi,boxxsize)
5463 yj=boxshift(yj-yi,boxysize)
5464 zj=boxshift(zj-zi,boxzsize)
5468 rij=xj*xj+yj*yj+zj*zj
5472 if (rij.lt.r0ijsq) then
5473 evdwij=0.25d0*(rij-r0ijsq)**2
5481 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5487 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5488 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5499 C-----------------------------------------------------------------------------
5500 subroutine escp(evdw2,evdw2_14)
5502 C This subroutine calculates the excluded-volume interaction energy between
5503 C peptide-group centers and side chains and its gradient in virtual-bond and
5504 C side-chain vectors.
5507 include 'DIMENSIONS'
5508 include 'COMMON.GEO'
5509 include 'COMMON.VAR'
5510 include 'COMMON.LOCAL'
5511 include 'COMMON.CHAIN'
5512 include 'COMMON.DERIV'
5513 include 'COMMON.INTERACT'
5514 include 'COMMON.FFIELD'
5515 include 'COMMON.IOUNITS'
5516 include 'COMMON.CONTROL'
5517 include 'COMMON.SPLITELE'
5518 double precision ggg(3)
5519 integer i,iint,j,k,iteli,itypj,subchap,ikont
5520 double precision xi,yi,zi,xj,yj,zj,rrij,sss1,sssgrad1,
5522 double precision evdw2,evdw2_14,evdwij
5523 double precision sscale,sscagrad
5524 double precision boxshift
5527 c print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5528 cd print '(a)','Enter ESCP'
5529 cd write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5533 if (energy_dec) write (iout,*) "escp:",r_cut_int,rlamb
5534 c do i=iatscp_s,iatscp_e
5535 do ikont=g_listscp_start,g_listscp_end
5536 i=newcontlistscpi(ikont)
5537 j=newcontlistscpj(ikont)
5538 if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5540 xi=0.5D0*(c(1,i)+c(1,i+1))
5541 yi=0.5D0*(c(2,i)+c(2,i+1))
5542 zi=0.5D0*(c(3,i)+c(3,i+1))
5543 call to_box(xi,yi,zi)
5544 c do iint=1,nscp_gr(i)
5546 c do j=iscpstart(i,iint),iscpend(i,iint)
5547 itypj=iabs(itype(j))
5548 if (itypj.eq.ntyp1) cycle
5549 C Uncomment following three lines for SC-p interactions
5553 C Uncomment following three lines for Ca-p interactions
5557 call to_box(xj,yj,zj)
5558 xj=boxshift(xj-xi,boxxsize)
5559 yj=boxshift(yj-yi,boxysize)
5560 zj=boxshift(zj-zi,boxzsize)
5561 c print *,xj,yj,zj,'polozenie j'
5562 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5564 sss=sscale(1.0d0/(dsqrt(rrij)),r_cut_int)
5565 c print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5566 c if (sss.eq.0) print *,'czasem jest OK'
5567 if (sss.le.0.0d0) cycle
5568 sssgrad=sscagrad(1.0d0/(dsqrt(rrij)),r_cut_int)
5570 e1=fac*fac*aad(itypj,iteli)
5571 e2=fac*bad(itypj,iteli)
5572 if (iabs(j-i) .le. 2) then
5575 evdw2_14=evdw2_14+(e1+e2)*sss
5578 evdw2=evdw2+evdwij*sss
5579 if (energy_dec) write (iout,'(a6,2i5,3f7.3,2i3,3e11.3)')
5580 & 'evdw2',i,j,1.0d0/dsqrt(rrij),sss,
5581 & evdwij,iteli,itypj,fac,aad(itypj,iteli),
5584 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5586 fac=-(evdwij+e1)*rrij*sss
5587 fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5591 cgrad if (j.lt.i) then
5592 cd write (iout,*) 'j<i'
5593 C Uncomment following three lines for SC-p interactions
5595 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5598 cd write (iout,*) 'j>i'
5600 cgrad ggg(k)=-ggg(k)
5601 C Uncomment following line for SC-p interactions
5602 ccgrad gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5603 c gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5607 cgrad gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5609 cgrad kstart=min0(i+1,j)
5610 cgrad kend=max0(i-1,j-1)
5611 cd write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5612 cd write (iout,*) ggg(1),ggg(2),ggg(3)
5613 cgrad do k=kstart,kend
5615 cgrad gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5619 gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5620 gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5622 c endif !endif for sscale cutoff
5632 gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5633 gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5634 gradx_scp(j,i)=expon*gradx_scp(j,i)
5637 C******************************************************************************
5641 C To save time the factor EXPON has been extracted from ALL components
5642 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5645 C******************************************************************************
5648 C--------------------------------------------------------------------------
5649 subroutine edis(ehpb)
5651 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5653 implicit real*8 (a-h,o-z)
5654 include 'DIMENSIONS'
5655 include 'COMMON.SBRIDGE'
5656 include 'COMMON.CHAIN'
5657 include 'COMMON.DERIV'
5658 include 'COMMON.VAR'
5659 include 'COMMON.INTERACT'
5660 include 'COMMON.IOUNITS'
5661 include 'COMMON.CONTROL'
5662 dimension ggg(3),ggg_peak(3,1000)
5667 c 8/21/18 AL: added explicit restraints on reference coords
5668 c write (iout,*) "restr_on_coord",restr_on_coord
5669 if (restr_on_coord) then
5673 if (itype(i).eq.ntyp1) cycle
5675 ecoor=ecoor+(c(j,i)-cref(j,i))**2
5676 ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5678 if (itype(i).ne.10) then
5680 ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5681 ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5684 if (energy_dec) write (iout,*)
5685 & "i",i," bfac",bfac(i)," ecoor",ecoor
5686 ehpb=ehpb+0.5d0*bfac(i)*ecoor
5690 C write (iout,*) ,"link_end",link_end,constr_dist
5691 cd write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5692 c write(iout,*)'link_start=',link_start,' link_end=',link_end,
5693 c & " constr_dist",constr_dist," link_start_peak",link_start_peak,
5694 c & " link_end_peak",link_end_peak
5695 if (link_end.eq.0.and.link_end_peak.eq.0) return
5696 do i=link_start_peak,link_end_peak
5698 c print *,"i",i," link_end_peak",link_end_peak," ipeak",
5699 c & ipeak(1,i),ipeak(2,i)
5700 do ip=ipeak(1,i),ipeak(2,i)
5705 C iii and jjj point to the residues for which the distance is assigned.
5706 c if (ii.gt.nres) then
5713 if (ii.gt.nres) then
5718 if (jj.gt.nres) then
5723 aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5724 aux=dexp(-scal_peak*aux)
5725 ehpb_peak=ehpb_peak+aux
5726 fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5727 & forcon_peak(ip))*aux/dd
5729 ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5731 if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5732 & "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5733 & forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5735 c write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5736 ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5737 do ip=ipeak(1,i),ipeak(2,i)
5740 ggg(j)=ggg_peak(j,iip)/ehpb_peak
5744 C iii and jjj point to the residues for which the distance is assigned.
5745 c if (ii.gt.nres) then
5752 if (ii.gt.nres) then
5757 if (jj.gt.nres) then
5764 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5769 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5773 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5774 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5778 do i=link_start,link_end
5779 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5780 C CA-CA distance used in regularization of structure.
5783 C iii and jjj point to the residues for which the distance is assigned.
5784 if (ii.gt.nres) then
5789 if (jj.gt.nres) then
5794 c write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5795 c & dhpb(i),dhpb1(i),forcon(i)
5796 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5797 C distance and angle dependent SS bond potential.
5798 C if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5799 C & iabs(itype(jjj)).eq.1) then
5800 cmc if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5801 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5802 if (.not.dyn_ss .and. i.le.nss) then
5803 C 15/02/13 CC dynamic SSbond - additional check
5804 if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5805 & iabs(itype(jjj)).eq.1) then
5806 call ssbond_ene(iii,jjj,eij)
5809 cd write (iout,*) "eij",eij
5810 cd & ' waga=',waga,' fac=',fac
5811 ! else if (ii.gt.nres .and. jj.gt.nres) then
5813 C Calculate the distance between the two points and its difference from the
5816 if (irestr_type(i).eq.11) then
5817 ehpb=ehpb+fordepth(i)!**4.0d0
5818 & *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5819 fac=fordepth(i)!**4.0d0
5820 & *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5821 if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5822 & "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5823 & ehpb,irestr_type(i)
5824 else if (irestr_type(i).eq.10) then
5825 c AL 6//19/2018 cross-link restraints
5826 xdis = 0.5d0*(dd/forcon(i))**2
5827 expdis = dexp(-xdis)
5828 c aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5829 aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5830 c write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5831 c & " wboltzd",wboltzd
5832 ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5833 c fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5834 fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5835 & *expdis/(aux*forcon(i)**2)
5836 if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5837 & "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5838 & -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5839 else if (irestr_type(i).eq.2) then
5840 c Quartic restraints
5841 ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5842 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5843 & "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5844 & forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5845 fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5847 c Quadratic restraints
5849 C Get the force constant corresponding to this distance.
5851 C Calculate the contribution to energy.
5852 ehpb=ehpb+0.5d0*waga*rdis*rdis
5853 if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5854 & "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5855 & 0.5d0*waga*rdis*rdis,irestr_type(i)
5857 C Evaluate gradient.
5861 c Calculate Cartesian gradient
5863 ggg(j)=fac*(c(j,jj)-c(j,ii))
5865 cd print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5866 C If this is a SC-SC distance, we need to calculate the contributions to the
5867 C Cartesian gradient in the SC vectors (ghpbx).
5870 ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5875 ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5879 ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5880 ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5886 C--------------------------------------------------------------------------
5887 subroutine ssbond_ene(i,j,eij)
5889 C Calculate the distance and angle dependent SS-bond potential energy
5890 C using a free-energy function derived based on RHF/6-31G** ab initio
5891 C calculations of diethyl disulfide.
5893 C A. Liwo and U. Kozlowska, 11/24/03
5895 implicit real*8 (a-h,o-z)
5896 include 'DIMENSIONS'
5897 include 'COMMON.SBRIDGE'
5898 include 'COMMON.CHAIN'
5899 include 'COMMON.DERIV'
5900 include 'COMMON.LOCAL'
5901 include 'COMMON.INTERACT'
5902 include 'COMMON.VAR'
5903 include 'COMMON.IOUNITS'
5904 double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5905 itypi=iabs(itype(i))
5909 dxi=dc_norm(1,nres+i)
5910 dyi=dc_norm(2,nres+i)
5911 dzi=dc_norm(3,nres+i)
5912 c dsci_inv=dsc_inv(itypi)
5913 dsci_inv=vbld_inv(nres+i)
5914 itypj=iabs(itype(j))
5915 c dscj_inv=dsc_inv(itypj)
5916 dscj_inv=vbld_inv(nres+j)
5920 dxj=dc_norm(1,nres+j)
5921 dyj=dc_norm(2,nres+j)
5922 dzj=dc_norm(3,nres+j)
5923 rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5928 om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5929 om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5930 om12=dxi*dxj+dyi*dyj+dzi*dzj
5932 dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5933 dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5939 deltat12=om2-om1+2.0d0
5941 eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5942 & +akct*deltad*deltat12
5943 & +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5944 c write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5945 c & " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5946 c & " deltat12",deltat12," eij",eij
5947 ed=2*akcm*deltad+akct*deltat12
5949 pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5950 eom1=-2*akth*deltat1-pom1-om2*pom2
5951 eom2= 2*akth*deltat2+pom1-om1*pom2
5954 ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5955 ghpbx(k,i)=ghpbx(k,i)-ggk
5956 & +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5957 & +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5958 ghpbx(k,j)=ghpbx(k,j)+ggk
5959 & +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5960 & +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5961 ghpbc(k,i)=ghpbc(k,i)-ggk
5962 ghpbc(k,j)=ghpbc(k,j)+ggk
5965 C Calculate the components of the gradient in DC and X
5969 cgrad ghpbc(l,k)=ghpbc(l,k)+gg(l)
5974 C--------------------------------------------------------------------------
5975 subroutine ebond(estr)
5977 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5979 implicit real*8 (a-h,o-z)
5980 include 'DIMENSIONS'
5981 include 'COMMON.LOCAL'
5982 include 'COMMON.GEO'
5983 include 'COMMON.INTERACT'
5984 include 'COMMON.DERIV'
5985 include 'COMMON.VAR'
5986 include 'COMMON.CHAIN'
5987 include 'COMMON.IOUNITS'
5988 include 'COMMON.NAMES'
5989 include 'COMMON.FFIELD'
5990 include 'COMMON.CONTROL'
5991 include 'COMMON.SETUP'
5992 double precision u(3),ud(3)
5995 do i=ibondp_start,ibondp_end
5996 c 3/4/2020 Adam: removed dummy bond graient if Calpha and SC coords are
5999 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) cycle
6000 diff = vbld(i)-vbldp0
6002 if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6003 c estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6005 c gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6006 c & *dc(j,i-1)/vbld(i)
6008 c if (energy_dec) write(iout,*)
6009 c & "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6011 C Checking if it involves dummy (NH3+ or COO-) group
6012 if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6013 C YES vbldpDUM is the equlibrium length of spring for Dummy atom
6014 diff = vbld(i)-vbldpDUM
6015 if (energy_dec) write(iout,*) "dum_bond",i,diff
6017 C NO vbldp0 is the equlibrium length of spring for peptide group
6018 diff = vbld(i)-vbldp0
6021 if (energy_dec) write (iout,'(a7,i5,4f7.3)')
6022 & "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6025 gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6027 c write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6031 estr=0.5d0*AKP*estr+estr1
6033 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6035 do i=ibond_start,ibond_end
6037 if (iti.ne.10 .and. iti.ne.ntyp1) then
6040 diff=vbld(i+nres)-vbldsc0(1,iti)
6041 if (energy_dec) write (iout,*)
6042 & "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6043 & AKSC(1,iti),AKSC(1,iti)*diff*diff
6044 estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6046 gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6050 diff=vbld(i+nres)-vbldsc0(j,iti)
6051 ud(j)=aksc(j,iti)*diff
6052 u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6066 uprod2=uprod2*u(k)*u(k)
6070 usumsqder=usumsqder+ud(j)*uprod2
6072 estr=estr+uprod/usum
6074 gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6082 C--------------------------------------------------------------------------
6083 subroutine ebend(etheta)
6085 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6086 C angles gamma and its derivatives in consecutive thetas and gammas.
6088 implicit real*8 (a-h,o-z)
6089 include 'DIMENSIONS'
6090 include 'COMMON.LOCAL'
6091 include 'COMMON.GEO'
6092 include 'COMMON.INTERACT'
6093 include 'COMMON.DERIV'
6094 include 'COMMON.VAR'
6095 include 'COMMON.CHAIN'
6096 include 'COMMON.IOUNITS'
6097 include 'COMMON.NAMES'
6098 include 'COMMON.FFIELD'
6099 include 'COMMON.CONTROL'
6100 include 'COMMON.TORCNSTR'
6101 common /calcthet/ term1,term2,termm,diffak,ratak,
6102 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6103 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6104 double precision y(2),z(2)
6106 c time11=dexp(-2*time)
6109 c write (*,'(a,i2)') 'EBEND ICG=',icg
6110 do i=ithet_start,ithet_end
6111 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6112 & .or.itype(i).eq.ntyp1) cycle
6113 C Zero the energy function and its derivative at 0 or pi.
6114 call splinthet(theta(i),0.5d0*delta,ss,ssd)
6116 ichir1=isign(1,itype(i-2))
6117 ichir2=isign(1,itype(i))
6118 if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6119 if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6120 if (itype(i-1).eq.10) then
6121 itype1=isign(10,itype(i-2))
6122 ichir11=isign(1,itype(i-2))
6123 ichir12=isign(1,itype(i-2))
6124 itype2=isign(10,itype(i))
6125 ichir21=isign(1,itype(i))
6126 ichir22=isign(1,itype(i))
6129 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6132 if (phii.ne.phii) phii=150.0
6142 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6145 if (phii1.ne.phii1) phii1=150.0
6157 C Calculate the "mean" value of theta from the part of the distribution
6158 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6159 C In following comments this theta will be referred to as t_c.
6160 thet_pred_mean=0.0d0
6162 athetk=athet(k,it,ichir1,ichir2)
6163 bthetk=bthet(k,it,ichir1,ichir2)
6165 athetk=athet(k,itype1,ichir11,ichir12)
6166 bthetk=bthet(k,itype2,ichir21,ichir22)
6168 thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6169 c write(iout,*) 'chuj tu', y(k),z(k)
6171 dthett=thet_pred_mean*ssd
6172 thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6173 C Derivatives of the "mean" values in gamma1 and gamma2.
6174 dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6175 &+athet(2,it,ichir1,ichir2)*y(1))*ss
6176 dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6177 & +bthet(2,it,ichir1,ichir2)*z(1))*ss
6179 dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6180 &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6181 dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6182 & +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6184 if (theta(i).gt.pi-delta) then
6185 call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6187 call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6188 call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6189 call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6191 call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6193 else if (theta(i).lt.delta) then
6194 call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6195 call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6196 call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6198 call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6199 call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6202 call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6205 etheta=etheta+ethetai
6206 if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6207 & 'ebend',i,ethetai,theta(i),itype(i)
6208 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6209 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6210 gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6213 C Ufff.... We've done all this!!!
6216 C---------------------------------------------------------------------------
6217 subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6219 implicit real*8 (a-h,o-z)
6220 include 'DIMENSIONS'
6221 include 'COMMON.LOCAL'
6222 include 'COMMON.IOUNITS'
6223 common /calcthet/ term1,term2,termm,diffak,ratak,
6224 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6225 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6226 C Calculate the contributions to both Gaussian lobes.
6227 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6228 C The "polynomial part" of the "standard deviation" of this part of
6229 C the distributioni.
6230 ccc write (iout,*) thetai,thet_pred_mean
6233 sig=sig*thet_pred_mean+polthet(j,it)
6235 C Derivative of the "interior part" of the "standard deviation of the"
6236 C gamma-dependent Gaussian lobe in t_c.
6237 sigtc=3*polthet(3,it)
6239 sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6242 C Set the parameters of both Gaussian lobes of the distribution.
6243 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6244 fac=sig*sig+sigc0(it)
6247 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6248 sigsqtc=-4.0D0*sigcsq*sigtc
6249 c print *,i,sig,sigtc,sigsqtc
6250 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6251 sigtc=-sigtc/(fac*fac)
6252 C Following variable is sigma(t_c)**(-2)
6253 sigcsq=sigcsq*sigcsq
6255 sig0inv=1.0D0/sig0i**2
6256 delthec=thetai-thet_pred_mean
6257 delthe0=thetai-theta0i
6258 term1=-0.5D0*sigcsq*delthec*delthec
6259 term2=-0.5D0*sig0inv*delthe0*delthe0
6260 C write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6261 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6262 C NaNs in taking the logarithm. We extract the largest exponent which is added
6263 C to the energy (this being the log of the distribution) at the end of energy
6264 C term evaluation for this virtual-bond angle.
6265 if (term1.gt.term2) then
6267 term2=dexp(term2-termm)
6271 term1=dexp(term1-termm)
6274 C The ratio between the gamma-independent and gamma-dependent lobes of
6275 C the distribution is a Gaussian function of thet_pred_mean too.
6276 diffak=gthet(2,it)-thet_pred_mean
6277 ratak=diffak/gthet(3,it)**2
6278 ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6279 C Let's differentiate it in thet_pred_mean NOW.
6281 C Now put together the distribution terms to make complete distribution.
6282 termexp=term1+ak*term2
6283 termpre=sigc+ak*sig0i
6284 C Contribution of the bending energy from this theta is just the -log of
6285 C the sum of the contributions from the two lobes and the pre-exponential
6286 C factor. Simple enough, isn't it?
6287 ethetai=(-dlog(termexp)-termm+dlog(termpre))
6288 C write (iout,*) 'termexp',termexp,termm,termpre,i
6289 C NOW the derivatives!!!
6290 C 6/6/97 Take into account the deformation.
6291 E_theta=(delthec*sigcsq*term1
6292 & +ak*delthe0*sig0inv*term2)/termexp
6293 E_tc=((sigtc+aktc*sig0i)/termpre
6294 & -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6295 & aktc*term2)/termexp)
6298 c-----------------------------------------------------------------------------
6299 subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6300 implicit real*8 (a-h,o-z)
6301 include 'DIMENSIONS'
6302 include 'COMMON.LOCAL'
6303 include 'COMMON.IOUNITS'
6304 common /calcthet/ term1,term2,termm,diffak,ratak,
6305 & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6306 & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6307 delthec=thetai-thet_pred_mean
6308 delthe0=thetai-theta0i
6309 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6310 t3 = thetai-thet_pred_mean
6314 t14 = t12+t6*sigsqtc
6316 t21 = thetai-theta0i
6322 E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6323 & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6324 & *(-t12*t9-ak*sig0inv*t27)
6328 C--------------------------------------------------------------------------
6329 subroutine ebend(etheta)
6331 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6332 C angles gamma and its derivatives in consecutive thetas and gammas.
6333 C ab initio-derived potentials from
6334 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6336 implicit real*8 (a-h,o-z)
6337 include 'DIMENSIONS'
6338 include 'COMMON.LOCAL'
6339 include 'COMMON.GEO'
6340 include 'COMMON.INTERACT'
6341 include 'COMMON.DERIV'
6342 include 'COMMON.VAR'
6343 include 'COMMON.CHAIN'
6344 include 'COMMON.IOUNITS'
6345 include 'COMMON.NAMES'
6346 include 'COMMON.FFIELD'
6347 include 'COMMON.CONTROL'
6348 include 'COMMON.TORCNSTR'
6349 double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6350 & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6351 & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6352 & sinph1ph2(maxdouble,maxdouble)
6353 logical lprn /.false./, lprn1 /.false./
6355 do i=ithet_start,ithet_end
6356 c print *,i,itype(i-1),itype(i),itype(i-2)
6357 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6358 & .or.itype(i).eq.ntyp1) cycle
6359 C print *,i,theta(i)
6360 if (iabs(itype(i+1)).eq.20) iblock=2
6361 if (iabs(itype(i+1)).ne.20) iblock=1
6365 theti2=0.5d0*theta(i)
6366 ityp2=ithetyp((itype(i-1)))
6368 coskt(k)=dcos(k*theti2)
6369 sinkt(k)=dsin(k*theti2)
6372 if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6375 if (phii.ne.phii) phii=150.0
6379 ityp1=ithetyp((itype(i-2)))
6380 C propagation of chirality for glycine type
6382 cosph1(k)=dcos(k*phii)
6383 sinph1(k)=dsin(k*phii)
6388 ityp1=ithetyp((itype(i-2)))
6393 if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6396 if (phii1.ne.phii1) phii1=150.0
6401 ityp3=ithetyp((itype(i)))
6403 cosph2(k)=dcos(k*phii1)
6404 sinph2(k)=dsin(k*phii1)
6408 ityp3=ithetyp((itype(i)))
6414 ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6417 ccl=cosph1(l)*cosph2(k-l)
6418 ssl=sinph1(l)*sinph2(k-l)
6419 scl=sinph1(l)*cosph2(k-l)
6420 csl=cosph1(l)*sinph2(k-l)
6421 cosph1ph2(l,k)=ccl-ssl
6422 cosph1ph2(k,l)=ccl+ssl
6423 sinph1ph2(l,k)=scl+csl
6424 sinph1ph2(k,l)=scl-csl
6428 write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6429 & " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6430 write (iout,*) "coskt and sinkt"
6432 write (iout,*) k,coskt(k),sinkt(k)
6436 ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6437 dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6440 & write (iout,*) "k",k,"
6441 & aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6442 & " ethetai",ethetai
6445 write (iout,*) "cosph and sinph"
6447 write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6449 write (iout,*) "cosph1ph2 and sinph2ph2"
6452 write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6453 & sinph1ph2(l,k),sinph1ph2(k,l)
6456 write(iout,*) "ethetai",ethetai
6461 aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6462 & +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6463 & +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6464 & +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6465 ethetai=ethetai+sinkt(m)*aux
6466 dethetai=dethetai+0.5d0*m*aux*coskt(m)
6467 dephii=dephii+k*sinkt(m)*(
6468 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6469 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6470 dephii1=dephii1+k*sinkt(m)*(
6471 & eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6472 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6474 & write (iout,*) "m",m," k",k," bbthet",
6475 & bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6476 & ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6477 & ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6478 & eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6479 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6482 C print *,"cosph1", (cosph1(k), k=1,nsingle)
6483 C print *,"cosph2", (cosph2(k), k=1,nsingle)
6484 C print *,"sinph1", (sinph1(k), k=1,nsingle)
6485 C print *,"sinph2", (sinph2(k), k=1,nsingle)
6487 & write(iout,*) "ethetai",ethetai
6488 C print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6492 aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6493 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6494 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6495 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6496 ethetai=ethetai+sinkt(m)*aux
6497 dethetai=dethetai+0.5d0*m*coskt(m)*aux
6498 dephii=dephii+l*sinkt(m)*(
6499 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6500 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6501 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6502 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6503 dephii1=dephii1+(k-l)*sinkt(m)*(
6504 & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6505 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6506 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6507 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6509 write (iout,*) "m",m," k",k," l",l," ffthet",
6510 & ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6511 & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6512 & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6513 & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6514 & " ethetai",ethetai
6515 write (iout,*) cosph1ph2(l,k)*sinkt(m),
6516 & cosph1ph2(k,l)*sinkt(m),
6517 & sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6526 & write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6527 & i,theta(i)*rad2deg,phii*rad2deg,
6528 & phii1*rad2deg,ethetai
6530 etheta=etheta+ethetai
6531 if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6532 if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6533 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6540 c-----------------------------------------------------------------------------
6541 subroutine esc(escloc)
6542 C Calculate the local energy of a side chain and its derivatives in the
6543 C corresponding virtual-bond valence angles THETA and the spherical angles
6545 implicit real*8 (a-h,o-z)
6546 include 'DIMENSIONS'
6547 include 'COMMON.GEO'
6548 include 'COMMON.LOCAL'
6549 include 'COMMON.VAR'
6550 include 'COMMON.INTERACT'
6551 include 'COMMON.DERIV'
6552 include 'COMMON.CHAIN'
6553 include 'COMMON.IOUNITS'
6554 include 'COMMON.NAMES'
6555 include 'COMMON.FFIELD'
6556 include 'COMMON.CONTROL'
6557 double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6558 & ddersc0(3),ddummy(3),xtemp(3),temp(3)
6559 common /sccalc/ time11,time12,time112,theti,it,nlobit
6562 c write (iout,'(a)') 'ESC'
6563 do i=loc_start,loc_end
6565 if (it.eq.ntyp1) cycle
6566 if (it.eq.10) goto 1
6567 nlobit=nlob(iabs(it))
6568 c print *,'i=',i,' it=',it,' nlobit=',nlobit
6569 c write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6570 theti=theta(i+1)-pipol
6575 if (x(2).gt.pi-delta) then
6579 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6581 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6582 call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6584 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6585 & ddersc0(1),dersc(1))
6586 call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6587 & ddersc0(3),dersc(3))
6589 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6591 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6592 call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6593 & dersc0(2),esclocbi,dersc02)
6594 call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6596 call splinthet(x(2),0.5d0*delta,ss,ssd)
6601 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6603 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6604 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6606 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6608 c write (iout,*) escloci
6609 else if (x(2).lt.delta) then
6613 call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6615 call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6616 call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6618 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6619 & ddersc0(1),dersc(1))
6620 call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6621 & ddersc0(3),dersc(3))
6623 call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6625 call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6626 call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6627 & dersc0(2),esclocbi,dersc02)
6628 call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6633 call splinthet(x(2),0.5d0*delta,ss,ssd)
6635 dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6637 dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6638 c write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6640 escloci=ss*escloci+(1.0d0-ss)*esclocbi
6641 c write (iout,*) escloci
6643 call enesc(x,escloci,dersc,ddummy,.false.)
6646 escloc=escloc+escloci
6647 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6648 & 'escloc',i,escloci
6649 c write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6651 gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6653 gloc(ialph(i,1),icg)=wscloc*dersc(2)
6654 gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6659 C---------------------------------------------------------------------------
6660 subroutine enesc(x,escloci,dersc,ddersc,mixed)
6661 implicit real*8 (a-h,o-z)
6662 include 'DIMENSIONS'
6663 include 'COMMON.GEO'
6664 include 'COMMON.LOCAL'
6665 include 'COMMON.IOUNITS'
6666 common /sccalc/ time11,time12,time112,theti,it,nlobit
6667 double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6668 double precision contr(maxlob,-1:1)
6670 c write (iout,*) 'it=',it,' nlobit=',nlobit
6674 if (mixed) ddersc(j)=0.0d0
6678 C Because of periodicity of the dependence of the SC energy in omega we have
6679 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6680 C To avoid underflows, first compute & store the exponents.
6688 z(k)=x(k)-censc(k,j,it)
6693 Axk=Axk+gaussc(l,k,j,it)*z(l)
6699 expfac=expfac+Ax(k,j,iii)*z(k)
6707 C As in the case of ebend, we want to avoid underflows in exponentiation and
6708 C subsequent NaNs and INFs in energy calculation.
6709 C Find the largest exponent
6713 if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6717 cd print *,'it=',it,' emin=',emin
6719 C Compute the contribution to SC energy and derivatives
6724 adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6725 if(adexp.ne.adexp) adexp=1.0
6728 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6730 cd print *,'j=',j,' expfac=',expfac
6731 escloc_i=escloc_i+expfac
6733 dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6737 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6738 & +gaussc(k,2,j,it))*expfac
6745 dersc(1)=dersc(1)/cos(theti)**2
6746 ddersc(1)=ddersc(1)/cos(theti)**2
6749 escloci=-(dlog(escloc_i)-emin)
6751 dersc(j)=dersc(j)/escloc_i
6755 ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6760 C------------------------------------------------------------------------------
6761 subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6762 implicit real*8 (a-h,o-z)
6763 include 'DIMENSIONS'
6764 include 'COMMON.GEO'
6765 include 'COMMON.LOCAL'
6766 include 'COMMON.IOUNITS'
6767 common /sccalc/ time11,time12,time112,theti,it,nlobit
6768 double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6769 double precision contr(maxlob)
6780 z(k)=x(k)-censc(k,j,it)
6786 Axk=Axk+gaussc(l,k,j,it)*z(l)
6792 expfac=expfac+Ax(k,j)*z(k)
6797 C As in the case of ebend, we want to avoid underflows in exponentiation and
6798 C subsequent NaNs and INFs in energy calculation.
6799 C Find the largest exponent
6802 if (emin.gt.contr(j)) emin=contr(j)
6806 C Compute the contribution to SC energy and derivatives
6810 expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6811 escloc_i=escloc_i+expfac
6813 dersc(k)=dersc(k)+Ax(k,j)*expfac
6815 if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6816 & +gaussc(1,2,j,it))*expfac
6820 dersc(1)=dersc(1)/cos(theti)**2
6821 dersc12=dersc12/cos(theti)**2
6822 escloci=-(dlog(escloc_i)-emin)
6824 dersc(j)=dersc(j)/escloc_i
6826 if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6830 c----------------------------------------------------------------------------------
6831 subroutine esc(escloc)
6832 C Calculate the local energy of a side chain and its derivatives in the
6833 C corresponding virtual-bond valence angles THETA and the spherical angles
6834 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6835 C added by Urszula Kozlowska. 07/11/2007
6837 implicit real*8 (a-h,o-z)
6838 include 'DIMENSIONS'
6839 include 'COMMON.GEO'
6840 include 'COMMON.LOCAL'
6841 include 'COMMON.VAR'
6842 include 'COMMON.SCROT'
6843 include 'COMMON.INTERACT'
6844 include 'COMMON.DERIV'
6845 include 'COMMON.CHAIN'
6846 include 'COMMON.IOUNITS'
6847 include 'COMMON.NAMES'
6848 include 'COMMON.FFIELD'
6849 include 'COMMON.CONTROL'
6850 include 'COMMON.VECTORS'
6851 double precision x_prime(3),y_prime(3),z_prime(3)
6852 & , sumene,dsc_i,dp2_i,x(65),
6853 & xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6854 & de_dxx,de_dyy,de_dzz,de_dt
6855 double precision s1_t,s1_6_t,s2_t,s2_6_t
6857 & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6858 & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6859 & dt_dCi(3),dt_dCi1(3)
6860 common /sccalc/ time11,time12,time112,theti,it,nlobit
6863 do i=loc_start,loc_end
6864 if (itype(i).eq.ntyp1) cycle
6865 costtab(i+1) =dcos(theta(i+1))
6866 sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6867 cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6868 sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6869 cosfac2=0.5d0/(1.0d0+costtab(i+1))
6870 cosfac=dsqrt(cosfac2)
6871 sinfac2=0.5d0/(1.0d0-costtab(i+1))
6872 sinfac=dsqrt(sinfac2)
6874 if (it.eq.10) goto 1
6876 C Compute the axes of tghe local cartesian coordinates system; store in
6877 c x_prime, y_prime and z_prime
6884 C write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6885 C & dc_norm(3,i+nres)
6887 x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6888 y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6891 z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6894 c write (2,*) "x_prime",(x_prime(j),j=1,3)
6895 c write (2,*) "y_prime",(y_prime(j),j=1,3)
6896 c write (2,*) "z_prime",(z_prime(j),j=1,3)
6897 c write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6898 c & " xy",scalar(x_prime(1),y_prime(1)),
6899 c & " xz",scalar(x_prime(1),z_prime(1)),
6900 c & " yy",scalar(y_prime(1),y_prime(1)),
6901 c & " yz",scalar(y_prime(1),z_prime(1)),
6902 c & " zz",scalar(z_prime(1),z_prime(1))
6904 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6905 C to local coordinate system. Store in xx, yy, zz.
6911 xx = xx + x_prime(j)*dc_norm(j,i+nres)
6912 yy = yy + y_prime(j)*dc_norm(j,i+nres)
6913 zz = zz + z_prime(j)*dc_norm(j,i+nres)
6920 C Compute the energy of the ith side cbain
6922 c write (2,*) "xx",xx," yy",yy," zz",zz
6925 x(j) = sc_parmin(j,it)
6928 Cc diagnostics - remove later
6930 yy1 = dsin(alph(2))*dcos(omeg(2))
6931 zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6932 write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6933 & alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6935 C," --- ", xx_w,yy_w,zz_w
6938 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
6939 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
6941 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6942 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6944 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6945 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6946 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6947 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6948 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6950 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6951 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6952 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6953 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6954 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6956 dsc_i = 0.743d0+x(61)
6958 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6959 & *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6960 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6961 & *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6962 s1=(1+x(63))/(0.1d0 + dscp1)
6963 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6964 s2=(1+x(65))/(0.1d0 + dscp2)
6965 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6966 sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6967 & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6968 c write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6970 c & dscp1,dscp2,sumene
6971 c sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6972 escloc = escloc + sumene
6973 if (energy_dec) write (2,*) "i",i," itype",itype(i)," it",it,
6974 & " escloc",sumene,escloc,it,itype(i)
6979 C This section to check the numerical derivatives of the energy of ith side
6980 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6981 C #define DEBUG in the code to turn it on.
6983 write (2,*) "sumene =",sumene
6987 write (2,*) xx,yy,zz
6988 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6989 de_dxx_num=(sumenep-sumene)/aincr
6991 write (2,*) "xx+ sumene from enesc=",sumenep
6994 write (2,*) xx,yy,zz
6995 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6996 de_dyy_num=(sumenep-sumene)/aincr
6998 write (2,*) "yy+ sumene from enesc=",sumenep
7001 write (2,*) xx,yy,zz
7002 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7003 de_dzz_num=(sumenep-sumene)/aincr
7005 write (2,*) "zz+ sumene from enesc=",sumenep
7006 costsave=cost2tab(i+1)
7007 sintsave=sint2tab(i+1)
7008 cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7009 sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7010 sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7011 de_dt_num=(sumenep-sumene)/aincr
7012 write (2,*) " t+ sumene from enesc=",sumenep
7013 cost2tab(i+1)=costsave
7014 sint2tab(i+1)=sintsave
7015 C End of diagnostics section.
7018 C Compute the gradient of esc
7020 c zz=zz*dsign(1.0,dfloat(itype(i)))
7021 pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7022 pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7023 pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7024 pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7025 pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7026 pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7027 pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7028 pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7029 pom1=(sumene3*sint2tab(i+1)+sumene1)
7030 & *(pom_s1/dscp1+pom_s16*dscp1**4)
7031 pom2=(sumene4*cost2tab(i+1)+sumene2)
7032 & *(pom_s2/dscp2+pom_s26*dscp2**4)
7033 sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7034 sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7035 & +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7037 sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7038 sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7039 & +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7041 de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7042 & +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7043 & +(pom1+pom2)*pom_dx
7045 write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7048 sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7049 sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7050 & +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7052 sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7053 sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7054 & +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7055 & +x(59)*zz**2 +x(60)*xx*zz
7056 de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7057 & +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7058 & +(pom1-pom2)*pom_dy
7060 write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7063 de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7064 & +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7065 & +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7066 & +(x(4) + 2*x(7)*zz+ x(8)*xx + x(10)*yy)*(s1+s1_6)
7067 & +(x(44)+2*x(47)*zz +x(48)*xx +x(50)*yy +3*x(53)*zz**2
7068 & +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7069 & +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7070 & + ( x(14) + 2*x(17)*zz+ x(18)*xx + x(20)*yy)*(s2+s2_6)
7072 write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7075 de_dt = 0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7076 & -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7077 & +pom1*pom_dt1+pom2*pom_dt2
7079 write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7084 cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7085 cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7086 cosfac2xx=cosfac2*xx
7087 sinfac2yy=sinfac2*yy
7089 dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7091 dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7093 pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7094 pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7095 c write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7096 c & " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7097 c write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7098 c & (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7099 dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7100 dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7101 dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7102 dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7106 dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7107 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7108 dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7109 & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7112 dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7113 dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7114 dZZ_XYZ(k)=vbld_inv(i+nres)*
7115 & (z_prime(k)-zz*dC_norm(k,i+nres))
7117 dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7118 dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7122 dXX_Ctab(k,i)=dXX_Ci(k)
7123 dXX_C1tab(k,i)=dXX_Ci1(k)
7124 dYY_Ctab(k,i)=dYY_Ci(k)
7125 dYY_C1tab(k,i)=dYY_Ci1(k)
7126 dZZ_Ctab(k,i)=dZZ_Ci(k)
7127 dZZ_C1tab(k,i)=dZZ_Ci1(k)
7128 dXX_XYZtab(k,i)=dXX_XYZ(k)
7129 dYY_XYZtab(k,i)=dYY_XYZ(k)
7130 dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7134 c write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7135 c & dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7136 c write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7137 c & dyy_ci(k)," dzz_ci",dzz_ci(k)
7138 c write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7140 c write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7141 c & dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7142 gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7143 & +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7144 gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7145 & +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7146 gsclocx(k,i)= de_dxx*dxx_XYZ(k)
7147 & +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7149 c write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7150 c & (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7152 C to check gradient call subroutine check_grad
7158 c------------------------------------------------------------------------------
7159 double precision function enesc(x,xx,yy,zz,cost2,sint2)
7161 double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7162 & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7163 sumene1= x(1)+ x(2)*xx+ x(3)*yy+ x(4)*zz+ x(5)*xx**2
7164 & + x(6)*yy**2+ x(7)*zz**2+ x(8)*xx*zz+ x(9)*xx*yy
7166 sumene2= x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7167 & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7169 sumene3= x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7170 & +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7171 & +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7172 & +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7173 & +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7175 sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7176 & +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7177 & +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7178 & +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7179 & +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7181 dsc_i = 0.743d0+x(61)
7183 dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7184 & *(xx*cost2+yy*sint2))
7185 dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7186 & *(xx*cost2-yy*sint2))
7187 s1=(1+x(63))/(0.1d0 + dscp1)
7188 s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7189 s2=(1+x(65))/(0.1d0 + dscp2)
7190 s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7191 sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7192 & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7197 c------------------------------------------------------------------------------
7198 subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7200 C This procedure calculates two-body contact function g(rij) and its derivative:
7203 C g(rij) = esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5) ! -1 =< x =< 1
7206 C where x=(rij-r0ij)/delta
7208 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7211 double precision rij,r0ij,eps0ij,fcont,fprimcont
7212 double precision x,x2,x4,delta
7216 if (x.lt.-1.0D0) then
7219 else if (x.le.1.0D0) then
7222 fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7223 fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7230 c------------------------------------------------------------------------------
7231 subroutine splinthet(theti,delta,ss,ssder)
7232 implicit real*8 (a-h,o-z)
7233 include 'DIMENSIONS'
7234 include 'COMMON.VAR'
7235 include 'COMMON.GEO'
7238 if (theti.gt.pipol) then
7239 call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7241 call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7246 c------------------------------------------------------------------------------
7247 subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7249 double precision x,x0,delta,f0,f1,fprim0,f,fprim
7250 double precision ksi,ksi2,ksi3,a1,a2,a3
7251 a1=fprim0*delta/(f1-f0)
7257 f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7258 fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7261 c------------------------------------------------------------------------------
7262 subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7264 double precision x,x0,delta,f0x,f1x,fprim0x,fx
7265 double precision ksi,ksi2,ksi3,a1,a2,a3
7270 a2=3*(f1x-f0x)-2*fprim0x*delta
7271 a3=fprim0x*delta-2*(f1x-f0x)
7272 fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7275 C-----------------------------------------------------------------------------
7277 C-----------------------------------------------------------------------------
7278 subroutine etor(etors)
7279 implicit real*8 (a-h,o-z)
7280 include 'DIMENSIONS'
7281 include 'COMMON.VAR'
7282 include 'COMMON.GEO'
7283 include 'COMMON.LOCAL'
7284 include 'COMMON.TORSION'
7285 include 'COMMON.INTERACT'
7286 include 'COMMON.DERIV'
7287 include 'COMMON.CHAIN'
7288 include 'COMMON.NAMES'
7289 include 'COMMON.IOUNITS'
7290 include 'COMMON.FFIELD'
7291 include 'COMMON.TORCNSTR'
7292 include 'COMMON.CONTROL'
7294 C Set lprn=.true. for debugging
7298 do i=iphi_start,iphi_end
7300 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7301 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7302 itori=itortyp(itype(i-2))
7303 itori1=itortyp(itype(i-1))
7306 C Proline-Proline pair is a special case...
7307 if (itori.eq.3 .and. itori1.eq.3) then
7308 if (phii.gt.-dwapi3) then
7310 fac=1.0D0/(1.0D0-cosphi)
7311 etorsi=v1(1,3,3)*fac
7312 etorsi=etorsi+etorsi
7313 etors=etors+etorsi-v1(1,3,3)
7314 if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7315 gloci=gloci-3*fac*etorsi*dsin(3*phii)
7318 v1ij=v1(j+1,itori,itori1)
7319 v2ij=v2(j+1,itori,itori1)
7322 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7323 if (energy_dec) etors_ii=etors_ii+
7324 & v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7325 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7329 v1ij=v1(j,itori,itori1)
7330 v2ij=v2(j,itori,itori1)
7333 etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7334 if (energy_dec) etors_ii=etors_ii+
7335 & v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7336 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7339 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7342 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7343 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7344 & (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7345 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7346 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7350 c------------------------------------------------------------------------------
7351 subroutine etor_d(etors_d)
7355 c----------------------------------------------------------------------------
7356 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7357 subroutine e_modeller(ehomology_constr)
7358 ehomology_constr=0.0d0
7359 write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7362 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7364 c------------------------------------------------------------------------------
7365 subroutine etor_d(etors_d)
7369 c----------------------------------------------------------------------------
7371 subroutine etor(etors)
7372 implicit real*8 (a-h,o-z)
7373 include 'DIMENSIONS'
7374 include 'COMMON.VAR'
7375 include 'COMMON.GEO'
7376 include 'COMMON.LOCAL'
7377 include 'COMMON.TORSION'
7378 include 'COMMON.INTERACT'
7379 include 'COMMON.DERIV'
7380 include 'COMMON.CHAIN'
7381 include 'COMMON.NAMES'
7382 include 'COMMON.IOUNITS'
7383 include 'COMMON.FFIELD'
7384 include 'COMMON.TORCNSTR'
7385 include 'COMMON.CONTROL'
7387 C Set lprn=.true. for debugging
7391 do i=iphi_start,iphi_end
7392 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7393 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7394 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7395 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7396 if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7397 & .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7398 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7399 C For introducing the NH3+ and COO- group please check the etor_d for reference
7402 if (iabs(itype(i)).eq.20) then
7407 itori=itortyp(itype(i-2))
7408 itori1=itortyp(itype(i-1))
7411 C Regular cosine and sine terms
7412 do j=1,nterm(itori,itori1,iblock)
7413 v1ij=v1(j,itori,itori1,iblock)
7414 v2ij=v2(j,itori,itori1,iblock)
7417 etors=etors+v1ij*cosphi+v2ij*sinphi
7418 if (energy_dec) etors_ii=etors_ii+
7419 & v1ij*cosphi+v2ij*sinphi
7420 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7424 C E = SUM ----------------------------------- - v1
7425 C [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7427 cosphi=dcos(0.5d0*phii)
7428 sinphi=dsin(0.5d0*phii)
7429 do j=1,nlor(itori,itori1,iblock)
7430 vl1ij=vlor1(j,itori,itori1)
7431 vl2ij=vlor2(j,itori,itori1)
7432 vl3ij=vlor3(j,itori,itori1)
7433 pom=vl2ij*cosphi+vl3ij*sinphi
7434 pom1=1.0d0/(pom*pom+1.0d0)
7435 etors=etors+vl1ij*pom1
7436 if (energy_dec) etors_ii=etors_ii+
7439 gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7441 C Subtract the constant term
7442 etors=etors-v0(itori,itori1,iblock)
7443 if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7444 & 'etor',i,etors_ii-v0(itori,itori1,iblock)
7446 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7447 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7448 & (v1(j,itori,itori1,iblock),j=1,6),
7449 & (v2(j,itori,itori1,iblock),j=1,6)
7450 gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7451 c write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7455 c----------------------------------------------------------------------------
7456 subroutine etor_d(etors_d)
7457 C 6/23/01 Compute double torsional energy
7458 implicit real*8 (a-h,o-z)
7459 include 'DIMENSIONS'
7460 include 'COMMON.VAR'
7461 include 'COMMON.GEO'
7462 include 'COMMON.LOCAL'
7463 include 'COMMON.TORSION'
7464 include 'COMMON.INTERACT'
7465 include 'COMMON.DERIV'
7466 include 'COMMON.CHAIN'
7467 include 'COMMON.NAMES'
7468 include 'COMMON.IOUNITS'
7469 include 'COMMON.FFIELD'
7470 include 'COMMON.TORCNSTR'
7472 C Set lprn=.true. for debugging
7476 c write(iout,*) "a tu??"
7477 do i=iphid_start,iphid_end
7478 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7479 C if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7480 C & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7481 C & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1)) .or.
7482 C & ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7483 if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7484 & (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7485 & (itype(i+1).eq.ntyp1)) cycle
7486 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7487 itori=itortyp(itype(i-2))
7488 itori1=itortyp(itype(i-1))
7489 itori2=itortyp(itype(i))
7495 if (iabs(itype(i+1)).eq.20) iblock=2
7496 C Iblock=2 Proline type
7497 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7498 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7499 C if (itype(i+1).eq.ntyp1) iblock=3
7500 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7501 C IS or IS NOT need for this
7502 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7503 C is (itype(i-3).eq.ntyp1) ntblock=2
7504 C ntblock is N-terminal blocking group
7506 C Regular cosine and sine terms
7507 do j=1,ntermd_1(itori,itori1,itori2,iblock)
7508 C Example of changes for NH3+ blocking group
7509 C do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7510 C v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7511 v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7512 v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7513 v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7514 v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7515 cosphi1=dcos(j*phii)
7516 sinphi1=dsin(j*phii)
7517 cosphi2=dcos(j*phii1)
7518 sinphi2=dsin(j*phii1)
7519 etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7520 & v2cij*cosphi2+v2sij*sinphi2
7521 gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7522 gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7524 do k=2,ntermd_2(itori,itori1,itori2,iblock)
7526 v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7527 v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7528 v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7529 v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7530 cosphi1p2=dcos(l*phii+(k-l)*phii1)
7531 cosphi1m2=dcos(l*phii-(k-l)*phii1)
7532 sinphi1p2=dsin(l*phii+(k-l)*phii1)
7533 sinphi1m2=dsin(l*phii-(k-l)*phii1)
7534 etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7535 & v1sdij*sinphi1p2+v2sdij*sinphi1m2
7536 gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7537 & -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7538 gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7539 & -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7542 gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7543 gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7548 C----------------------------------------------------------------------------------
7549 C The rigorous attempt to derive energy function
7550 subroutine etor_kcc(etors)
7551 implicit real*8 (a-h,o-z)
7552 include 'DIMENSIONS'
7553 include 'COMMON.VAR'
7554 include 'COMMON.GEO'
7555 include 'COMMON.LOCAL'
7556 include 'COMMON.TORSION'
7557 include 'COMMON.INTERACT'
7558 include 'COMMON.DERIV'
7559 include 'COMMON.CHAIN'
7560 include 'COMMON.NAMES'
7561 include 'COMMON.IOUNITS'
7562 include 'COMMON.FFIELD'
7563 include 'COMMON.TORCNSTR'
7564 include 'COMMON.CONTROL'
7565 double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7567 c double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7568 C Set lprn=.true. for debugging
7571 C print *,"wchodze kcc"
7572 if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7574 do i=iphi_start,iphi_end
7575 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7576 c if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7577 c & ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)) .or.
7578 c & ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
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))
7587 C to avoid multiple devision by 2
7588 c theti22=0.5d0*theta(i)
7589 C theta 12 is the theta_1 /2
7590 C theta 22 is theta_2 /2
7591 c theti12=0.5d0*theta(i-1)
7592 C and appropriate sinus function
7593 sinthet1=dsin(theta(i-1))
7594 sinthet2=dsin(theta(i))
7595 costhet1=dcos(theta(i-1))
7596 costhet2=dcos(theta(i))
7597 C to speed up lets store its mutliplication
7598 sint1t2=sinthet2*sinthet1
7600 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7601 C +d_n*sin(n*gamma)) *
7602 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7603 C we have two sum 1) Non-Chebyshev which is with n and gamma
7604 nval=nterm_kcc_Tb(itori,itori1)
7610 c1(j)=c1(j-1)*costhet1
7611 c2(j)=c2(j-1)*costhet2
7614 do j=1,nterm_kcc(itori,itori1)
7618 sint1t2n=sint1t2n*sint1t2
7624 sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7625 gradvalct1=gradvalct1+
7626 & (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7627 gradvalct2=gradvalct2+
7628 & (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7631 gradvalct1=-gradvalct1*sinthet1
7632 gradvalct2=-gradvalct2*sinthet2
7638 sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7639 gradvalst1=gradvalst1+
7640 & (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7641 gradvalst2=gradvalst2+
7642 & (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7645 gradvalst1=-gradvalst1*sinthet1
7646 gradvalst2=-gradvalst2*sinthet2
7647 if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7648 etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7649 C glocig is the gradient local i site in gamma
7650 glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7651 C now gradient over theta_1
7652 glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7653 & +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7654 glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7655 & +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7658 C derivative over gamma
7659 gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7660 C derivative over theta1
7661 gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7662 C now derivative over theta2
7663 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7665 write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7666 & theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7667 write (iout,*) "c1",(c1(k),k=0,nval),
7668 & " c2",(c2(k),k=0,nval)
7673 c---------------------------------------------------------------------------------------------
7674 subroutine etor_constr(edihcnstr)
7675 implicit real*8 (a-h,o-z)
7676 include 'DIMENSIONS'
7677 include 'COMMON.VAR'
7678 include 'COMMON.GEO'
7679 include 'COMMON.LOCAL'
7680 include 'COMMON.TORSION'
7681 include 'COMMON.INTERACT'
7682 include 'COMMON.DERIV'
7683 include 'COMMON.CHAIN'
7684 include 'COMMON.NAMES'
7685 include 'COMMON.IOUNITS'
7686 include 'COMMON.FFIELD'
7687 include 'COMMON.TORCNSTR'
7688 include 'COMMON.BOUNDS'
7689 include 'COMMON.CONTROL'
7690 ! 6/20/98 - dihedral angle constraints
7692 c do i=1,ndih_constr
7693 if (raw_psipred) then
7694 do i=idihconstr_start,idihconstr_end
7695 itori=idih_constr(i)
7697 gaudih_i=vpsipred(1,i)
7701 cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7702 dexpcos_i=dexp(-cos_i*cos_i)
7703 gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7704 gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7705 & *cos_i*dexpcos_i/s**2
7707 edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7708 gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7710 & write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7711 & i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7712 & phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7713 & phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7714 & -wdihc*dlog(gaudih_i)
7718 do i=idihconstr_start,idihconstr_end
7719 itori=idih_constr(i)
7721 difi=pinorm(phii-phi0(i))
7722 if (difi.gt.drange(i)) then
7724 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7725 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7726 else if (difi.lt.-drange(i)) then
7728 edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7729 gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7739 c----------------------------------------------------------------------------
7740 c MODELLER restraint function
7741 subroutine e_modeller(ehomology_constr)
7743 include 'DIMENSIONS'
7745 double precision ehomology_constr
7746 integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7747 integer katy, odleglosci, test7
7748 real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
7750 real*8 distance(max_template),distancek(max_template),
7751 & min_odl,godl(max_template),dih_diff(max_template)
7754 c FP - 30/10/2014 Temporary specifications for homology restraints
7756 double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
7758 double precision, dimension (maxres) :: guscdiff,usc_diff
7759 double precision, dimension (max_template) ::
7760 & gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
7762 double precision sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,
7763 & sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,
7764 & betai,sum_sgodl,dij
7765 double precision dist,pinorm
7767 include 'COMMON.SBRIDGE'
7768 include 'COMMON.CHAIN'
7769 include 'COMMON.GEO'
7770 include 'COMMON.DERIV'
7771 include 'COMMON.LOCAL'
7772 include 'COMMON.INTERACT'
7773 include 'COMMON.VAR'
7774 include 'COMMON.IOUNITS'
7775 c include 'COMMON.MD'
7776 include 'COMMON.CONTROL'
7777 include 'COMMON.HOMOLOGY'
7778 include 'COMMON.QRESTR'
7780 c From subroutine Econstr_back
7782 include 'COMMON.NAMES'
7783 include 'COMMON.TIME1'
7788 distancek(i)=9999999.9
7794 c Pseudo-energy and gradient from homology restraints (MODELLER-like
7796 C AL 5/2/14 - Introduce list of restraints
7797 c write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7799 write(iout,*) "------- dist restrs start -------"
7801 do ii = link_start_homo,link_end_homo
7805 c write (iout,*) "dij(",i,j,") =",dij
7807 do k=1,constr_homology
7808 c write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7809 if(.not.l_homo(k,ii)) then
7813 distance(k)=odl(k,ii)-dij
7814 c write (iout,*) "distance(",k,") =",distance(k)
7816 c For Gaussian-type Urestr
7818 distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7819 c write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7820 c write (iout,*) "distancek(",k,") =",distancek(k)
7821 c distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7823 c For Lorentzian-type Urestr
7825 if (waga_dist.lt.0.0d0) then
7826 sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7827 distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
7828 & (distance(k)**2+sigma_odlir(k,ii)**2))
7832 c min_odl=minval(distancek)
7836 do kk=1,constr_homology
7837 if(l_homo(kk,ii)) then
7838 min_odl=distancek(kk)
7842 do kk=1,constr_homology
7843 if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
7844 & min_odl=distancek(kk)
7848 c write (iout,* )"min_odl",min_odl
7850 write (iout,*) "ij dij",i,j,dij
7851 write (iout,*) "distance",(distance(k),k=1,constr_homology)
7852 write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7853 write (iout,* )"min_odl",min_odl
7858 if (waga_dist.ge.0.0d0) then
7864 do k=1,constr_homology
7865 c Nie wiem po co to liczycie jeszcze raz!
7866 c odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7867 c & (2*(sigma_odl(i,j,k))**2))
7868 if(.not.l_homo(k,ii)) cycle
7869 if (waga_dist.ge.0.0d0) then
7871 c For Gaussian-type Urestr
7873 godl(k)=dexp(-distancek(k)+min_odl)
7874 odleg2=odleg2+godl(k)
7876 c For Lorentzian-type Urestr
7879 odleg2=odleg2+distancek(k)
7882 ccc write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7883 ccc & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7884 ccc & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7885 ccc & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7888 c write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7889 c write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7891 write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7892 write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7894 if (waga_dist.ge.0.0d0) then
7896 c For Gaussian-type Urestr
7898 odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7900 c For Lorentzian-type Urestr
7903 odleg=odleg+odleg2/constr_homology
7906 c write (iout,*) "odleg",odleg ! sum of -ln-s
7909 c For Gaussian-type Urestr
7911 if (waga_dist.ge.0.0d0) sum_godl=odleg2
7913 do k=1,constr_homology
7914 c godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7915 c & *waga_dist)+min_odl
7916 c sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7918 if(.not.l_homo(k,ii)) cycle
7919 if (waga_dist.ge.0.0d0) then
7920 c For Gaussian-type Urestr
7922 sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7924 c For Lorentzian-type Urestr
7927 sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
7928 & sigma_odlir(k,ii)**2)**2)
7930 sum_sgodl=sum_sgodl+sgodl
7932 c sgodl2=sgodl2+sgodl
7933 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7934 c write(iout,*) "constr_homology=",constr_homology
7935 c write(iout,*) i, j, k, "TEST K"
7937 if (waga_dist.ge.0.0d0) then
7939 c For Gaussian-type Urestr
7941 grad_odl3=waga_homology(iset)*waga_dist
7942 & *sum_sgodl/(sum_godl*dij)
7944 c For Lorentzian-type Urestr
7947 c Original grad expr modified by analogy w Gaussian-type Urestr grad
7948 c grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7949 grad_odl3=-waga_homology(iset)*waga_dist*
7950 & sum_sgodl/(constr_homology*dij)
7953 c grad_odl3=sum_sgodl/(sum_godl*dij)
7956 c write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7957 c write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7958 c & (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7960 ccc write(iout,*) godl, sgodl, grad_odl3
7962 c grad_odl=grad_odl+grad_odl3
7965 ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7966 ccc write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7967 ccc write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7968 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
7969 ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7970 ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7971 ccc write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7972 ccc & ghpbc(jik,i+1), ghpbc(jik,j+1)
7973 c if (i.eq.25.and.j.eq.27) then
7974 c write(iout,*) "jik",jik,"i",i,"j",j
7975 c write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7976 c write(iout,*) "grad_odl3",grad_odl3
7977 c write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7978 c write(iout,*) "ggodl",ggodl
7979 c write(iout,*) "ghpbc(",jik,i,")",
7980 c & ghpbc(jik,i),"ghpbc(",jik,j,")",
7984 ccc write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7985 ccc & dLOG(odleg2),"-odleg=", -odleg
7987 enddo ! ii-loop for dist
7989 write(iout,*) "------- dist restrs end -------"
7990 c if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7991 c & waga_d.eq.1.0d0) call sum_gradient
7993 c Pseudo-energy and gradient from dihedral-angle restraints from
7994 c homology templates
7995 c write (iout,*) "End of distance loop"
7998 c write (iout,*) idihconstr_start_homo,idihconstr_end_homo
8000 write(iout,*) "------- dih restrs start -------"
8001 do i=idihconstr_start_homo,idihconstr_end_homo
8002 write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
8005 do i=idihconstr_start_homo,idihconstr_end_homo
8007 c betai=beta(i,i+1,i+2,i+3)
8009 c write (iout,*) "betai =",betai
8010 do k=1,constr_homology
8011 dih_diff(k)=pinorm(dih(k,i)-betai)
8012 cd write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
8013 cd & ,sigma_dih(k,i)
8014 c if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
8015 c & -(6.28318-dih_diff(i,k))
8016 c if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
8017 c & 6.28318+dih_diff(i,k)
8019 kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8021 kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
8023 c kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
8026 c write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
8029 c write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
8030 c write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
8032 write (iout,*) "i",i," betai",betai," kat2",kat2
8033 write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
8035 if (kat2.le.1.0d-14) cycle
8036 kat=kat-dLOG(kat2/constr_homology)
8037 c write (iout,*) "kat",kat ! sum of -ln-s
8039 ccc write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
8040 ccc & dLOG(kat2), "-kat=", -kat
8042 c ----------------------------------------------------------------------
8044 c ----------------------------------------------------------------------
8048 do k=1,constr_homology
8050 sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i) ! waga_angle rmvd
8052 sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i) ! waga_angle rmvd
8054 c sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
8055 sum_sgdih=sum_sgdih+sgdih
8057 c grad_dih3=sum_sgdih/sum_gdih
8058 grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
8060 c write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
8061 ccc write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
8062 ccc & gloc(nphi+i-3,icg)
8063 gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
8065 c write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
8067 ccc write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
8068 ccc & gloc(nphi+i-3,icg)
8070 enddo ! i-loop for dih
8072 write(iout,*) "------- dih restrs end -------"
8075 c Pseudo-energy and gradient for theta angle restraints from
8076 c homology templates
8077 c FP 01/15 - inserted from econstr_local_test.F, loop structure
8081 c For constr_homology reference structures (FP)
8083 c Uconst_back_tot=0.0d0
8086 c Econstr_back legacy
8088 c do i=ithet_start,ithet_end
8091 c do i=loc_start,loc_end
8094 duscdiffx(j,i)=0.0d0
8099 c write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
8100 c write (iout,*) "waga_theta",waga_theta
8101 if (waga_theta.gt.0.0d0) then
8103 write (iout,*) "usampl",usampl
8104 write(iout,*) "------- theta restrs start -------"
8105 c do i=ithet_start,ithet_end
8106 c write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
8109 c write (iout,*) "maxres",maxres,"nres",nres
8111 do i=ithet_start,ithet_end
8114 c ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
8116 c Deviation of theta angles wrt constr_homology ref structures
8118 utheta_i=0.0d0 ! argument of Gaussian for single k
8119 gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8120 c do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
8121 c over residues in a fragment
8122 c write (iout,*) "theta(",i,")=",theta(i)
8123 do k=1,constr_homology
8125 c dtheta_i=theta(j)-thetaref(j,iref)
8126 c dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
8127 theta_diff(k)=thetatpl(k,i)-theta(i)
8128 cd write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
8129 cd & ,sigma_theta(k,i)
8132 utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
8133 c utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
8134 gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
8135 gutheta_i=gutheta_i+gtheta(k) ! Sum of Gaussians (pk)
8136 c Gradient for single Gaussian restraint in subr Econstr_back
8137 c dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
8140 c write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
8141 c write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
8144 c Gradient for multiple Gaussian restraint
8145 sum_gtheta=gutheta_i
8147 do k=1,constr_homology
8148 c New generalized expr for multiple Gaussian from Econstr_back
8149 sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8151 c sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8152 sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8154 c Final value of gradient using same var as in Econstr_back
8155 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
8156 & +sum_sgtheta/sum_gtheta*waga_theta
8157 & *waga_homology(iset)
8158 c dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8159 c & *waga_homology(iset)
8160 c dutheta(i)=sum_sgtheta/sum_gtheta
8162 c Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8163 Eval=Eval-dLOG(gutheta_i/constr_homology)
8164 c write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8165 c write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8166 c Uconst_back=Uconst_back+utheta(i)
8167 enddo ! (i-loop for theta)
8169 write(iout,*) "------- theta restrs end -------"
8173 c Deviation of local SC geometry
8175 c Separation of two i-loops (instructed by AL - 11/3/2014)
8177 c write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8178 c write (iout,*) "waga_d",waga_d
8181 write(iout,*) "------- SC restrs start -------"
8182 write (iout,*) "Initial duscdiff,duscdiffx"
8183 do i=loc_start,loc_end
8184 write (iout,*) i,(duscdiff(jik,i),jik=1,3),
8185 & (duscdiffx(jik,i),jik=1,3)
8188 do i=loc_start,loc_end
8189 usc_diff_i=0.0d0 ! argument of Gaussian for single k
8190 guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8191 c do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8192 c write(iout,*) "xxtab, yytab, zztab"
8193 c write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8194 do k=1,constr_homology
8196 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8197 c Original sign inverted for calc of gradients (s. Econstr_back)
8198 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8199 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8200 c write(iout,*) "dxx, dyy, dzz"
8201 cd write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8203 usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d rmvd from Gaussian argument
8204 c usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8205 c uscdiffk(k)=usc_diff(i)
8206 guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8207 c write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8208 c & " guscdiff2",guscdiff2(k)
8209 guscdiff(i)=guscdiff(i)+guscdiff2(k) !Sum of Gaussians (pk)
8210 c write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8211 c & xxref(j),yyref(j),zzref(j)
8216 c Generalized expression for multiple Gaussian acc to that for a single
8217 c Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8219 c Original implementation
8220 c sum_guscdiff=guscdiff(i)
8222 c sum_sguscdiff=0.0d0
8223 c do k=1,constr_homology
8224 c sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8225 c sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8226 c sum_sguscdiff=sum_sguscdiff+sguscdiff
8229 c Implementation of new expressions for gradient (Jan. 2015)
8231 c grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8232 do k=1,constr_homology
8234 c New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8235 c before. Now the drivatives should be correct
8237 dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8238 c Original sign inverted for calc of gradients (s. Econstr_back)
8239 dyy=-yytpl(k,i)+yytab(i) ! ibid y
8240 dzz=-zztpl(k,i)+zztab(i) ! ibid z
8242 c New implementation
8244 sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8245 & sigma_d(k,i) ! for the grad wrt r'
8246 c sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8249 c New implementation
8250 sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8252 duscdiff(jik,i-1)=duscdiff(jik,i-1)+
8253 & sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
8254 & dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8255 duscdiff(jik,i)=duscdiff(jik,i)+
8256 & sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
8257 & dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8258 duscdiffx(jik,i)=duscdiffx(jik,i)+
8259 & sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
8260 & dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8263 write(iout,*) "jik",jik,"i",i
8264 write(iout,*) "dxx, dyy, dzz"
8265 write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8266 write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8267 c write(iout,*) "sum_sguscdiff",sum_sguscdiff
8268 cc write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8269 c write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8270 c write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8271 c write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8272 c write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8273 c write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8274 c write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8275 c write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8276 c write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8277 c write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8278 c write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8279 c write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8285 c uscdiff(i)=-dLOG(guscdiff(i)/(ii-1)) ! Weighting by (ii-1) required?
8286 c usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8288 c write (iout,*) i," uscdiff",uscdiff(i)
8290 c Put together deviations from local geometry
8292 c Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8293 c & wfrag_back(3,i,iset)*uscdiff(i)
8294 Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8295 c write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8296 c write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8297 c Uconst_back=Uconst_back+usc_diff(i)
8299 c Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8301 c New implment: multiplied by sum_sguscdiff
8304 enddo ! (i-loop for dscdiff)
8309 write(iout,*) "------- SC restrs end -------"
8310 write (iout,*) "------ After SC loop in e_modeller ------"
8311 do i=loc_start,loc_end
8312 write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8313 write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8315 if (waga_theta.eq.1.0d0) then
8316 write (iout,*) "in e_modeller after SC restr end: dutheta"
8317 do i=ithet_start,ithet_end
8318 write (iout,*) i,dutheta(i)
8321 if (waga_d.eq.1.0d0) then
8322 write (iout,*) "e_modeller after SC loop: duscdiff/x"
8324 write (iout,*) i,(duscdiff(j,i),j=1,3)
8325 write (iout,*) i,(duscdiffx(j,i),j=1,3)
8330 c Total energy from homology restraints
8332 write (iout,*) "odleg",odleg," kat",kat
8335 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8337 c ehomology_constr=odleg+kat
8339 c For Lorentzian-type Urestr
8342 if (waga_dist.ge.0.0d0) then
8344 c For Gaussian-type Urestr
8346 ehomology_constr=(waga_dist*odleg+waga_angle*kat+
8347 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8348 c write (iout,*) "ehomology_constr=",ehomology_constr
8351 c For Lorentzian-type Urestr
8353 ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
8354 & waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8355 c write (iout,*) "ehomology_constr=",ehomology_constr
8358 write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
8359 & "Eval",waga_theta,eval,
8360 & "Erot",waga_d,Erot
8361 write (iout,*) "ehomology_constr",ehomology_constr
8367 748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8368 747 format(a12,i4,i4,i4,f8.3,f8.3)
8369 746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8370 778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8371 779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
8372 & f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8374 c----------------------------------------------------------------------------
8375 C The rigorous attempt to derive energy function
8376 subroutine ebend_kcc(etheta)
8378 implicit real*8 (a-h,o-z)
8379 include 'DIMENSIONS'
8380 include 'COMMON.VAR'
8381 include 'COMMON.GEO'
8382 include 'COMMON.LOCAL'
8383 include 'COMMON.TORSION'
8384 include 'COMMON.INTERACT'
8385 include 'COMMON.DERIV'
8386 include 'COMMON.CHAIN'
8387 include 'COMMON.NAMES'
8388 include 'COMMON.IOUNITS'
8389 include 'COMMON.FFIELD'
8390 include 'COMMON.TORCNSTR'
8391 include 'COMMON.CONTROL'
8393 double precision thybt1(maxang_kcc)
8394 C Set lprn=.true. for debugging
8397 C print *,"wchodze kcc"
8398 if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8400 do i=ithet_start,ithet_end
8401 c print *,i,itype(i-1),itype(i),itype(i-2)
8402 if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
8403 & .or.itype(i).eq.ntyp1) cycle
8404 iti=iabs(itortyp(itype(i-1)))
8405 sinthet=dsin(theta(i))
8406 costhet=dcos(theta(i))
8407 do j=1,nbend_kcc_Tb(iti)
8408 thybt1(j)=v1bend_chyb(j,iti)
8410 sumth1thyb=v1bend_chyb(0,iti)+
8411 & tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8412 if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
8414 ihelp=nbend_kcc_Tb(iti)-1
8415 gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8416 etheta=etheta+sumth1thyb
8417 C print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8418 gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8422 c-------------------------------------------------------------------------------------
8423 subroutine etheta_constr(ethetacnstr)
8425 implicit real*8 (a-h,o-z)
8426 include 'DIMENSIONS'
8427 include 'COMMON.VAR'
8428 include 'COMMON.GEO'
8429 include 'COMMON.LOCAL'
8430 include 'COMMON.TORSION'
8431 include 'COMMON.INTERACT'
8432 include 'COMMON.DERIV'
8433 include 'COMMON.CHAIN'
8434 include 'COMMON.NAMES'
8435 include 'COMMON.IOUNITS'
8436 include 'COMMON.FFIELD'
8437 include 'COMMON.TORCNSTR'
8438 include 'COMMON.CONTROL'
8440 C print *,ithetaconstr_start,ithetaconstr_end,"TU"
8441 do i=ithetaconstr_start,ithetaconstr_end
8442 itheta=itheta_constr(i)
8443 thetiii=theta(itheta)
8444 difi=pinorm(thetiii-theta_constr0(i))
8445 if (difi.gt.theta_drange(i)) then
8446 difi=difi-theta_drange(i)
8447 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8448 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8449 & +for_thet_constr(i)*difi**3
8450 else if (difi.lt.-drange(i)) then
8452 ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8453 gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
8454 & +for_thet_constr(i)*difi**3
8458 if (energy_dec) then
8459 write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
8460 & i,itheta,rad2deg*thetiii,
8461 & rad2deg*theta_constr0(i), rad2deg*theta_drange(i),
8462 & rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
8463 & gloc(itheta+nphi-2,icg)
8468 c------------------------------------------------------------------------------
8469 subroutine eback_sc_corr(esccor)
8470 c 7/21/2007 Correlations between the backbone-local and side-chain-local
8471 c conformational states; temporarily implemented as differences
8472 c between UNRES torsional potentials (dependent on three types of
8473 c residues) and the torsional potentials dependent on all 20 types
8474 c of residues computed from AM1 energy surfaces of terminally-blocked
8475 c amino-acid residues.
8476 implicit real*8 (a-h,o-z)
8477 include 'DIMENSIONS'
8478 include 'COMMON.VAR'
8479 include 'COMMON.GEO'
8480 include 'COMMON.LOCAL'
8481 include 'COMMON.TORSION'
8482 include 'COMMON.SCCOR'
8483 include 'COMMON.INTERACT'
8484 include 'COMMON.DERIV'
8485 include 'COMMON.CHAIN'
8486 include 'COMMON.NAMES'
8487 include 'COMMON.IOUNITS'
8488 include 'COMMON.FFIELD'
8489 include 'COMMON.CONTROL'
8491 C Set lprn=.true. for debugging
8494 c write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8496 do i=itau_start,itau_end
8497 if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
8499 isccori=isccortyp(itype(i-2))
8500 isccori1=isccortyp(itype(i-1))
8501 c write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8503 do intertyp=1,3 !intertyp
8504 cc Added 09 May 2012 (Adasko)
8505 cc Intertyp means interaction type of backbone mainchain correlation:
8506 c 1 = SC...Ca...Ca...Ca
8507 c 2 = Ca...Ca...Ca...SC
8508 c 3 = SC...Ca...Ca...SCi
8510 if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
8511 & (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
8512 & (itype(i-1).eq.ntyp1)))
8513 & .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
8514 & .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
8515 & .or.(itype(i).eq.ntyp1)))
8516 & .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
8517 & (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
8518 & (itype(i-3).eq.ntyp1)))) cycle
8519 if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
8520 if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
8522 do j=1,nterm_sccor(isccori,isccori1)
8523 v1ij=v1sccor(j,intertyp,isccori,isccori1)
8524 v2ij=v2sccor(j,intertyp,isccori,isccori1)
8525 cosphi=dcos(j*tauangle(intertyp,i))
8526 sinphi=dsin(j*tauangle(intertyp,i))
8527 esccor=esccor+v1ij*cosphi+v2ij*sinphi
8528 gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8530 c write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8531 gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8533 & write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
8534 & restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
8535 & (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
8536 & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8537 gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8544 c----------------------------------------------------------------------------
8545 subroutine multibody(ecorr)
8546 C This subroutine calculates multi-body contributions to energy following
8547 C the idea of Skolnick et al. If side chains I and J make a contact and
8548 C at the same time side chains I+1 and J+1 make a contact, an extra
8549 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8550 implicit real*8 (a-h,o-z)
8551 include 'DIMENSIONS'
8552 include 'COMMON.IOUNITS'
8553 include 'COMMON.DERIV'
8554 include 'COMMON.INTERACT'
8555 include 'COMMON.CONTACTS'
8556 include 'COMMON.CONTMAT'
8557 include 'COMMON.CORRMAT'
8558 double precision gx(3),gx1(3)
8561 C Set lprn=.true. for debugging
8565 write (iout,'(a)') 'Contact function values:'
8567 write (iout,'(i2,20(1x,i2,f10.5))')
8568 & i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8583 num_conti=num_cont(i)
8584 num_conti1=num_cont(i1)
8589 if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8590 cd write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8591 cd & ' ishift=',ishift
8592 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8593 C The system gains extra energy.
8594 ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8595 endif ! j1==j+-ishift
8604 c------------------------------------------------------------------------------
8605 double precision function esccorr(i,j,k,l,jj,kk)
8606 implicit real*8 (a-h,o-z)
8607 include 'DIMENSIONS'
8608 include 'COMMON.IOUNITS'
8609 include 'COMMON.DERIV'
8610 include 'COMMON.INTERACT'
8611 include 'COMMON.CONTACTS'
8612 include 'COMMON.CONTMAT'
8613 include 'COMMON.CORRMAT'
8614 include 'COMMON.SHIELD'
8615 double precision gx(3),gx1(3)
8620 cd write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8621 C Calculate the multi-body contribution to energy.
8622 C Calculate multi-body contributions to the gradient.
8623 cd write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8624 cd & k,l,(gacont(m,kk,k),m=1,3)
8626 gx(m) =ekl*gacont(m,jj,i)
8627 gx1(m)=eij*gacont(m,kk,k)
8628 gradxorr(m,i)=gradxorr(m,i)-gx(m)
8629 gradxorr(m,j)=gradxorr(m,j)+gx(m)
8630 gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8631 gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8635 gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8640 gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8646 c------------------------------------------------------------------------------
8647 subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8648 C This subroutine calculates multi-body contributions to hydrogen-bonding
8649 implicit real*8 (a-h,o-z)
8650 include 'DIMENSIONS'
8651 include 'COMMON.IOUNITS'
8654 parameter (max_cont=maxconts)
8655 parameter (max_dim=26)
8656 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8657 double precision zapas(max_dim,maxconts,max_fg_procs),
8658 & zapas_recv(max_dim,maxconts,max_fg_procs)
8659 common /przechowalnia/ zapas
8660 integer status(MPI_STATUS_SIZE),req(maxconts*2),
8661 & status_array(MPI_STATUS_SIZE,maxconts*2)
8663 include 'COMMON.SETUP'
8664 include 'COMMON.FFIELD'
8665 include 'COMMON.DERIV'
8666 include 'COMMON.INTERACT'
8667 include 'COMMON.CONTACTS'
8668 include 'COMMON.CONTMAT'
8669 include 'COMMON.CORRMAT'
8670 include 'COMMON.CONTROL'
8671 include 'COMMON.LOCAL'
8672 double precision gx(3),gx1(3),time00
8675 C Set lprn=.true. for debugging
8680 if (nfgtasks.le.1) goto 30
8682 write (iout,'(a)') 'Contact function values before RECEIVE:'
8684 write (iout,'(2i3,50(1x,i2,f5.2))')
8685 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8686 & j=1,num_cont_hb(i))
8690 do i=1,ntask_cont_from
8693 do i=1,ntask_cont_to
8696 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8698 C Make the list of contacts to send to send to other procesors
8699 c write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8701 do i=iturn3_start,iturn3_end
8702 c write (iout,*) "make contact list turn3",i," num_cont",
8704 call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8706 do i=iturn4_start,iturn4_end
8707 c write (iout,*) "make contact list turn4",i," num_cont",
8709 call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8713 c write (iout,*) "make contact list longrange",i,ii," num_cont",
8715 do j=1,num_cont_hb(i)
8718 iproc=iint_sent_local(k,jjc,ii)
8719 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8720 if (iproc.gt.0) then
8721 ncont_sent(iproc)=ncont_sent(iproc)+1
8722 nn=ncont_sent(iproc)
8724 zapas(2,nn,iproc)=jjc
8725 zapas(3,nn,iproc)=facont_hb(j,i)
8726 zapas(4,nn,iproc)=ees0p(j,i)
8727 zapas(5,nn,iproc)=ees0m(j,i)
8728 zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8729 zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8730 zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8731 zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8732 zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8733 zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8734 zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8735 zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8736 zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8737 zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8738 zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8739 zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8740 zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8741 zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8742 zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8743 zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8744 zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8745 zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8746 zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8747 zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8748 zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8755 & "Numbers of contacts to be sent to other processors",
8756 & (ncont_sent(i),i=1,ntask_cont_to)
8757 write (iout,*) "Contacts sent"
8758 do ii=1,ntask_cont_to
8760 iproc=itask_cont_to(ii)
8761 write (iout,*) nn," contacts to processor",iproc,
8762 & " of CONT_TO_COMM group"
8764 write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8772 CorrelID1=nfgtasks+fg_rank+1
8774 C Receive the numbers of needed contacts from other processors
8775 do ii=1,ntask_cont_from
8776 iproc=itask_cont_from(ii)
8778 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8779 & FG_COMM,req(ireq),IERR)
8781 c write (iout,*) "IRECV ended"
8783 C Send the number of contacts needed by other processors
8784 do ii=1,ntask_cont_to
8785 iproc=itask_cont_to(ii)
8787 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8788 & FG_COMM,req(ireq),IERR)
8790 c write (iout,*) "ISEND ended"
8791 c write (iout,*) "number of requests (nn)",ireq
8794 & call MPI_Waitall(ireq,req,status_array,ierr)
8796 c & "Numbers of contacts to be received from other processors",
8797 c & (ncont_recv(i),i=1,ntask_cont_from)
8801 do ii=1,ntask_cont_from
8802 iproc=itask_cont_from(ii)
8804 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
8805 c & " of CONT_TO_COMM group"
8809 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8810 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8811 c write (iout,*) "ireq,req",ireq,req(ireq)
8814 C Send the contacts to processors that need them
8815 do ii=1,ntask_cont_to
8816 iproc=itask_cont_to(ii)
8818 c write (iout,*) nn," contacts to processor",iproc,
8819 c & " of CONT_TO_COMM group"
8822 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8823 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8824 c write (iout,*) "ireq,req",ireq,req(ireq)
8826 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8830 c write (iout,*) "number of requests (contacts)",ireq
8831 c write (iout,*) "req",(req(i),i=1,4)
8834 & call MPI_Waitall(ireq,req,status_array,ierr)
8835 do iii=1,ntask_cont_from
8836 iproc=itask_cont_from(iii)
8839 write (iout,*) "Received",nn," contacts from processor",iproc,
8840 & " of CONT_FROM_COMM group"
8843 write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8848 ii=zapas_recv(1,i,iii)
8849 c Flag the received contacts to prevent double-counting
8850 jj=-zapas_recv(2,i,iii)
8851 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8853 nnn=num_cont_hb(ii)+1
8856 facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8857 ees0p(nnn,ii)=zapas_recv(4,i,iii)
8858 ees0m(nnn,ii)=zapas_recv(5,i,iii)
8859 gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8860 gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8861 gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8862 gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8863 gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8864 gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8865 gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8866 gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8867 gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8868 gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8869 gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8870 gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8871 gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8872 gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8873 gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8874 gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8875 gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8876 gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8877 gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8878 gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8879 gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8883 write (iout,'(a)') 'Contact function values after receive:'
8885 write (iout,'(2i3,50(1x,i3,f5.2))')
8886 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8887 & j=1,num_cont_hb(i))
8894 write (iout,'(a)') 'Contact function values:'
8896 write (iout,'(2i3,50(1x,i3,f5.2))')
8897 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8898 & j=1,num_cont_hb(i))
8903 C Remove the loop below after debugging !!!
8910 C Calculate the local-electrostatic correlation terms
8911 do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8913 num_conti=num_cont_hb(i)
8914 num_conti1=num_cont_hb(i+1)
8921 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8922 c & ' jj=',jj,' kk=',kk
8924 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8925 & .or. j.lt.0 .and. j1.gt.0) .and.
8926 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8927 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8928 C The system gains extra energy.
8929 ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8930 if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8931 & 'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8933 else if (j1.eq.j) then
8934 C Contacts I-J and I-(J+1) occur simultaneously.
8935 C The system loses extra energy.
8936 c ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8941 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8942 c & ' jj=',jj,' kk=',kk
8944 C Contacts I-J and (I+1)-J occur simultaneously.
8945 C The system loses extra energy.
8946 c ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8953 c------------------------------------------------------------------------------
8954 subroutine add_hb_contact(ii,jj,itask)
8955 implicit real*8 (a-h,o-z)
8956 include "DIMENSIONS"
8957 include "COMMON.IOUNITS"
8960 parameter (max_cont=maxconts)
8961 parameter (max_dim=26)
8962 include "COMMON.CONTACTS"
8963 include 'COMMON.CONTMAT'
8964 include 'COMMON.CORRMAT'
8965 double precision zapas(max_dim,maxconts,max_fg_procs),
8966 & zapas_recv(max_dim,maxconts,max_fg_procs)
8967 common /przechowalnia/ zapas
8968 integer i,j,ii,jj,iproc,itask(4),nn
8969 c write (iout,*) "itask",itask
8972 if (iproc.gt.0) then
8973 do j=1,num_cont_hb(ii)
8975 c write (iout,*) "i",ii," j",jj," jjc",jjc
8977 ncont_sent(iproc)=ncont_sent(iproc)+1
8978 nn=ncont_sent(iproc)
8979 zapas(1,nn,iproc)=ii
8980 zapas(2,nn,iproc)=jjc
8981 zapas(3,nn,iproc)=facont_hb(j,ii)
8982 zapas(4,nn,iproc)=ees0p(j,ii)
8983 zapas(5,nn,iproc)=ees0m(j,ii)
8984 zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8985 zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8986 zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8987 zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8988 zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8989 zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8990 zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8991 zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8992 zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8993 zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8994 zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8995 zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8996 zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8997 zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8998 zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8999 zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
9000 zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
9001 zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
9002 zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
9003 zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
9004 zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
9012 c------------------------------------------------------------------------------
9013 subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
9015 C This subroutine calculates multi-body contributions to hydrogen-bonding
9016 implicit real*8 (a-h,o-z)
9017 include 'DIMENSIONS'
9018 include 'COMMON.IOUNITS'
9021 parameter (max_cont=maxconts)
9022 parameter (max_dim=70)
9023 integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
9024 double precision zapas(max_dim,maxconts,max_fg_procs),
9025 & zapas_recv(max_dim,maxconts,max_fg_procs)
9026 common /przechowalnia/ zapas
9027 integer status(MPI_STATUS_SIZE),req(maxconts*2),
9028 & status_array(MPI_STATUS_SIZE,maxconts*2)
9030 include 'COMMON.SETUP'
9031 include 'COMMON.FFIELD'
9032 include 'COMMON.DERIV'
9033 include 'COMMON.LOCAL'
9034 include 'COMMON.INTERACT'
9035 include 'COMMON.CONTACTS'
9036 include 'COMMON.CONTMAT'
9037 include 'COMMON.CORRMAT'
9038 include 'COMMON.CHAIN'
9039 include 'COMMON.CONTROL'
9040 include 'COMMON.SHIELD'
9041 double precision gx(3),gx1(3)
9042 integer num_cont_hb_old(maxres)
9044 double precision eello4,eello5,eelo6,eello_turn6
9045 external eello4,eello5,eello6,eello_turn6
9046 C Set lprn=.true. for debugging
9051 num_cont_hb_old(i)=num_cont_hb(i)
9055 if (nfgtasks.le.1) goto 30
9057 write (iout,'(a)') 'Contact function values before RECEIVE:'
9059 write (iout,'(2i3,50(1x,i2,f5.2))')
9060 & i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
9061 & j=1,num_cont_hb(i))
9064 do i=1,ntask_cont_from
9067 do i=1,ntask_cont_to
9070 c write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
9072 C Make the list of contacts to send to send to other procesors
9073 do i=iturn3_start,iturn3_end
9074 c write (iout,*) "make contact list turn3",i," num_cont",
9076 call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
9078 do i=iturn4_start,iturn4_end
9079 c write (iout,*) "make contact list turn4",i," num_cont",
9081 call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
9085 c write (iout,*) "make contact list longrange",i,ii," num_cont",
9087 do j=1,num_cont_hb(i)
9090 iproc=iint_sent_local(k,jjc,ii)
9091 c write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
9092 if (iproc.ne.0) then
9093 ncont_sent(iproc)=ncont_sent(iproc)+1
9094 nn=ncont_sent(iproc)
9096 zapas(2,nn,iproc)=jjc
9097 zapas(3,nn,iproc)=d_cont(j,i)
9101 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
9106 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
9114 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
9125 & "Numbers of contacts to be sent to other processors",
9126 & (ncont_sent(i),i=1,ntask_cont_to)
9127 write (iout,*) "Contacts sent"
9128 do ii=1,ntask_cont_to
9130 iproc=itask_cont_to(ii)
9131 write (iout,*) nn," contacts to processor",iproc,
9132 & " of CONT_TO_COMM group"
9134 write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
9142 CorrelID1=nfgtasks+fg_rank+1
9144 C Receive the numbers of needed contacts from other processors
9145 do ii=1,ntask_cont_from
9146 iproc=itask_cont_from(ii)
9148 call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
9149 & FG_COMM,req(ireq),IERR)
9151 c write (iout,*) "IRECV ended"
9153 C Send the number of contacts needed by other processors
9154 do ii=1,ntask_cont_to
9155 iproc=itask_cont_to(ii)
9157 call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
9158 & FG_COMM,req(ireq),IERR)
9160 c write (iout,*) "ISEND ended"
9161 c write (iout,*) "number of requests (nn)",ireq
9164 & call MPI_Waitall(ireq,req,status_array,ierr)
9166 c & "Numbers of contacts to be received from other processors",
9167 c & (ncont_recv(i),i=1,ntask_cont_from)
9171 do ii=1,ntask_cont_from
9172 iproc=itask_cont_from(ii)
9174 c write (iout,*) "Receiving",nn," contacts from processor",iproc,
9175 c & " of CONT_TO_COMM group"
9179 call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
9180 & MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9181 c write (iout,*) "ireq,req",ireq,req(ireq)
9184 C Send the contacts to processors that need them
9185 do ii=1,ntask_cont_to
9186 iproc=itask_cont_to(ii)
9188 c write (iout,*) nn," contacts to processor",iproc,
9189 c & " of CONT_TO_COMM group"
9192 call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
9193 & iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9194 c write (iout,*) "ireq,req",ireq,req(ireq)
9196 c write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9200 c write (iout,*) "number of requests (contacts)",ireq
9201 c write (iout,*) "req",(req(i),i=1,4)
9204 & call MPI_Waitall(ireq,req,status_array,ierr)
9205 do iii=1,ntask_cont_from
9206 iproc=itask_cont_from(iii)
9209 write (iout,*) "Received",nn," contacts from processor",iproc,
9210 & " of CONT_FROM_COMM group"
9213 write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9218 ii=zapas_recv(1,i,iii)
9219 c Flag the received contacts to prevent double-counting
9220 jj=-zapas_recv(2,i,iii)
9221 c write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9223 nnn=num_cont_hb(ii)+1
9226 d_cont(nnn,ii)=zapas_recv(3,i,iii)
9230 grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9235 a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9243 a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9251 write (iout,'(a)') 'Contact function values after receive:'
9253 write (iout,'(2i3,50(1x,i3,5f6.3))')
9254 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9255 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9262 write (iout,'(a)') 'Contact function values:'
9264 write (iout,'(2i3,50(1x,i2,5f6.3))')
9265 & i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
9266 & ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9272 C Remove the loop below after debugging !!!
9279 C Calculate the dipole-dipole interaction energies
9280 if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9281 do i=iatel_s,iatel_e+1
9282 num_conti=num_cont_hb(i)
9291 C Calculate the local-electrostatic correlation terms
9292 c write (iout,*) "gradcorr5 in eello5 before loop"
9294 c write (iout,'(i5,3f10.5)')
9295 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9297 do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9298 c write (iout,*) "corr loop i",i
9300 num_conti=num_cont_hb(i)
9301 num_conti1=num_cont_hb(i+1)
9308 c write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9309 c & ' jj=',jj,' kk=',kk
9310 c if (j1.eq.j+1 .or. j1.eq.j-1) then
9311 if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
9312 & .or. j.lt.0 .and. j1.gt.0) .and.
9313 & (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9314 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9315 C The system gains extra energy.
9317 sqd1=dsqrt(d_cont(jj,i))
9318 sqd2=dsqrt(d_cont(kk,i1))
9319 sred_geom = sqd1*sqd2
9320 IF (sred_geom.lt.cutoff_corr) THEN
9321 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
9323 cd write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9324 cd & ' jj=',jj,' kk=',kk
9325 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9326 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9328 g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9329 g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9332 cd write (iout,*) 'sred_geom=',sred_geom,
9333 cd & ' ekont=',ekont,' fprim=',fprimcont,
9334 cd & ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9335 cd write (iout,*) "g_contij",g_contij
9336 cd write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9337 cd write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9338 call calc_eello(i,jp,i+1,jp1,jj,kk)
9339 if (wcorr4.gt.0.0d0)
9340 & ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9341 CC & *fac_shield(i)**2*fac_shield(j)**2
9342 if (energy_dec.and.wcorr4.gt.0.0d0)
9343 1 write (iout,'(a6,4i5,0pf7.3)')
9344 2 'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9345 c write (iout,*) "gradcorr5 before eello5"
9347 c write (iout,'(i5,3f10.5)')
9348 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9350 if (wcorr5.gt.0.0d0)
9351 & ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9352 c write (iout,*) "gradcorr5 after eello5"
9354 c write (iout,'(i5,3f10.5)')
9355 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9357 if (energy_dec.and.wcorr5.gt.0.0d0)
9358 1 write (iout,'(a6,4i5,0pf7.3)')
9359 2 'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9360 cd write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9361 cd write(2,*)'ijkl',i,jp,i+1,jp1
9362 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
9363 & .or. wturn6.eq.0.0d0))then
9364 cd write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9365 ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9366 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9367 1 'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9368 cd write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9369 cd & 'ecorr6=',ecorr6
9370 cd write (iout,'(4e15.5)') sred_geom,
9371 cd & dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9372 cd & dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9373 cd & dabs(eello6(i,jp,i+1,jp1,jj,kk))
9374 else if (wturn6.gt.0.0d0
9375 & .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9376 cd write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9377 eturn6=eturn6+eello_turn6(i,jj,kk)
9378 if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
9379 1 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9380 cd write (2,*) 'multibody_eello:eturn6',eturn6
9389 num_cont_hb(i)=num_cont_hb_old(i)
9391 c write (iout,*) "gradcorr5 in eello5"
9393 c write (iout,'(i5,3f10.5)')
9394 c & iii,(gradcorr5(jjj,iii),jjj=1,3)
9398 c------------------------------------------------------------------------------
9399 subroutine add_hb_contact_eello(ii,jj,itask)
9400 implicit real*8 (a-h,o-z)
9401 include "DIMENSIONS"
9402 include "COMMON.IOUNITS"
9405 parameter (max_cont=maxconts)
9406 parameter (max_dim=70)
9407 include "COMMON.CONTACTS"
9408 include 'COMMON.CONTMAT'
9409 include 'COMMON.CORRMAT'
9410 double precision zapas(max_dim,maxconts,max_fg_procs),
9411 & zapas_recv(max_dim,maxconts,max_fg_procs)
9412 common /przechowalnia/ zapas
9413 integer i,j,ii,jj,iproc,itask(4),nn
9414 c write (iout,*) "itask",itask
9417 if (iproc.gt.0) then
9418 do j=1,num_cont_hb(ii)
9420 c write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9422 ncont_sent(iproc)=ncont_sent(iproc)+1
9423 nn=ncont_sent(iproc)
9424 zapas(1,nn,iproc)=ii
9425 zapas(2,nn,iproc)=jjc
9426 zapas(3,nn,iproc)=d_cont(j,ii)
9430 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9435 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9443 zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9455 c------------------------------------------------------------------------------
9456 double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9457 implicit real*8 (a-h,o-z)
9458 include 'DIMENSIONS'
9459 include 'COMMON.IOUNITS'
9460 include 'COMMON.DERIV'
9461 include 'COMMON.INTERACT'
9462 include 'COMMON.CONTACTS'
9463 include 'COMMON.CONTMAT'
9464 include 'COMMON.CORRMAT'
9465 include 'COMMON.SHIELD'
9466 include 'COMMON.CONTROL'
9467 double precision gx(3),gx1(3)
9470 C print *,"wchodze",fac_shield(i),shield_mode
9478 ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9480 C & fac_shield(i)**2*fac_shield(j)**2
9481 cd ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9482 C Following 4 lines for diagnostics.
9487 c write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9488 c & 'Contacts ',i,j,
9489 c & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9490 c & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9492 C Calculate the multi-body contribution to energy.
9493 C ecorr=ecorr+ekont*ees
9494 C Calculate multi-body contributions to the gradient.
9495 coeffpees0pij=coeffp*ees0pij
9496 coeffmees0mij=coeffm*ees0mij
9497 coeffpees0pkl=coeffp*ees0pkl
9498 coeffmees0mkl=coeffm*ees0mkl
9500 cgrad ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9501 gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
9502 & -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
9503 & coeffmees0mkl*gacontm_hb1(ll,jj,i))
9504 gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
9505 & -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
9506 & coeffmees0mkl*gacontm_hb2(ll,jj,i))
9507 cgrad ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9508 gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
9509 & -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
9510 & coeffmees0mij*gacontm_hb1(ll,kk,k))
9511 gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
9512 & -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
9513 & coeffmees0mij*gacontm_hb2(ll,kk,k))
9514 gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
9515 & ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
9516 & coeffmees0mkl*gacontm_hb3(ll,jj,i))
9517 gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9518 gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9519 gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
9520 & ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
9521 & coeffmees0mij*gacontm_hb3(ll,kk,k))
9522 gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9523 gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9524 c write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9529 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9530 cgrad & ees*ekl*gacont_hbr(ll,jj,i)-
9531 cgrad & ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9532 cgrad & coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9537 cgrad gradcorr(ll,m)=gradcorr(ll,m)+
9538 cgrad & ees*eij*gacont_hbr(ll,kk,k)-
9539 cgrad & ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9540 cgrad & coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9543 c write (iout,*) "ehbcorr",ekont*ees
9544 C print *,ekont,ees,i,k
9546 C now gradient over shielding
9548 if (shield_mode.gt.0) then
9551 C print *,i,j,fac_shield(i),fac_shield(j),
9552 C &fac_shield(k),fac_shield(l)
9553 if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
9554 & (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9555 do ilist=1,ishield_list(i)
9556 iresshield=shield_list(ilist,i)
9558 rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9560 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9562 & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9563 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9567 do ilist=1,ishield_list(j)
9568 iresshield=shield_list(ilist,j)
9570 rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9572 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9574 & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9575 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9580 do ilist=1,ishield_list(k)
9581 iresshield=shield_list(ilist,k)
9583 rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9585 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9587 & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9588 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9592 do ilist=1,ishield_list(l)
9593 iresshield=shield_list(ilist,l)
9595 rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9597 gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9599 & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9600 gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9604 C print *,gshieldx(m,iresshield)
9606 gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9607 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9608 gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9609 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9610 gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9611 & grad_shield(m,i)*ehbcorr/fac_shield(i)
9612 gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9613 & grad_shield(m,j)*ehbcorr/fac_shield(j)
9615 gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9616 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9617 gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9618 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9619 gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9620 & grad_shield(m,k)*ehbcorr/fac_shield(k)
9621 gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9622 & grad_shield(m,l)*ehbcorr/fac_shield(l)
9630 C---------------------------------------------------------------------------
9631 subroutine dipole(i,j,jj)
9632 implicit real*8 (a-h,o-z)
9633 include 'DIMENSIONS'
9634 include 'COMMON.IOUNITS'
9635 include 'COMMON.CHAIN'
9636 include 'COMMON.FFIELD'
9637 include 'COMMON.DERIV'
9638 include 'COMMON.INTERACT'
9639 include 'COMMON.CONTACTS'
9640 include 'COMMON.CONTMAT'
9641 include 'COMMON.CORRMAT'
9642 include 'COMMON.TORSION'
9643 include 'COMMON.VAR'
9644 include 'COMMON.GEO'
9645 dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9647 iti1 = itortyp(itype(i+1))
9648 if (j.lt.nres-1) then
9649 itj1 = itype2loc(itype(j+1))
9654 dipi(iii,1)=Ub2(iii,i)
9655 dipderi(iii)=Ub2der(iii,i)
9656 dipi(iii,2)=b1(iii,i+1)
9657 dipj(iii,1)=Ub2(iii,j)
9658 dipderj(iii)=Ub2der(iii,j)
9659 dipj(iii,2)=b1(iii,j+1)
9663 call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9666 dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9673 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9677 dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9682 call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9683 call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9685 dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9687 call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9689 dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9694 C---------------------------------------------------------------------------
9695 subroutine calc_eello(i,j,k,l,jj,kk)
9697 C This subroutine computes matrices and vectors needed to calculate
9698 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9700 implicit real*8 (a-h,o-z)
9701 include 'DIMENSIONS'
9702 include 'COMMON.IOUNITS'
9703 include 'COMMON.CHAIN'
9704 include 'COMMON.DERIV'
9705 include 'COMMON.INTERACT'
9706 include 'COMMON.CONTACTS'
9707 include 'COMMON.CONTMAT'
9708 include 'COMMON.CORRMAT'
9709 include 'COMMON.TORSION'
9710 include 'COMMON.VAR'
9711 include 'COMMON.GEO'
9712 include 'COMMON.FFIELD'
9713 double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9714 & aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9717 cd write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9718 cd & ' jj=',jj,' kk=',kk
9719 cd if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9720 cd write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9721 cd write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9724 aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9725 aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9728 call transpose2(aa1(1,1),aa1t(1,1))
9729 call transpose2(aa2(1,1),aa2t(1,1))
9732 call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9733 & aa1tder(1,1,lll,kkk))
9734 call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9735 & aa2tder(1,1,lll,kkk))
9739 C parallel orientation of the two CA-CA-CA frames.
9741 iti=itype2loc(itype(i))
9745 itk1=itype2loc(itype(k+1))
9746 itj=itype2loc(itype(j))
9747 if (l.lt.nres-1) then
9748 itl1=itype2loc(itype(l+1))
9752 C A1 kernel(j+1) A2T
9754 cd write (iout,'(3f10.5,5x,3f10.5)')
9755 cd & (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9757 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9758 & aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9759 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9760 C Following matrices are needed only for 6-th order cumulants
9761 IF (wcorr6.gt.0.0d0) THEN
9762 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9763 & aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9764 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9765 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9766 & aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9767 & Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9768 & ADtEAderx(1,1,1,1,1,1))
9770 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9771 & aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9772 & DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9773 & ADtEA1derx(1,1,1,1,1,1))
9775 C End 6-th order cumulants
9778 cd write (2,*) 'In calc_eello6'
9780 cd write (2,*) 'iii=',iii
9782 cd write (2,*) 'kkk=',kkk
9784 cd write (2,'(3(2f10.5),5x)')
9785 cd & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9790 call transpose2(EUgder(1,1,k),auxmat(1,1))
9791 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9792 call transpose2(EUg(1,1,k),auxmat(1,1))
9793 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9794 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9795 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9796 c in theta; to be sriten later.
9798 c call transpose2(gtEE(1,1,k),auxmat(1,1))
9799 c call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9800 c call transpose2(EUg(1,1,k),auxmat(1,1))
9801 c call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9806 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9807 & EAEAderx(1,1,lll,kkk,iii,1))
9811 C A1T kernel(i+1) A2
9812 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9813 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9814 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9815 C Following matrices are needed only for 6-th order cumulants
9816 IF (wcorr6.gt.0.0d0) THEN
9817 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9818 & a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9819 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9820 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9821 & a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9822 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9823 & ADtEAderx(1,1,1,1,1,2))
9824 call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9825 & a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9826 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9827 & ADtEA1derx(1,1,1,1,1,2))
9829 C End 6-th order cumulants
9830 call transpose2(EUgder(1,1,l),auxmat(1,1))
9831 call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9832 call transpose2(EUg(1,1,l),auxmat(1,1))
9833 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9834 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9838 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9839 & EAEAderx(1,1,lll,kkk,iii,2))
9844 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9845 C They are needed only when the fifth- or the sixth-order cumulants are
9847 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9848 call transpose2(AEA(1,1,1),auxmat(1,1))
9849 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9850 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9851 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9852 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9853 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9854 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9855 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9856 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9857 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9858 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9859 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9860 call transpose2(AEA(1,1,2),auxmat(1,1))
9861 call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9862 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9863 call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9864 call transpose2(AEAderg(1,1,2),auxmat(1,1))
9865 call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9866 call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9867 call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9868 call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9869 call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9870 call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9871 call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9872 C Calculate the Cartesian derivatives of the vectors.
9876 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9877 call matvec2(auxmat(1,1),b1(1,i),
9878 & AEAb1derx(1,lll,kkk,iii,1,1))
9879 call matvec2(auxmat(1,1),Ub2(1,i),
9880 & AEAb2derx(1,lll,kkk,iii,1,1))
9881 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9882 & AEAb1derx(1,lll,kkk,iii,2,1))
9883 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9884 & AEAb2derx(1,lll,kkk,iii,2,1))
9885 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9886 call matvec2(auxmat(1,1),b1(1,j),
9887 & AEAb1derx(1,lll,kkk,iii,1,2))
9888 call matvec2(auxmat(1,1),Ub2(1,j),
9889 & AEAb2derx(1,lll,kkk,iii,1,2))
9890 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9891 & AEAb1derx(1,lll,kkk,iii,2,2))
9892 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9893 & AEAb2derx(1,lll,kkk,iii,2,2))
9900 C Antiparallel orientation of the two CA-CA-CA frames.
9902 iti=itype2loc(itype(i))
9906 itk1=itype2loc(itype(k+1))
9907 itl=itype2loc(itype(l))
9908 itj=itype2loc(itype(j))
9909 if (j.lt.nres-1) then
9910 itj1=itype2loc(itype(j+1))
9914 C A2 kernel(j-1)T A1T
9915 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9916 & aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9917 & AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9918 C Following matrices are needed only for 6-th order cumulants
9919 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9920 & j.eq.i+4 .and. l.eq.i+3)) THEN
9921 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9922 & aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9923 & AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9924 call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9925 & aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9926 & Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9927 & ADtEAderx(1,1,1,1,1,1))
9928 call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9929 & aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9930 & DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9931 & ADtEA1derx(1,1,1,1,1,1))
9933 C End 6-th order cumulants
9934 call transpose2(EUgder(1,1,k),auxmat(1,1))
9935 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9936 call transpose2(EUg(1,1,k),auxmat(1,1))
9937 call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9938 call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9942 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9943 & EAEAderx(1,1,lll,kkk,iii,1))
9947 C A2T kernel(i+1)T A1
9948 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9949 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9950 & AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9951 C Following matrices are needed only for 6-th order cumulants
9952 IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9953 & j.eq.i+4 .and. l.eq.i+3)) THEN
9954 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9955 & a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9956 & AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9957 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9958 & a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9959 & Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9960 & ADtEAderx(1,1,1,1,1,2))
9961 call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9962 & a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9963 & DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9964 & ADtEA1derx(1,1,1,1,1,2))
9966 C End 6-th order cumulants
9967 call transpose2(EUgder(1,1,j),auxmat(1,1))
9968 call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9969 call transpose2(EUg(1,1,j),auxmat(1,1))
9970 call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9971 call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9975 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9976 & EAEAderx(1,1,lll,kkk,iii,2))
9981 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9982 C They are needed only when the fifth- or the sixth-order cumulants are
9984 IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9985 & (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9986 call transpose2(AEA(1,1,1),auxmat(1,1))
9987 call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9988 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9989 call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9990 call transpose2(AEAderg(1,1,1),auxmat(1,1))
9991 call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9992 call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9993 call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9994 call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9995 call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9996 call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9997 call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9998 call transpose2(AEA(1,1,2),auxmat(1,1))
9999 call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
10000 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
10001 call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
10002 call transpose2(AEAderg(1,1,2),auxmat(1,1))
10003 call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
10004 call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
10005 call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
10006 call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
10007 call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
10008 call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
10009 call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
10010 C Calculate the Cartesian derivatives of the vectors.
10014 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
10015 call matvec2(auxmat(1,1),b1(1,i),
10016 & AEAb1derx(1,lll,kkk,iii,1,1))
10017 call matvec2(auxmat(1,1),Ub2(1,i),
10018 & AEAb2derx(1,lll,kkk,iii,1,1))
10019 call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10020 & AEAb1derx(1,lll,kkk,iii,2,1))
10021 call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
10022 & AEAb2derx(1,lll,kkk,iii,2,1))
10023 call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
10024 call matvec2(auxmat(1,1),b1(1,l),
10025 & AEAb1derx(1,lll,kkk,iii,1,2))
10026 call matvec2(auxmat(1,1),Ub2(1,l),
10027 & AEAb2derx(1,lll,kkk,iii,1,2))
10028 call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
10029 & AEAb1derx(1,lll,kkk,iii,2,2))
10030 call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
10031 & AEAb2derx(1,lll,kkk,iii,2,2))
10040 C---------------------------------------------------------------------------
10041 subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
10042 & KK,KKderg,AKA,AKAderg,AKAderx)
10046 double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
10047 & aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
10048 & AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
10049 integer iii,kkk,lll
10052 common /kutas/ lprn
10053 call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
10055 call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
10056 & AKAderg(1,1,iii))
10058 cd if (lprn) write (2,*) 'In kernel'
10060 cd if (lprn) write (2,*) 'kkk=',kkk
10062 call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
10063 & KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
10065 cd write (2,*) 'lll=',lll
10066 cd write (2,*) 'iii=1'
10068 cd write (2,'(3(2f10.5),5x)')
10069 cd & (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
10072 call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
10073 & KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
10075 cd write (2,*) 'lll=',lll
10076 cd write (2,*) 'iii=2'
10078 cd write (2,'(3(2f10.5),5x)')
10079 cd & (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
10086 C---------------------------------------------------------------------------
10087 double precision function eello4(i,j,k,l,jj,kk)
10088 implicit real*8 (a-h,o-z)
10089 include 'DIMENSIONS'
10090 include 'COMMON.IOUNITS'
10091 include 'COMMON.CHAIN'
10092 include 'COMMON.DERIV'
10093 include 'COMMON.INTERACT'
10094 include 'COMMON.CONTACTS'
10095 include 'COMMON.CONTMAT'
10096 include 'COMMON.CORRMAT'
10097 include 'COMMON.TORSION'
10098 include 'COMMON.VAR'
10099 include 'COMMON.GEO'
10100 double precision pizda(2,2),ggg1(3),ggg2(3)
10101 cd if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
10105 cd print *,'eello4:',i,j,k,l,jj,kk
10106 cd write (2,*) 'i',i,' j',j,' k',k,' l',l
10107 cd call checkint4(i,j,k,l,jj,kk,eel4_num)
10108 cold eij=facont_hb(jj,i)
10109 cold ekl=facont_hb(kk,k)
10111 eel4=-EAEA(1,1,1)-EAEA(2,2,1)
10112 cd eel41=-EAEA(1,1,2)-EAEA(2,2,2)
10113 gcorr_loc(k-1)=gcorr_loc(k-1)
10114 & -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
10116 gcorr_loc(l-1)=gcorr_loc(l-1)
10117 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10118 C Al 4/16/16: Derivatives in theta, to be added later.
10120 c gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
10121 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10124 gcorr_loc(j-1)=gcorr_loc(j-1)
10125 & -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
10127 c gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
10128 c & -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
10134 derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
10135 & -EAEAderx(2,2,lll,kkk,iii,1)
10136 cd derx(lll,kkk,iii)=0.0d0
10140 cd gcorr_loc(l-1)=0.0d0
10141 cd gcorr_loc(j-1)=0.0d0
10142 cd gcorr_loc(k-1)=0.0d0
10144 cd write (iout,*)'Contacts have occurred for peptide groups',
10145 cd & i,j,' fcont:',eij,' eij',' and ',k,l,
10146 cd & ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
10147 if (j.lt.nres-1) then
10154 if (l.lt.nres-1) then
10162 cgrad ggg1(ll)=eel4*g_contij(ll,1)
10163 cgrad ggg2(ll)=eel4*g_contij(ll,2)
10164 glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
10165 glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10166 cgrad ghalf=0.5d0*ggg1(ll)
10167 gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10168 gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10169 gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10170 gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10171 gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10172 gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10173 cgrad ghalf=0.5d0*ggg2(ll)
10174 gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10175 gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10176 gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10177 gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10178 gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10179 gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10183 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10188 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10193 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10198 cgrad gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10202 cd write (2,*) iii,gcorr_loc(iii)
10205 cd write (2,*) 'ekont',ekont
10206 cd write (iout,*) 'eello4',ekont*eel4
10209 C---------------------------------------------------------------------------
10210 double precision function eello5(i,j,k,l,jj,kk)
10211 implicit real*8 (a-h,o-z)
10212 include 'DIMENSIONS'
10213 include 'COMMON.IOUNITS'
10214 include 'COMMON.CHAIN'
10215 include 'COMMON.DERIV'
10216 include 'COMMON.INTERACT'
10217 include 'COMMON.CONTACTS'
10218 include 'COMMON.CONTMAT'
10219 include 'COMMON.CORRMAT'
10220 include 'COMMON.TORSION'
10221 include 'COMMON.VAR'
10222 include 'COMMON.GEO'
10223 double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
10224 double precision ggg1(3),ggg2(3)
10225 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10227 C Parallel chains C
10230 C /l\ / \ \ / \ / \ / C
10231 C / \ / \ \ / \ / \ / C
10232 C j| o |l1 | o | o| o | | o |o C
10233 C \ |/k\| |/ \| / |/ \| |/ \| C
10234 C \i/ \ / \ / / \ / \ C
10236 C (I) (II) (III) (IV) C
10238 C eello5_1 eello5_2 eello5_3 eello5_4 C
10240 C Antiparallel chains C
10243 C /j\ / \ \ / \ / \ / C
10244 C / \ / \ \ / \ / \ / C
10245 C j1| o |l | o | o| o | | o |o C
10246 C \ |/k\| |/ \| / |/ \| |/ \| C
10247 C \i/ \ / \ / / \ / \ C
10249 C (I) (II) (III) (IV) C
10251 C eello5_1 eello5_2 eello5_3 eello5_4 C
10253 C o denotes a local interaction, vertical lines an electrostatic interaction. C
10255 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10256 cd if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10261 cd & 'EELLO5: Contacts have occurred for peptide groups',i,j,
10263 itk=itype2loc(itype(k))
10264 itl=itype2loc(itype(l))
10265 itj=itype2loc(itype(j))
10270 cd call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10271 cd & eel5_3_num,eel5_4_num)
10275 derx(lll,kkk,iii)=0.0d0
10279 cd eij=facont_hb(jj,i)
10280 cd ekl=facont_hb(kk,k)
10282 cd write (iout,*)'Contacts have occurred for peptide groups',
10283 cd & i,j,' fcont:',eij,' eij',' and ',k,l
10285 C Contribution from the graph I.
10286 cd write (2,*) 'AEA ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10287 cd write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10288 call transpose2(EUg(1,1,k),auxmat(1,1))
10289 call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10290 vv(1)=pizda(1,1)-pizda(2,2)
10291 vv(2)=pizda(1,2)+pizda(2,1)
10292 eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
10293 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10294 C Explicit gradient in virtual-dihedral angles.
10295 if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
10296 & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
10297 & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10298 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10299 call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10300 vv(1)=pizda(1,1)-pizda(2,2)
10301 vv(2)=pizda(1,2)+pizda(2,1)
10302 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10303 & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
10304 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10305 call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10306 vv(1)=pizda(1,1)-pizda(2,2)
10307 vv(2)=pizda(1,2)+pizda(2,1)
10309 if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
10310 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10311 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10313 if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
10314 & +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
10315 & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10317 C Cartesian gradient
10321 call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
10323 vv(1)=pizda(1,1)-pizda(2,2)
10324 vv(2)=pizda(1,2)+pizda(2,1)
10325 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10326 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
10327 & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10333 C Contribution from graph II
10334 call transpose2(EE(1,1,k),auxmat(1,1))
10335 call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10336 vv(1)=pizda(1,1)+pizda(2,2)
10337 vv(2)=pizda(2,1)-pizda(1,2)
10338 eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
10339 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10340 C Explicit gradient in virtual-dihedral angles.
10341 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10342 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10343 call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10344 vv(1)=pizda(1,1)+pizda(2,2)
10345 vv(2)=pizda(2,1)-pizda(1,2)
10347 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10348 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10349 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10351 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10352 & +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
10353 & -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10355 C Cartesian gradient
10359 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
10361 vv(1)=pizda(1,1)+pizda(2,2)
10362 vv(2)=pizda(2,1)-pizda(1,2)
10363 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10364 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
10365 & -0.5d0*scalar2(vv(1),Ctobr(1,k))
10373 C Parallel orientation
10374 C Contribution from graph III
10375 call transpose2(EUg(1,1,l),auxmat(1,1))
10376 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10377 vv(1)=pizda(1,1)-pizda(2,2)
10378 vv(2)=pizda(1,2)+pizda(2,1)
10379 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
10380 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10381 C Explicit gradient in virtual-dihedral angles.
10382 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10383 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
10384 & +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10385 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10386 vv(1)=pizda(1,1)-pizda(2,2)
10387 vv(2)=pizda(1,2)+pizda(2,1)
10388 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10389 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
10390 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10391 call transpose2(EUgder(1,1,l),auxmat1(1,1))
10392 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10393 vv(1)=pizda(1,1)-pizda(2,2)
10394 vv(2)=pizda(1,2)+pizda(2,1)
10395 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10396 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
10397 & +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10398 C Cartesian gradient
10402 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10404 vv(1)=pizda(1,1)-pizda(2,2)
10405 vv(2)=pizda(1,2)+pizda(2,1)
10406 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10407 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
10408 & +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10413 C Contribution from graph IV
10415 call transpose2(EE(1,1,l),auxmat(1,1))
10416 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10417 vv(1)=pizda(1,1)+pizda(2,2)
10418 vv(2)=pizda(2,1)-pizda(1,2)
10419 eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
10420 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10421 C Explicit gradient in virtual-dihedral angles.
10422 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10423 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10424 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10425 vv(1)=pizda(1,1)+pizda(2,2)
10426 vv(2)=pizda(2,1)-pizda(1,2)
10427 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10428 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
10429 & -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10430 C Cartesian gradient
10434 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10436 vv(1)=pizda(1,1)+pizda(2,2)
10437 vv(2)=pizda(2,1)-pizda(1,2)
10438 derx(lll,kkk,iii)=derx(lll,kkk,iii)
10439 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
10440 & -0.5d0*scalar2(vv(1),Ctobr(1,l))
10445 C Antiparallel orientation
10446 C Contribution from graph III
10448 call transpose2(EUg(1,1,j),auxmat(1,1))
10449 call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10450 vv(1)=pizda(1,1)-pizda(2,2)
10451 vv(2)=pizda(1,2)+pizda(2,1)
10452 eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
10453 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10454 C Explicit gradient in virtual-dihedral angles.
10455 g_corr5_loc(l-1)=g_corr5_loc(l-1)
10456 & +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
10457 & +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10458 call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10459 vv(1)=pizda(1,1)-pizda(2,2)
10460 vv(2)=pizda(1,2)+pizda(2,1)
10461 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10462 & +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
10463 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10464 call transpose2(EUgder(1,1,j),auxmat1(1,1))
10465 call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10466 vv(1)=pizda(1,1)-pizda(2,2)
10467 vv(2)=pizda(1,2)+pizda(2,1)
10468 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10469 & +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
10470 & +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10471 C Cartesian gradient
10475 call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
10477 vv(1)=pizda(1,1)-pizda(2,2)
10478 vv(2)=pizda(1,2)+pizda(2,1)
10479 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10480 & +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
10481 & +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10486 C Contribution from graph IV
10488 call transpose2(EE(1,1,j),auxmat(1,1))
10489 call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10490 vv(1)=pizda(1,1)+pizda(2,2)
10491 vv(2)=pizda(2,1)-pizda(1,2)
10492 eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
10493 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10494 C Explicit gradient in virtual-dihedral angles.
10495 g_corr5_loc(j-1)=g_corr5_loc(j-1)
10496 & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10497 call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10498 vv(1)=pizda(1,1)+pizda(2,2)
10499 vv(2)=pizda(2,1)-pizda(1,2)
10500 g_corr5_loc(k-1)=g_corr5_loc(k-1)
10501 & +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
10502 & -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10503 C Cartesian gradient
10507 call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
10509 vv(1)=pizda(1,1)+pizda(2,2)
10510 vv(2)=pizda(2,1)-pizda(1,2)
10511 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
10512 & +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
10513 & -0.5d0*scalar2(vv(1),Ctobr(1,j))
10519 eel5=eello5_1+eello5_2+eello5_3+eello5_4
10520 cd if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10521 cd write (2,*) 'ijkl',i,j,k,l
10522 cd write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10523 cd & ' eello5_3',eello5_3,' eello5_4',eello5_4
10525 cd write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10526 cd write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10527 cd write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10528 cd write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10529 if (j.lt.nres-1) then
10536 if (l.lt.nres-1) then
10546 cd write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10547 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
10548 C summed up outside the subrouine as for the other subroutines
10549 C handling long-range interactions. The old code is commented out
10550 C with "cgrad" to keep track of changes.
10552 cgrad ggg1(ll)=eel5*g_contij(ll,1)
10553 cgrad ggg2(ll)=eel5*g_contij(ll,2)
10554 gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10555 gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10556 c write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10557 c & "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10558 c & derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10559 c & derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10560 c write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10561 c & "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10563 c & k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10564 cold ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10565 cgrad ghalf=0.5d0*ggg1(ll)
10567 gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10568 gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10569 gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10570 gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10571 gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10572 gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10573 cold ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10574 cgrad ghalf=0.5d0*ggg2(ll)
10576 gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
10577 gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10578 gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
10579 gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10580 gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10581 gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10586 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10587 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10592 cold gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10593 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10599 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10604 cgrad gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10608 cd write (2,*) iii,g_corr5_loc(iii)
10611 cd write (2,*) 'ekont',ekont
10612 cd write (iout,*) 'eello5',ekont*eel5
10615 c--------------------------------------------------------------------------
10616 double precision function eello6(i,j,k,l,jj,kk)
10617 implicit real*8 (a-h,o-z)
10618 include 'DIMENSIONS'
10619 include 'COMMON.IOUNITS'
10620 include 'COMMON.CHAIN'
10621 include 'COMMON.DERIV'
10622 include 'COMMON.INTERACT'
10623 include 'COMMON.CONTACTS'
10624 include 'COMMON.CONTMAT'
10625 include 'COMMON.CORRMAT'
10626 include 'COMMON.TORSION'
10627 include 'COMMON.VAR'
10628 include 'COMMON.GEO'
10629 include 'COMMON.FFIELD'
10630 double precision ggg1(3),ggg2(3)
10631 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10636 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
10644 cd call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10645 cd & eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10649 derx(lll,kkk,iii)=0.0d0
10653 cd eij=facont_hb(jj,i)
10654 cd ekl=facont_hb(kk,k)
10660 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10661 eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10662 eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10663 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10664 eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10665 eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10667 eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10668 eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10669 eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10670 eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10671 if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10672 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10676 eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10678 C If turn contributions are considered, they will be handled separately.
10679 eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10680 cd write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10681 cd write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10682 cd write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10683 cd write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10684 cd write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10685 cd write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10687 if (j.lt.nres-1) then
10694 if (l.lt.nres-1) then
10702 cgrad ggg1(ll)=eel6*g_contij(ll,1)
10703 cgrad ggg2(ll)=eel6*g_contij(ll,2)
10704 cold ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10705 cgrad ghalf=0.5d0*ggg1(ll)
10707 gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10708 gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10709 gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10710 gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10711 gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10712 gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10713 gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10714 gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10715 cgrad ghalf=0.5d0*ggg2(ll)
10716 cold ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10718 gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10719 gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10720 gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10721 gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10722 gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10723 gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10728 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10729 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10734 cold gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10735 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10741 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10746 cgrad gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10750 cd write (2,*) iii,g_corr6_loc(iii)
10753 cd write (2,*) 'ekont',ekont
10754 cd write (iout,*) 'eello6',ekont*eel6
10757 c--------------------------------------------------------------------------
10758 double precision function eello6_graph1(i,j,k,l,imat,swap)
10759 implicit real*8 (a-h,o-z)
10760 include 'DIMENSIONS'
10761 include 'COMMON.IOUNITS'
10762 include 'COMMON.CHAIN'
10763 include 'COMMON.DERIV'
10764 include 'COMMON.INTERACT'
10765 include 'COMMON.CONTACTS'
10766 include 'COMMON.CONTMAT'
10767 include 'COMMON.CORRMAT'
10768 include 'COMMON.TORSION'
10769 include 'COMMON.VAR'
10770 include 'COMMON.GEO'
10771 double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10774 common /kutas/ lprn
10775 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10777 C Parallel Antiparallel C
10783 C \ j|/k\| / \ |/k\|l / C
10784 C \ / \ / \ / \ / C
10788 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10789 itk=itype2loc(itype(k))
10790 s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10791 s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10792 s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10793 call transpose2(EUgC(1,1,k),auxmat(1,1))
10794 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10795 vv1(1)=pizda1(1,1)-pizda1(2,2)
10796 vv1(2)=pizda1(1,2)+pizda1(2,1)
10797 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10798 vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10799 vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10800 s5=scalar2(vv(1),Dtobr2(1,i))
10801 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10802 eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10803 if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10804 & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10805 & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10806 & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10807 & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10808 & +scalar2(vv(1),Dtobr2der(1,i)))
10809 call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10810 vv1(1)=pizda1(1,1)-pizda1(2,2)
10811 vv1(2)=pizda1(1,2)+pizda1(2,1)
10812 vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10813 vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10815 g_corr6_loc(l-1)=g_corr6_loc(l-1)
10816 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10817 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10818 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10819 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10821 g_corr6_loc(j-1)=g_corr6_loc(j-1)
10822 & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10823 & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10824 & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10825 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10827 call transpose2(EUgCder(1,1,k),auxmat(1,1))
10828 call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10829 vv1(1)=pizda1(1,1)-pizda1(2,2)
10830 vv1(2)=pizda1(1,2)+pizda1(2,1)
10831 if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10832 & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10833 & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10834 & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10843 s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10844 s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10845 s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10846 call transpose2(EUgC(1,1,k),auxmat(1,1))
10847 call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10849 vv1(1)=pizda1(1,1)-pizda1(2,2)
10850 vv1(2)=pizda1(1,2)+pizda1(2,1)
10851 s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10852 vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10853 & -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10854 vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10855 & +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10856 s5=scalar2(vv(1),Dtobr2(1,i))
10857 derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10863 c----------------------------------------------------------------------------
10864 double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10865 implicit real*8 (a-h,o-z)
10866 include 'DIMENSIONS'
10867 include 'COMMON.IOUNITS'
10868 include 'COMMON.CHAIN'
10869 include 'COMMON.DERIV'
10870 include 'COMMON.INTERACT'
10871 include 'COMMON.CONTACTS'
10872 include 'COMMON.CONTMAT'
10873 include 'COMMON.CORRMAT'
10874 include 'COMMON.TORSION'
10875 include 'COMMON.VAR'
10876 include 'COMMON.GEO'
10878 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10879 & auxvec1(2),auxvec2(2),auxmat1(2,2)
10881 common /kutas/ lprn
10882 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10884 C Parallel Antiparallel C
10890 C \ j|/k\| \ |/k\|l C
10895 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10896 cd write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10897 C AL 7/4/01 s1 would occur in the sixth-order moment,
10898 C but not in a cluster cumulant
10900 s1=dip(1,jj,i)*dip(1,kk,k)
10902 call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10903 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10904 call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10905 s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10906 call transpose2(EUg(1,1,k),auxmat(1,1))
10907 call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10908 vv(1)=pizda(1,1)-pizda(2,2)
10909 vv(2)=pizda(1,2)+pizda(2,1)
10910 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10911 cd write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10913 eello6_graph2=-(s1+s2+s3+s4)
10915 eello6_graph2=-(s2+s3+s4)
10917 c eello6_graph2=-s3
10918 C Derivatives in gamma(i-1)
10921 s1=dipderg(1,jj,i)*dip(1,kk,k)
10923 s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10924 call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10925 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10926 s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10928 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10930 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10932 c g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10934 C Derivatives in gamma(k-1)
10936 s1=dip(1,jj,i)*dipderg(1,kk,k)
10938 call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10939 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10940 call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10941 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10942 call transpose2(EUgder(1,1,k),auxmat1(1,1))
10943 call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10944 vv(1)=pizda(1,1)-pizda(2,2)
10945 vv(2)=pizda(1,2)+pizda(2,1)
10946 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10948 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10950 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10952 c g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10953 C Derivatives in gamma(j-1) or gamma(l-1)
10956 s1=dipderg(3,jj,i)*dip(1,kk,k)
10958 call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10959 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10960 s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10961 call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10962 vv(1)=pizda(1,1)-pizda(2,2)
10963 vv(2)=pizda(1,2)+pizda(2,1)
10964 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10967 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10969 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10972 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10973 c g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10975 C Derivatives in gamma(l-1) or gamma(j-1)
10978 s1=dip(1,jj,i)*dipderg(3,kk,k)
10980 call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10981 s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10982 call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10983 s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10984 call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10985 vv(1)=pizda(1,1)-pizda(2,2)
10986 vv(2)=pizda(1,2)+pizda(2,1)
10987 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10990 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10992 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10995 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10996 c g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10998 C Cartesian derivatives.
11000 write (2,*) 'In eello6_graph2'
11002 write (2,*) 'iii=',iii
11004 write (2,*) 'kkk=',kkk
11006 write (2,'(3(2f10.5),5x)')
11007 & ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
11017 s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
11019 s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
11022 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
11024 s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
11025 call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
11027 s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
11028 call transpose2(EUg(1,1,k),auxmat(1,1))
11029 call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
11031 vv(1)=pizda(1,1)-pizda(2,2)
11032 vv(2)=pizda(1,2)+pizda(2,1)
11033 s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
11034 cd write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
11036 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11038 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11041 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11043 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11050 c----------------------------------------------------------------------------
11051 double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
11052 implicit real*8 (a-h,o-z)
11053 include 'DIMENSIONS'
11054 include 'COMMON.IOUNITS'
11055 include 'COMMON.CHAIN'
11056 include 'COMMON.DERIV'
11057 include 'COMMON.INTERACT'
11058 include 'COMMON.CONTACTS'
11059 include 'COMMON.CONTMAT'
11060 include 'COMMON.CORRMAT'
11061 include 'COMMON.TORSION'
11062 include 'COMMON.VAR'
11063 include 'COMMON.GEO'
11064 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
11066 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11068 C Parallel Antiparallel C
11073 C /| o |o o| o |\ C
11074 C j|/k\| / |/k\|l / C
11079 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11081 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11082 C energy moment and not to the cluster cumulant.
11083 iti=itortyp(itype(i))
11084 if (j.lt.nres-1) then
11085 itj1=itype2loc(itype(j+1))
11089 itk=itype2loc(itype(k))
11090 itk1=itype2loc(itype(k+1))
11091 if (l.lt.nres-1) then
11092 itl1=itype2loc(itype(l+1))
11097 s1=dip(4,jj,i)*dip(4,kk,k)
11099 call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
11100 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11101 call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
11102 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11103 call transpose2(EE(1,1,k),auxmat(1,1))
11104 call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
11105 vv(1)=pizda(1,1)+pizda(2,2)
11106 vv(2)=pizda(2,1)-pizda(1,2)
11107 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11108 cd write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
11109 cd & "sum",-(s2+s3+s4)
11111 eello6_graph3=-(s1+s2+s3+s4)
11113 eello6_graph3=-(s2+s3+s4)
11115 c eello6_graph3=-s4
11116 C Derivatives in gamma(k-1)
11117 call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
11118 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11119 s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
11120 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
11121 C Derivatives in gamma(l-1)
11122 call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
11123 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11124 call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
11125 vv(1)=pizda(1,1)+pizda(2,2)
11126 vv(2)=pizda(2,1)-pizda(1,2)
11127 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11128 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11129 C Cartesian derivatives.
11135 s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
11137 s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
11140 call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
11142 s2=0.5d0*scalar2(b1(1,k),auxvec(1))
11143 call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
11145 s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
11146 call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
11148 vv(1)=pizda(1,1)+pizda(2,2)
11149 vv(2)=pizda(2,1)-pizda(1,2)
11150 s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
11152 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11154 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11157 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11159 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11161 c derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11167 c----------------------------------------------------------------------------
11168 double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11169 implicit real*8 (a-h,o-z)
11170 include 'DIMENSIONS'
11171 include 'COMMON.IOUNITS'
11172 include 'COMMON.CHAIN'
11173 include 'COMMON.DERIV'
11174 include 'COMMON.INTERACT'
11175 include 'COMMON.CONTACTS'
11176 include 'COMMON.CONTMAT'
11177 include 'COMMON.CORRMAT'
11178 include 'COMMON.TORSION'
11179 include 'COMMON.VAR'
11180 include 'COMMON.GEO'
11181 include 'COMMON.FFIELD'
11182 double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
11183 & auxvec1(2),auxmat1(2,2)
11185 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11187 C Parallel Antiparallel C
11192 C /| o |o o| o |\ C
11193 C \ j|/k\| \ |/k\|l C
11198 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11200 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
11201 C energy moment and not to the cluster cumulant.
11202 cd write (2,*) 'eello_graph4: wturn6',wturn6
11203 iti=itype2loc(itype(i))
11204 itj=itype2loc(itype(j))
11205 if (j.lt.nres-1) then
11206 itj1=itype2loc(itype(j+1))
11210 itk=itype2loc(itype(k))
11211 if (k.lt.nres-1) then
11212 itk1=itype2loc(itype(k+1))
11216 itl=itype2loc(itype(l))
11217 if (l.lt.nres-1) then
11218 itl1=itype2loc(itype(l+1))
11222 cd write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11223 cd write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11224 cd & ' itl',itl,' itl1',itl1
11226 if (imat.eq.1) then
11227 s1=dip(3,jj,i)*dip(3,kk,k)
11229 s1=dip(2,jj,j)*dip(2,kk,l)
11232 call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11233 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11235 call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
11236 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11238 call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
11239 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11241 call transpose2(EUg(1,1,k),auxmat(1,1))
11242 call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11243 vv(1)=pizda(1,1)-pizda(2,2)
11244 vv(2)=pizda(2,1)+pizda(1,2)
11245 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11246 cd write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11248 eello6_graph4=-(s1+s2+s3+s4)
11250 eello6_graph4=-(s2+s3+s4)
11252 C Derivatives in gamma(i-1)
11255 if (imat.eq.1) then
11256 s1=dipderg(2,jj,i)*dip(3,kk,k)
11258 s1=dipderg(4,jj,j)*dip(2,kk,l)
11261 s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11263 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
11264 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11266 call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
11267 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11269 s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11270 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11271 cd write (2,*) 'turn6 derivatives'
11273 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11275 gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11279 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11281 g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11285 C Derivatives in gamma(k-1)
11287 if (imat.eq.1) then
11288 s1=dip(3,jj,i)*dipderg(2,kk,k)
11290 s1=dip(2,jj,j)*dipderg(4,kk,l)
11293 call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11294 s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11296 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
11297 s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
11299 call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
11300 s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
11302 call transpose2(EUgder(1,1,k),auxmat1(1,1))
11303 call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11304 vv(1)=pizda(1,1)-pizda(2,2)
11305 vv(2)=pizda(2,1)+pizda(1,2)
11306 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11307 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11309 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11311 gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11315 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11317 g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11320 C Derivatives in gamma(j-1) or gamma(l-1)
11321 if (l.eq.j+1 .and. l.gt.1) then
11322 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11323 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11324 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11325 vv(1)=pizda(1,1)-pizda(2,2)
11326 vv(2)=pizda(2,1)+pizda(1,2)
11327 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11328 g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11329 else if (j.gt.1) then
11330 call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11331 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11332 call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11333 vv(1)=pizda(1,1)-pizda(2,2)
11334 vv(2)=pizda(2,1)+pizda(1,2)
11335 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11336 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11337 gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11339 g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11342 C Cartesian derivatives.
11348 if (imat.eq.1) then
11349 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11351 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11354 if (imat.eq.1) then
11355 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11357 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11361 call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
11363 s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11365 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11366 & b1(1,j+1),auxvec(1))
11367 s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
11369 call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
11370 & b1(1,l+1),auxvec(1))
11371 s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
11373 call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
11375 vv(1)=pizda(1,1)-pizda(2,2)
11376 vv(2)=pizda(2,1)+pizda(1,2)
11377 s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11379 if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11381 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11384 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
11387 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11390 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11392 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11394 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11398 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11400 derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11403 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11405 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11413 c----------------------------------------------------------------------------
11414 double precision function eello_turn6(i,jj,kk)
11415 implicit real*8 (a-h,o-z)
11416 include 'DIMENSIONS'
11417 include 'COMMON.IOUNITS'
11418 include 'COMMON.CHAIN'
11419 include 'COMMON.DERIV'
11420 include 'COMMON.INTERACT'
11421 include 'COMMON.CONTACTS'
11422 include 'COMMON.CONTMAT'
11423 include 'COMMON.CORRMAT'
11424 include 'COMMON.TORSION'
11425 include 'COMMON.VAR'
11426 include 'COMMON.GEO'
11427 double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
11428 & atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
11430 double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
11431 & atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
11432 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11433 C the respective energy moment and not to the cluster cumulant.
11442 iti=itype2loc(itype(i))
11443 itk=itype2loc(itype(k))
11444 itk1=itype2loc(itype(k+1))
11445 itl=itype2loc(itype(l))
11446 itj=itype2loc(itype(j))
11447 cd write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11448 cd write (2,*) 'i',i,' k',k,' j',j,' l',l
11449 cd if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11454 cd & 'EELLO6: Contacts have occurred for peptide groups',i,j,
11456 cd call checkint_turn6(i,jj,kk,eel_turn6_num)
11460 derx_turn(lll,kkk,iii)=0.0d0
11467 eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11469 cd write (2,*) 'eello6_5',eello6_5
11471 call transpose2(AEA(1,1,1),auxmat(1,1))
11472 call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11473 ss1=scalar2(Ub2(1,i+2),b1(1,l))
11474 s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11476 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11477 call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11478 s2 = scalar2(b1(1,k),vtemp1(1))
11480 call transpose2(AEA(1,1,2),atemp(1,1))
11481 call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11482 call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
11483 s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11485 call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11486 call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11487 s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11489 call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11490 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11491 call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11492 call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11493 ss13 = scalar2(b1(1,k),vtemp4(1))
11494 s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11496 c write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11502 eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11503 C Derivatives in gamma(i+2)
11507 call transpose2(AEA(1,1,1),auxmatd(1,1))
11508 call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11509 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11510 call transpose2(AEAderg(1,1,2),atempd(1,1))
11511 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11512 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11514 call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11515 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11516 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11522 gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11523 C Derivatives in gamma(i+3)
11525 call transpose2(AEA(1,1,1),auxmatd(1,1))
11526 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11527 ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
11528 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11530 call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
11531 call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11532 s2d = scalar2(b1(1,k),vtemp1d(1))
11534 call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
11535 s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
11537 s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11539 call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11540 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11541 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11549 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11550 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11552 gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
11553 & -0.5d0*ekont*(s2d+s12d)
11555 C Derivatives in gamma(i+4)
11556 call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11557 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11558 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11560 call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11561 call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11562 s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11570 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11572 gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11574 C Derivatives in gamma(i+5)
11576 call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11577 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11578 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11580 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
11581 call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11582 s2d = scalar2(b1(1,k),vtemp1d(1))
11584 call transpose2(AEA(1,1,2),atempd(1,1))
11585 call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11586 s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
11588 call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11589 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11591 call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11592 ss13d = scalar2(b1(1,k),vtemp4d(1))
11593 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11601 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11602 & -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11604 gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11605 & -0.5d0*ekont*(s2d+s12d)
11607 C Cartesian derivatives
11612 call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11613 call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11614 s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11616 call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11617 call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11619 s2d = scalar2(b1(1,k),vtemp1d(1))
11621 call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11622 call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11623 s8d = -(atempd(1,1)+atempd(2,2))*
11624 & scalar2(cc(1,1,l),vtemp2(1))
11626 call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11628 call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11629 s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11636 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11637 & - 0.5d0*(s1d+s2d)
11639 derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11643 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11644 & - 0.5d0*(s8d+s12d)
11646 derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11655 call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11656 & achuj_tempd(1,1))
11657 call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11658 call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11659 s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11660 derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11661 call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11663 ss13d = scalar2(b1(1,k),vtemp4d(1))
11664 s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11665 derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11669 cd write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11670 cd & 16*eel_turn6_num
11672 if (j.lt.nres-1) then
11679 if (l.lt.nres-1) then
11687 cgrad ggg1(ll)=eel_turn6*g_contij(ll,1)
11688 cgrad ggg2(ll)=eel_turn6*g_contij(ll,2)
11689 cgrad ghalf=0.5d0*ggg1(ll)
11691 gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11692 gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11693 gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11694 & +ekont*derx_turn(ll,2,1)
11695 gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11696 gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11697 & +ekont*derx_turn(ll,4,1)
11698 gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11699 gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11700 gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11701 cgrad ghalf=0.5d0*ggg2(ll)
11703 gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11704 & +ekont*derx_turn(ll,2,2)
11705 gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11706 gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11707 & +ekont*derx_turn(ll,4,2)
11708 gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11709 gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11710 gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11715 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11720 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11726 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11731 cgrad gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11735 cd write (2,*) iii,g_corr6_loc(iii)
11737 eello_turn6=ekont*eel_turn6
11738 cd write (2,*) 'ekont',ekont
11739 cd write (2,*) 'eel_turn6',ekont*eel_turn6
11742 C-----------------------------------------------------------------------------
11744 double precision function scalar(u,v)
11745 !DIR$ INLINEALWAYS scalar
11747 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11750 double precision u(3),v(3)
11751 cd double precision sc
11759 scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11762 crc-------------------------------------------------
11763 SUBROUTINE MATVEC2(A1,V1,V2)
11764 !DIR$ INLINEALWAYS MATVEC2
11766 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11768 implicit real*8 (a-h,o-z)
11769 include 'DIMENSIONS'
11770 DIMENSION A1(2,2),V1(2),V2(2)
11774 c 3 VI=VI+A1(I,K)*V1(K)
11778 vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11779 vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11784 C---------------------------------------
11785 SUBROUTINE MATMAT2(A1,A2,A3)
11787 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11789 implicit real*8 (a-h,o-z)
11790 include 'DIMENSIONS'
11791 DIMENSION A1(2,2),A2(2,2),A3(2,2)
11792 c DIMENSION AI3(2,2)
11796 c A3IJ=A3IJ+A1(I,K)*A2(K,J)
11802 ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11803 ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11804 ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11805 ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11813 c-------------------------------------------------------------------------
11814 double precision function scalar2(u,v)
11815 !DIR$ INLINEALWAYS scalar2
11817 double precision u(2),v(2)
11818 double precision sc
11820 scalar2=u(1)*v(1)+u(2)*v(2)
11824 C-----------------------------------------------------------------------------
11826 subroutine transpose2(a,at)
11827 !DIR$ INLINEALWAYS transpose2
11829 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11832 double precision a(2,2),at(2,2)
11839 c--------------------------------------------------------------------------
11840 subroutine transpose(n,a,at)
11843 double precision a(n,n),at(n,n)
11851 C---------------------------------------------------------------------------
11852 subroutine prodmat3(a1,a2,kk,transp,prod)
11853 !DIR$ INLINEALWAYS prodmat3
11855 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11859 double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11861 crc double precision auxmat(2,2),prod_(2,2)
11864 crc call transpose2(kk(1,1),auxmat(1,1))
11865 crc call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11866 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11868 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11869 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11870 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11871 & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11872 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11873 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11874 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11875 & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11878 crc call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11879 crc call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11881 prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11882 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11883 prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11884 & +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11885 prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11886 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11887 prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11888 & +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11891 c call transpose2(a2(1,1),a2t(1,1))
11894 crc print *,((prod_(i,j),i=1,2),j=1,2)
11895 crc print *,((prod(i,j),i=1,2),j=1,2)
11899 CCC----------------------------------------------
11900 subroutine Eliptransfer(eliptran)
11901 implicit real*8 (a-h,o-z)
11902 include 'DIMENSIONS'
11903 include 'COMMON.GEO'
11904 include 'COMMON.VAR'
11905 include 'COMMON.LOCAL'
11906 include 'COMMON.CHAIN'
11907 include 'COMMON.DERIV'
11908 include 'COMMON.NAMES'
11909 include 'COMMON.INTERACT'
11910 include 'COMMON.IOUNITS'
11911 include 'COMMON.CALC'
11912 include 'COMMON.CONTROL'
11913 include 'COMMON.SPLITELE'
11914 include 'COMMON.SBRIDGE'
11915 C this is done by Adasko
11916 C print *,"wchodze"
11917 C structure of box:
11919 C--bordliptop-- buffore starts
11920 C--bufliptop--- here true lipid starts
11922 C--buflipbot--- lipid ends buffore starts
11923 C--bordlipbot--buffore ends
11926 do i=ilip_start,ilip_end
11928 if (itype(i).eq.ntyp1) cycle
11930 positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11931 if (positi.le.0.0) positi=positi+boxzsize
11933 C first for peptide groups
11934 c for each residue check if it is in lipid or lipid water border area
11935 if ((positi.gt.bordlipbot)
11936 &.and.(positi.lt.bordliptop)) then
11937 C the energy transfer exist
11938 if (positi.lt.buflipbot) then
11939 C what fraction I am in
11941 & ((positi-bordlipbot)/lipbufthick)
11942 C lipbufthick is thickenes of lipid buffore
11943 sslip=sscalelip(fracinbuf)
11944 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11945 eliptran=eliptran+sslip*pepliptran
11946 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11947 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11948 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11950 C print *,"doing sccale for lower part"
11951 C print *,i,sslip,fracinbuf,ssgradlip
11952 elseif (positi.gt.bufliptop) then
11953 fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11954 sslip=sscalelip(fracinbuf)
11955 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11956 eliptran=eliptran+sslip*pepliptran
11957 gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11958 gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11959 C gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11960 C print *, "doing sscalefor top part"
11961 C print *,i,sslip,fracinbuf,ssgradlip
11963 eliptran=eliptran+pepliptran
11964 C print *,"I am in true lipid"
11967 C eliptran=elpitran+0.0 ! I am in water
11970 C print *, "nic nie bylo w lipidzie?"
11971 C now multiply all by the peptide group transfer factor
11972 C eliptran=eliptran*pepliptran
11973 C now the same for side chains
11975 do i=ilip_start,ilip_end
11976 if (itype(i).eq.ntyp1) cycle
11977 positi=(mod(c(3,i+nres),boxzsize))
11978 if (positi.le.0) positi=positi+boxzsize
11979 c write(iout,*) "i",i," positi",positi,bordlipbot,buflipbot,
11981 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11982 c for each residue check if it is in lipid or lipid water border area
11983 C respos=mod(c(3,i+nres),boxzsize)
11984 C print *,positi,bordlipbot,buflipbot
11985 if ((positi.gt.bordlipbot)
11986 & .and.(positi.lt.bordliptop)) then
11987 C the energy transfer exist
11988 if (positi.lt.buflipbot) then
11990 & ((positi-bordlipbot)/lipbufthick)
11991 c write (iout,*) "i",i,itype(i)," fracinbuf",fracinbuf
11992 c write (iout,*) "i",i," liptranene",liptranene(itype(i))
11993 C lipbufthick is thickenes of lipid buffore
11994 sslip=sscalelip(fracinbuf)
11995 ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11996 eliptran=eliptran+sslip*liptranene(itype(i))
11997 gliptranx(3,i)=gliptranx(3,i)
11998 &+ssgradlip*liptranene(itype(i))
11999 gliptranc(3,i-1)= gliptranc(3,i-1)
12000 &+ssgradlip*liptranene(itype(i))
12001 C print *,"doing sccale for lower part"
12002 elseif (positi.gt.bufliptop) then
12004 &((bordliptop-positi)/lipbufthick)
12005 sslip=sscalelip(fracinbuf)
12006 ssgradlip=sscagradlip(fracinbuf)/lipbufthick
12007 eliptran=eliptran+sslip*liptranene(itype(i))
12008 gliptranx(3,i)=gliptranx(3,i)
12009 &+ssgradlip*liptranene(itype(i))
12010 gliptranc(3,i-1)= gliptranc(3,i-1)
12011 &+ssgradlip*liptranene(itype(i))
12012 C print *, "doing sscalefor top part",sslip,fracinbuf
12014 eliptran=eliptran+liptranene(itype(i))
12015 C print *,"I am in true lipid"
12017 endif ! if in lipid or buffor
12019 C eliptran=elpitran+0.0 ! I am in water
12023 C---------------------------------------------------------
12024 C AFM soubroutine for constant force
12025 subroutine AFMforce(Eafmforce)
12026 implicit real*8 (a-h,o-z)
12027 include 'DIMENSIONS'
12028 include 'COMMON.GEO'
12029 include 'COMMON.VAR'
12030 include 'COMMON.LOCAL'
12031 include 'COMMON.CHAIN'
12032 include 'COMMON.DERIV'
12033 include 'COMMON.NAMES'
12034 include 'COMMON.INTERACT'
12035 include 'COMMON.IOUNITS'
12036 include 'COMMON.CALC'
12037 include 'COMMON.CONTROL'
12038 include 'COMMON.SPLITELE'
12039 include 'COMMON.SBRIDGE'
12044 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12045 dist=dist+diffafm(i)**2
12048 Eafmforce=-forceAFMconst*(dist-distafminit)
12050 gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
12051 gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
12053 C print *,'AFM',Eafmforce
12056 C---------------------------------------------------------
12057 C AFM subroutine with pseudoconstant velocity
12058 subroutine AFMvel(Eafmforce)
12059 implicit real*8 (a-h,o-z)
12060 include 'DIMENSIONS'
12061 include 'COMMON.GEO'
12062 include 'COMMON.VAR'
12063 include 'COMMON.LOCAL'
12064 include 'COMMON.CHAIN'
12065 include 'COMMON.DERIV'
12066 include 'COMMON.NAMES'
12067 include 'COMMON.INTERACT'
12068 include 'COMMON.IOUNITS'
12069 include 'COMMON.CALC'
12070 include 'COMMON.CONTROL'
12071 include 'COMMON.SPLITELE'
12072 include 'COMMON.SBRIDGE'
12074 C Only for check grad COMMENT if not used for checkgrad
12076 C--------------------------------------------------------
12077 C print *,"wchodze"
12081 diffafm(i)=c(i,afmend)-c(i,afmbeg)
12082 dist=dist+diffafm(i)**2
12085 Eafmforce=0.5d0*forceAFMconst
12086 & *(distafminit+totTafm*velAFMconst-dist)**2
12087 C Eafmforce=-forceAFMconst*(dist-distafminit)
12089 gradafm(i,afmend-1)=-forceAFMconst*
12090 &(distafminit+totTafm*velAFMconst-dist)
12092 gradafm(i,afmbeg-1)=forceAFMconst*
12093 &(distafminit+totTafm*velAFMconst-dist)
12096 C print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
12099 C-----------------------------------------------------------
12100 C first for shielding is setting of function of side-chains
12101 subroutine set_shield_fac
12102 implicit real*8 (a-h,o-z)
12103 include 'DIMENSIONS'
12104 include 'COMMON.CHAIN'
12105 include 'COMMON.DERIV'
12106 include 'COMMON.IOUNITS'
12107 include 'COMMON.SHIELD'
12108 include 'COMMON.INTERACT'
12109 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12110 double precision div77_81/0.974996043d0/,
12111 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12113 C the vector between center of side_chain and peptide group
12114 double precision pep_side(3),long,side_calf(3),
12115 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12116 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12117 C the line belowe needs to be changed for FGPROC>1
12119 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12121 Cif there two consequtive dummy atoms there is no peptide group between them
12122 C the line below has to be changed for FGPROC>1
12125 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12129 C first lets set vector conecting the ithe side-chain with kth side-chain
12130 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12131 C pep_side(j)=2.0d0
12132 C and vector conecting the side-chain with its proper calfa
12133 side_calf(j)=c(j,k+nres)-c(j,k)
12134 C side_calf(j)=2.0d0
12135 pept_group(j)=c(j,i)-c(j,i+1)
12136 C lets have their lenght
12137 dist_pep_side=pep_side(j)**2+dist_pep_side
12138 dist_side_calf=dist_side_calf+side_calf(j)**2
12139 dist_pept_group=dist_pept_group+pept_group(j)**2
12141 dist_pep_side=dsqrt(dist_pep_side)
12142 dist_pept_group=dsqrt(dist_pept_group)
12143 dist_side_calf=dsqrt(dist_side_calf)
12145 pep_side_norm(j)=pep_side(j)/dist_pep_side
12146 side_calf_norm(j)=dist_side_calf
12148 C now sscale fraction
12149 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12150 C print *,buff_shield,"buff"
12152 if (sh_frac_dist.le.0.0) cycle
12153 C If we reach here it means that this side chain reaches the shielding sphere
12154 C Lets add him to the list for gradient
12155 ishield_list(i)=ishield_list(i)+1
12156 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12157 C this list is essential otherwise problem would be O3
12158 shield_list(ishield_list(i),i)=k
12159 C Lets have the sscale value
12160 if (sh_frac_dist.gt.1.0) then
12161 scale_fac_dist=1.0d0
12163 sh_frac_dist_grad(j)=0.0d0
12166 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12167 & *(2.0*sh_frac_dist-3.0d0)
12168 fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
12169 & /dist_pep_side/buff_shield*0.5
12170 C remember for the final gradient multiply sh_frac_dist_grad(j)
12171 C for side_chain by factor -2 !
12173 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12174 C print *,"jestem",scale_fac_dist,fac_help_scale,
12175 C & sh_frac_dist_grad(j)
12178 C if ((i.eq.3).and.(k.eq.2)) then
12179 C print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
12183 C this is what is now we have the distance scaling now volume...
12184 short=short_r_sidechain(itype(k))
12185 long=long_r_sidechain(itype(k))
12186 costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
12189 costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
12190 C costhet_fac=0.0d0
12192 costhet_grad(j)=costhet_fac*pep_side(j)
12194 C remember for the final gradient multiply costhet_grad(j)
12195 C for side_chain by factor -2 !
12196 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12197 C pep_side0pept_group is vector multiplication
12198 pep_side0pept_group=0.0
12200 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12202 cosalfa=(pep_side0pept_group/
12203 & (dist_pep_side*dist_side_calf))
12204 fac_alfa_sin=1.0-cosalfa**2
12205 fac_alfa_sin=dsqrt(fac_alfa_sin)
12206 rkprim=fac_alfa_sin*(long-short)+short
12208 cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
12209 cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
12212 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12213 &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12214 &*(long-short)/fac_alfa_sin*cosalfa/
12215 &((dist_pep_side*dist_side_calf))*
12216 &((side_calf(j))-cosalfa*
12217 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12219 cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
12220 &*(long-short)/fac_alfa_sin*cosalfa
12221 &/((dist_pep_side*dist_side_calf))*
12223 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12226 VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
12229 C now the gradient...
12230 C grad_shield is gradient of Calfa for peptide groups
12231 C write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
12233 C write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
12234 C & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
12236 grad_shield(j,i)=grad_shield(j,i)
12237 C gradient po skalowaniu
12238 & +(sh_frac_dist_grad(j)
12239 C gradient po costhet
12240 &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
12241 &-scale_fac_dist*(cosphi_grad_long(j))
12242 &/(1.0-cosphi) )*div77_81
12244 C grad_shield_side is Cbeta sidechain gradient
12245 grad_shield_side(j,ishield_list(i),i)=
12246 & (sh_frac_dist_grad(j)*(-2.0d0)
12247 & +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
12248 & +scale_fac_dist*(cosphi_grad_long(j))
12249 & *2.0d0/(1.0-cosphi))
12250 & *div77_81*VofOverlap
12252 grad_shield_loc(j,ishield_list(i),i)=
12253 & scale_fac_dist*cosphi_grad_loc(j)
12254 & *2.0d0/(1.0-cosphi)
12255 & *div77_81*VofOverlap
12257 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12259 fac_shield(i)=VolumeTotal*div77_81+div4_81
12260 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
12264 C--------------------------------------------------------------------------
12265 double precision function tschebyshev(m,n,x,y)
12267 include "DIMENSIONS"
12269 double precision x(n),y,yy(0:maxvar),aux
12270 c Tschebyshev polynomial. Note that the first term is omitted
12271 c m=0: the constant term is included
12272 c m=1: the constant term is not included
12276 yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
12285 C--------------------------------------------------------------------------
12286 double precision function gradtschebyshev(m,n,x,y)
12288 include "DIMENSIONS"
12290 double precision x(n+1),y,yy(0:maxvar),aux
12291 c Tschebyshev polynomial. Note that the first term is omitted
12292 c m=0: the constant term is included
12293 c m=1: the constant term is not included
12297 yy(i)=2*y*yy(i-1)-yy(i-2)
12301 aux=aux+x(i+1)*yy(i)*(i+1)
12302 C print *, x(i+1),yy(i),i
12304 gradtschebyshev=aux
12307 C------------------------------------------------------------------------
12308 C first for shielding is setting of function of side-chains
12309 subroutine set_shield_fac2
12310 implicit real*8 (a-h,o-z)
12311 include 'DIMENSIONS'
12312 include 'COMMON.CHAIN'
12313 include 'COMMON.DERIV'
12314 include 'COMMON.IOUNITS'
12315 include 'COMMON.SHIELD'
12316 include 'COMMON.INTERACT'
12317 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
12318 double precision div77_81/0.974996043d0/,
12319 &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
12321 C the vector between center of side_chain and peptide group
12322 double precision pep_side(3),long,side_calf(3),
12323 &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
12324 &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
12325 C the line belowe needs to be changed for FGPROC>1
12327 if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
12329 Cif there two consequtive dummy atoms there is no peptide group between them
12330 C the line below has to be changed for FGPROC>1
12333 if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
12337 C first lets set vector conecting the ithe side-chain with kth side-chain
12338 pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
12339 C pep_side(j)=2.0d0
12340 C and vector conecting the side-chain with its proper calfa
12341 side_calf(j)=c(j,k+nres)-c(j,k)
12342 C side_calf(j)=2.0d0
12343 pept_group(j)=c(j,i)-c(j,i+1)
12344 C lets have their lenght
12345 dist_pep_side=pep_side(j)**2+dist_pep_side
12346 dist_side_calf=dist_side_calf+side_calf(j)**2
12347 dist_pept_group=dist_pept_group+pept_group(j)**2
12349 dist_pep_side=dsqrt(dist_pep_side)
12350 dist_pept_group=dsqrt(dist_pept_group)
12351 dist_side_calf=dsqrt(dist_side_calf)
12353 pep_side_norm(j)=pep_side(j)/dist_pep_side
12354 side_calf_norm(j)=dist_side_calf
12356 C now sscale fraction
12357 sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
12358 C print *,buff_shield,"buff"
12360 if (sh_frac_dist.le.0.0) cycle
12361 C If we reach here it means that this side chain reaches the shielding sphere
12362 C Lets add him to the list for gradient
12363 ishield_list(i)=ishield_list(i)+1
12364 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
12365 C this list is essential otherwise problem would be O3
12366 shield_list(ishield_list(i),i)=k
12367 C Lets have the sscale value
12368 if (sh_frac_dist.gt.1.0) then
12369 scale_fac_dist=1.0d0
12371 sh_frac_dist_grad(j)=0.0d0
12374 scale_fac_dist=-sh_frac_dist*sh_frac_dist
12375 & *(2.0d0*sh_frac_dist-3.0d0)
12376 fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
12377 & /dist_pep_side/buff_shield*0.5d0
12378 C remember for the final gradient multiply sh_frac_dist_grad(j)
12379 C for side_chain by factor -2 !
12381 sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
12382 C sh_frac_dist_grad(j)=0.0d0
12383 C scale_fac_dist=1.0d0
12384 C print *,"jestem",scale_fac_dist,fac_help_scale,
12385 C & sh_frac_dist_grad(j)
12388 C this is what is now we have the distance scaling now volume...
12389 short=short_r_sidechain(itype(k))
12390 long=long_r_sidechain(itype(k))
12391 costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
12392 sinthet=short/dist_pep_side*costhet
12396 costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
12397 C sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
12398 C & -short/dist_pep_side**2/costhet)
12399 C costhet_fac=0.0d0
12401 costhet_grad(j)=costhet_fac*pep_side(j)
12403 C remember for the final gradient multiply costhet_grad(j)
12404 C for side_chain by factor -2 !
12405 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
12406 C pep_side0pept_group is vector multiplication
12407 pep_side0pept_group=0.0d0
12409 pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
12411 cosalfa=(pep_side0pept_group/
12412 & (dist_pep_side*dist_side_calf))
12413 fac_alfa_sin=1.0d0-cosalfa**2
12414 fac_alfa_sin=dsqrt(fac_alfa_sin)
12415 rkprim=fac_alfa_sin*(long-short)+short
12419 cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
12421 cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
12422 sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
12423 & dist_pep_side**2)
12426 cosphi_grad_long(j)=cosphi_fac*pep_side(j)
12427 &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12428 &*(long-short)/fac_alfa_sin*cosalfa/
12429 &((dist_pep_side*dist_side_calf))*
12430 &((side_calf(j))-cosalfa*
12431 &((pep_side(j)/dist_pep_side)*dist_side_calf))
12432 C cosphi_grad_long(j)=0.0d0
12433 cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
12434 &*(long-short)/fac_alfa_sin*cosalfa
12435 &/((dist_pep_side*dist_side_calf))*
12437 &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
12438 C cosphi_grad_loc(j)=0.0d0
12440 C print *,sinphi,sinthet
12441 c write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
12442 c & VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
12443 VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
12446 C now the gradient...
12448 grad_shield(j,i)=grad_shield(j,i)
12449 C gradient po skalowaniu
12450 & +(sh_frac_dist_grad(j)*VofOverlap
12451 C gradient po costhet
12452 & +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
12453 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12454 & sinphi/sinthet*costhet*costhet_grad(j)
12455 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12457 C grad_shield_side is Cbeta sidechain gradient
12458 grad_shield_side(j,ishield_list(i),i)=
12459 & (sh_frac_dist_grad(j)*(-2.0d0)
12461 & -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12462 &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
12463 & sinphi/sinthet*costhet*costhet_grad(j)
12464 & +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
12467 grad_shield_loc(j,ishield_list(i),i)=
12468 & scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
12469 &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
12470 & sinthet/sinphi*cosphi*cosphi_grad_loc(j)
12474 c write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
12476 VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
12478 fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
12479 c write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
12480 c & " wshield",wshield
12481 c write(2,*) "TU",rpp(1,1),short,long,buff_shield
12485 C-----------------------------------------------------------------------
12486 C-----------------------------------------------------------
12487 C This subroutine is to mimic the histone like structure but as well can be
12488 C utilizet to nanostructures (infinit) small modification has to be used to
12489 C make it finite (z gradient at the ends has to be changes as well as the x,y
12490 C gradient has to be modified at the ends
12491 C The energy function is Kihara potential
12492 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12493 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12494 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12495 C simple Kihara potential
12496 subroutine calctube(Etube)
12497 implicit real*8 (a-h,o-z)
12498 include 'DIMENSIONS'
12499 include 'COMMON.GEO'
12500 include 'COMMON.VAR'
12501 include 'COMMON.LOCAL'
12502 include 'COMMON.CHAIN'
12503 include 'COMMON.DERIV'
12504 include 'COMMON.NAMES'
12505 include 'COMMON.INTERACT'
12506 include 'COMMON.IOUNITS'
12507 include 'COMMON.CALC'
12508 include 'COMMON.CONTROL'
12509 include 'COMMON.SPLITELE'
12510 include 'COMMON.SBRIDGE'
12511 double precision tub_r,vectube(3),enetube(maxres*2)
12516 C first we calculate the distance from tube center
12517 C first sugare-phosphate group for NARES this would be peptide group
12520 C lets ommit dummy atoms for now
12521 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12522 C now calculate distance from center of tube and direction vectors
12523 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12524 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12525 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12526 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12527 vectube(1)=vectube(1)-tubecenter(1)
12528 vectube(2)=vectube(2)-tubecenter(2)
12530 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12531 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12533 C as the tube is infinity we do not calculate the Z-vector use of Z
12536 C now calculte the distance
12537 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12538 C now normalize vector
12539 vectube(1)=vectube(1)/tub_r
12540 vectube(2)=vectube(2)/tub_r
12541 C calculte rdiffrence between r and r0
12544 rdiff6=rdiff**6.0d0
12545 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12546 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12547 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12548 C print *,rdiff,rdiff6,pep_aa_tube
12549 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12550 C now we calculate gradient
12551 fac=(-12.0d0*pep_aa_tube/rdiff6+
12552 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12553 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12556 C now direction of gg_tube vector
12558 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12559 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12562 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12564 C Lets not jump over memory as we use many times iti
12566 C lets ommit dummy atoms for now
12568 C in UNRES uncomment the line below as GLY has no side-chain...
12571 vectube(1)=c(1,i+nres)
12572 vectube(1)=mod(vectube(1),boxxsize)
12573 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12574 vectube(2)=c(2,i+nres)
12575 vectube(2)=mod(vectube(2),boxxsize)
12576 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12578 vectube(1)=vectube(1)-tubecenter(1)
12579 vectube(2)=vectube(2)-tubecenter(2)
12581 C as the tube is infinity we do not calculate the Z-vector use of Z
12584 C now calculte the distance
12585 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12586 C now normalize vector
12587 vectube(1)=vectube(1)/tub_r
12588 vectube(2)=vectube(2)/tub_r
12589 C calculte rdiffrence between r and r0
12592 rdiff6=rdiff**6.0d0
12593 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12594 sc_aa_tube=sc_aa_tube_par(iti)
12595 sc_bb_tube=sc_bb_tube_par(iti)
12596 enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
12597 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12598 C now we calculate gradient
12599 fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12600 & 6.0d0*sc_bb_tube/rdiff6/rdiff
12601 C now direction of gg_tube vector
12603 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12604 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12608 Etube=Etube+enetube(i)
12610 C print *,"ETUBE", etube
12613 C TO DO 1) add to total energy
12614 C 2) add to gradient summation
12615 C 3) add reading parameters (AND of course oppening of PARAM file)
12616 C 4) add reading the center of tube
12618 C 6) add to zerograd
12620 C-----------------------------------------------------------------------
12621 C-----------------------------------------------------------
12622 C This subroutine is to mimic the histone like structure but as well can be
12623 C utilizet to nanostructures (infinit) small modification has to be used to
12624 C make it finite (z gradient at the ends has to be changes as well as the x,y
12625 C gradient has to be modified at the ends
12626 C The energy function is Kihara potential
12627 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12628 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12629 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12630 C simple Kihara potential
12631 subroutine calctube2(Etube)
12632 implicit real*8 (a-h,o-z)
12633 include 'DIMENSIONS'
12634 include 'COMMON.GEO'
12635 include 'COMMON.VAR'
12636 include 'COMMON.LOCAL'
12637 include 'COMMON.CHAIN'
12638 include 'COMMON.DERIV'
12639 include 'COMMON.NAMES'
12640 include 'COMMON.INTERACT'
12641 include 'COMMON.IOUNITS'
12642 include 'COMMON.CALC'
12643 include 'COMMON.CONTROL'
12644 include 'COMMON.SPLITELE'
12645 include 'COMMON.SBRIDGE'
12646 double precision tub_r,vectube(3),enetube(maxres*2)
12651 C first we calculate the distance from tube center
12652 C first sugare-phosphate group for NARES this would be peptide group
12655 C lets ommit dummy atoms for now
12656 if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12657 C now calculate distance from center of tube and direction vectors
12658 vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12659 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12660 vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12661 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12662 vectube(1)=vectube(1)-tubecenter(1)
12663 vectube(2)=vectube(2)-tubecenter(2)
12665 C print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12666 C print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12668 C as the tube is infinity we do not calculate the Z-vector use of Z
12671 C now calculte the distance
12672 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12673 C now normalize vector
12674 vectube(1)=vectube(1)/tub_r
12675 vectube(2)=vectube(2)/tub_r
12676 C calculte rdiffrence between r and r0
12679 rdiff6=rdiff**6.0d0
12680 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12681 enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12682 C write(iout,*) "TU13",i,rdiff6,enetube(i)
12683 C print *,rdiff,rdiff6,pep_aa_tube
12684 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12685 C now we calculate gradient
12686 fac=(-12.0d0*pep_aa_tube/rdiff6+
12687 & 6.0d0*pep_bb_tube)/rdiff6/rdiff
12688 C write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12691 C now direction of gg_tube vector
12693 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12694 gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12697 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12699 C Lets not jump over memory as we use many times iti
12701 C lets ommit dummy atoms for now
12703 C in UNRES uncomment the line below as GLY has no side-chain...
12706 vectube(1)=c(1,i+nres)
12707 vectube(1)=mod(vectube(1),boxxsize)
12708 if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12709 vectube(2)=c(2,i+nres)
12710 vectube(2)=mod(vectube(2),boxxsize)
12711 if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12713 vectube(1)=vectube(1)-tubecenter(1)
12714 vectube(2)=vectube(2)-tubecenter(2)
12715 C THIS FRAGMENT MAKES TUBE FINITE
12716 positi=(mod(c(3,i+nres),boxzsize))
12717 if (positi.le.0) positi=positi+boxzsize
12718 C print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12719 c for each residue check if it is in lipid or lipid water border area
12720 C respos=mod(c(3,i+nres),boxzsize)
12721 print *,positi,bordtubebot,buftubebot,bordtubetop
12722 if ((positi.gt.bordtubebot)
12723 & .and.(positi.lt.bordtubetop)) then
12724 C the energy transfer exist
12725 if (positi.lt.buftubebot) then
12727 & ((positi-bordtubebot)/tubebufthick)
12728 C lipbufthick is thickenes of lipid buffore
12729 sstube=sscalelip(fracinbuf)
12730 ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12731 print *,ssgradtube, sstube,tubetranene(itype(i))
12732 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12733 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12734 &+ssgradtube*tubetranene(itype(i))
12735 gg_tube(3,i-1)= gg_tube(3,i-1)
12736 &+ssgradtube*tubetranene(itype(i))
12737 C print *,"doing sccale for lower part"
12738 elseif (positi.gt.buftubetop) then
12740 &((bordtubetop-positi)/tubebufthick)
12741 sstube=sscalelip(fracinbuf)
12742 ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12743 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12744 C gg_tube_SC(3,i)=gg_tube_SC(3,i)
12745 C &+ssgradtube*tubetranene(itype(i))
12746 C gg_tube(3,i-1)= gg_tube(3,i-1)
12747 C &+ssgradtube*tubetranene(itype(i))
12748 C print *, "doing sscalefor top part",sslip,fracinbuf
12752 enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12753 C print *,"I am in true lipid"
12759 endif ! if in lipid or buffor
12760 CEND OF FINITE FRAGMENT
12761 C as the tube is infinity we do not calculate the Z-vector use of Z
12764 C now calculte the distance
12765 tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12766 C now normalize vector
12767 vectube(1)=vectube(1)/tub_r
12768 vectube(2)=vectube(2)/tub_r
12769 C calculte rdiffrence between r and r0
12772 rdiff6=rdiff**6.0d0
12773 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12774 sc_aa_tube=sc_aa_tube_par(iti)
12775 sc_bb_tube=sc_bb_tube_par(iti)
12776 enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12777 & *sstube+enetube(i+nres)
12778 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12779 C now we calculate gradient
12780 fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12781 & 6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12782 C now direction of gg_tube vector
12784 gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12785 gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12787 gg_tube_SC(3,i)=gg_tube_SC(3,i)
12788 &+ssgradtube*enetube(i+nres)/sstube
12789 gg_tube(3,i-1)= gg_tube(3,i-1)
12790 &+ssgradtube*enetube(i+nres)/sstube
12794 Etube=Etube+enetube(i)
12796 C print *,"ETUBE", etube
12799 C TO DO 1) add to total energy
12800 C 2) add to gradient summation
12801 C 3) add reading parameters (AND of course oppening of PARAM file)
12802 C 4) add reading the center of tube
12804 C 6) add to zerograd
12805 c----------------------------------------------------------------------------
12806 subroutine e_saxs(Esaxs_constr)
12808 include 'DIMENSIONS'
12811 include "COMMON.SETUP"
12814 include 'COMMON.SBRIDGE'
12815 include 'COMMON.CHAIN'
12816 include 'COMMON.GEO'
12817 include 'COMMON.DERIV'
12818 include 'COMMON.LOCAL'
12819 include 'COMMON.INTERACT'
12820 include 'COMMON.VAR'
12821 include 'COMMON.IOUNITS'
12822 c include 'COMMON.MD'
12825 include 'COMMON.LANGEVIN.lang0.5diag'
12827 include 'COMMON.LANGEVIN.lang0'
12830 include 'COMMON.LANGEVIN'
12832 include 'COMMON.CONTROL'
12833 include 'COMMON.SAXS'
12834 include 'COMMON.NAMES'
12835 include 'COMMON.TIME1'
12836 include 'COMMON.FFIELD'
12838 double precision Esaxs_constr
12839 integer i,iint,j,k,l
12840 double precision PgradC(maxSAXS,3,maxres),
12841 & PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12843 double precision PgradC_(maxSAXS,3,maxres),
12844 & PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12846 double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12847 & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12848 & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12849 & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12850 double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12851 double precision dist,mygauss,mygaussder
12853 integer llicz,lllicz
12854 double precision time01
12855 c SAXS restraint penalty function
12857 write(iout,*) "------- SAXS penalty function start -------"
12858 write (iout,*) "nsaxs",nsaxs
12859 write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12860 write (iout,*) "Psaxs"
12862 write (iout,'(i5,e15.5)') i, Psaxs(i)
12868 Esaxs_constr = 0.0d0
12873 PgradC(k,l,j)=0.0d0
12874 PgradX(k,l,j)=0.0d0
12879 do i=iatsc_s,iatsc_e
12880 if (itype(i).eq.ntyp1) cycle
12881 do iint=1,nint_gr(i)
12882 do j=istart(i,iint),iend(i,iint)
12883 if (itype(j).eq.ntyp1) cycle
12886 dijCASC=dist(i,j+nres)
12887 dijSCCA=dist(i+nres,j)
12888 dijSCSC=dist(i+nres,j+nres)
12889 sigma2CACA=2.0d0/(pstok**2)
12890 sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12891 sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12892 sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12895 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12896 if (itype(j).ne.10) then
12897 expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12901 if (itype(i).ne.10) then
12902 expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12906 if (itype(i).ne.10 .and. itype(j).ne.10) then
12907 expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12911 Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12913 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12915 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12916 CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12917 SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12918 SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12921 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12922 PgradC(k,l,i) = PgradC(k,l,i)-aux
12923 PgradC(k,l,j) = PgradC(k,l,j)+aux
12925 if (itype(j).ne.10) then
12926 aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12927 PgradC(k,l,i) = PgradC(k,l,i)-aux
12928 PgradC(k,l,j) = PgradC(k,l,j)+aux
12929 PgradX(k,l,j) = PgradX(k,l,j)+aux
12932 if (itype(i).ne.10) then
12933 aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12934 PgradX(k,l,i) = PgradX(k,l,i)-aux
12935 PgradC(k,l,i) = PgradC(k,l,i)-aux
12936 PgradC(k,l,j) = PgradC(k,l,j)+aux
12939 if (itype(i).ne.10 .and. itype(j).ne.10) then
12940 aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12941 PgradC(k,l,i) = PgradC(k,l,i)-aux
12942 PgradC(k,l,j) = PgradC(k,l,j)+aux
12943 PgradX(k,l,i) = PgradX(k,l,i)-aux
12944 PgradX(k,l,j) = PgradX(k,l,j)+aux
12950 sigma2CACA=scal_rad**2*0.25d0/
12951 & (restok(itype(j))**2+restok(itype(i))**2)
12952 c write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12953 c & ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12955 sigmaCACA=dsqrt(sigma2CACA)
12956 threesig=3.0d0/sigmaCACA
12960 if (dabs(dijCACA-dk).ge.threesig) cycle
12963 aux = sigmaCACA*(dijCACA-dk)
12964 expCACA = mygauss(aux)
12965 c if (expcaca.eq.0.0d0) cycle
12966 Pcalc(k) = Pcalc(k)+expCACA
12967 CACAgrad = -sigmaCACA*mygaussder(aux)
12968 c write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12970 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12971 PgradC(k,l,i) = PgradC(k,l,i)-aux
12972 PgradC(k,l,j) = PgradC(k,l,j)+aux
12975 c write (iout,*) "i",i," j",j," llicz",llicz
12977 IF (saxs_cutoff.eq.0) THEN
12980 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12981 Pcalc(k) = Pcalc(k)+expCACA
12982 CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12984 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12985 PgradC(k,l,i) = PgradC(k,l,i)-aux
12986 PgradC(k,l,j) = PgradC(k,l,j)+aux
12990 rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12993 c write (2,*) "ijk",i,j,k
12994 sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12995 if (sss2.eq.0.0d0) cycle
12996 ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12997 if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12998 & 'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12999 & 1.0d0/dsqrt(sigma2CACA),rrr,dk,
13001 expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
13002 Pcalc(k) = Pcalc(k)+expCACA
13004 write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
13006 CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
13007 & ssgrad2*expCACA/sss2
13010 aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
13011 PgradC(k,l,i) = PgradC(k,l,i)+aux
13012 PgradC(k,l,j) = PgradC(k,l,j)-aux
13022 c time_SAXS=time_SAXS+MPI_Wtime()-time01
13024 c write (iout,*) "lllicz",lllicz
13026 c time01=MPI_Wtime()
13029 if (nfgtasks.gt.1) then
13030 call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
13031 & MPI_SUM,FG_COMM,IERR)
13032 c if (fg_rank.eq.king) then
13034 Pcalc(k) = Pcalc_(k)
13037 c call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
13038 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13039 c if (fg_rank.eq.king) then
13043 c PgradC(k,l,i) = PgradC_(k,l,i)
13049 c call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
13050 c & MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
13051 c if (fg_rank.eq.king) then
13055 c PgradX(k,l,i) = PgradX_(k,l,i)
13065 Cnorm = Cnorm + Pcalc(k)
13068 if (fg_rank.eq.king) then
13070 Esaxs_constr = dlog(Cnorm)-wsaxs0
13072 if (Pcalc(k).gt.0.0d0)
13073 & Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
13075 write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
13079 write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
13094 & auxC = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
13095 auxC1 = auxC1+PgradC(k,l,i)
13097 auxX = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
13098 auxX1 = auxX1+PgradX(k,l,i)
13101 gsaxsC(l,i) = auxC - auxC1/Cnorm
13103 gsaxsX(l,i) = auxX - auxX1/Cnorm
13105 c write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
13106 c * " gradX",wsaxs*(auxX - auxX1/Cnorm)
13107 c write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
13108 c * " gradX",wsaxs*gsaxsX(l,i)
13112 time_SAXS=time_SAXS+MPI_Wtime()-time01
13115 write (iout,*) "gsaxsc"
13117 write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
13125 c----------------------------------------------------------------------------
13126 subroutine e_saxsC(Esaxs_constr)
13128 include 'DIMENSIONS'
13131 include "COMMON.SETUP"
13134 include 'COMMON.SBRIDGE'
13135 include 'COMMON.CHAIN'
13136 include 'COMMON.GEO'
13137 include 'COMMON.DERIV'
13138 include 'COMMON.LOCAL'
13139 include 'COMMON.INTERACT'
13140 include 'COMMON.VAR'
13141 include 'COMMON.IOUNITS'
13142 c include 'COMMON.MD'
13145 include 'COMMON.LANGEVIN.lang0.5diag'
13147 include 'COMMON.LANGEVIN.lang0'
13150 include 'COMMON.LANGEVIN'
13152 include 'COMMON.CONTROL'
13153 include 'COMMON.SAXS'
13154 include 'COMMON.NAMES'
13155 include 'COMMON.TIME1'
13156 include 'COMMON.FFIELD'
13158 double precision Esaxs_constr
13159 integer i,iint,j,k,l
13160 double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
13162 double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
13164 double precision dk,dijCASPH,dijSCSPH,
13165 & sigma2CA,sigma2SC,expCASPH,expSCSPH,
13166 & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
13168 c SAXS restraint penalty function
13170 write(iout,*) "------- SAXS penalty function start -------"
13171 write (iout,*) "nsaxs",nsaxs
13174 print *,MyRank,"C",i,(C(j,i),j=1,3)
13177 print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
13180 Esaxs_constr = 0.0d0
13182 do j=isaxs_start,isaxs_end
13191 if (itype(i).eq.ntyp1) cycle
13195 dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
13197 if (itype(i).ne.10) then
13199 dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
13202 sigma2CA=2.0d0/pstok**2
13203 sigma2SC=4.0d0/restok(itype(i))**2
13204 expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
13205 expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
13206 Pcalc = Pcalc+expCASPH+expSCSPH
13208 write(*,*) "processor i j Pcalc",
13209 & MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
13211 CASPHgrad = sigma2CA*expCASPH
13212 SCSPHgrad = sigma2SC*expSCSPH
13214 aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
13215 PgradX(l,i) = PgradX(l,i) + aux
13216 PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
13221 gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
13222 gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
13225 logPtot = logPtot - dlog(Pcalc)
13226 c print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
13227 c & " logPtot",logPtot
13230 if (nfgtasks.gt.1) then
13231 c write (iout,*) "logPtot before reduction",logPtot
13232 call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
13233 & MPI_SUM,king,FG_COMM,IERR)
13235 c write (iout,*) "logPtot after reduction",logPtot
13236 call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
13237 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13238 if (fg_rank.eq.king) then
13241 gsaxsC(l,i) = gsaxsC_(l,i)
13245 call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
13246 & MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
13247 if (fg_rank.eq.king) then
13250 gsaxsX(l,i) = gsaxsX_(l,i)
13256 Esaxs_constr = logPtot
13259 c----------------------------------------------------------------------------
13260 double precision function sscale2(r,r_cut,r0,rlamb)
13262 double precision r,gamm,r_cut,r0,rlamb,rr
13264 c write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
13265 c write (2,*) "rr",rr
13266 if(rr.lt.r_cut-rlamb) then
13268 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13269 gamm=(rr-(r_cut-rlamb))/rlamb
13270 sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13276 C-----------------------------------------------------------------------
13277 double precision function sscalgrad2(r,r_cut,r0,rlamb)
13279 double precision r,gamm,r_cut,r0,rlamb,rr
13281 if(rr.lt.r_cut-rlamb) then
13283 else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
13284 gamm=(rr-(r_cut-rlamb))/rlamb
13286 sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
13288 sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
13295 c------------------------------------------------------------------------
13296 double precision function boxshift(x,boxsize)
13298 double precision x,boxsize
13299 double precision xtemp
13300 xtemp=dmod(x,boxsize)
13301 if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
13302 boxshift=xtemp-boxsize
13303 else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
13304 boxshift=xtemp+boxsize
13310 c--------------------------------------------------------------------------
13311 subroutine closest_img(xi,yi,zi,xj,yj,zj)
13312 include 'DIMENSIONS'
13313 include 'COMMON.CHAIN'
13314 integer xshift,yshift,zshift,subchap
13315 double precision dist_init,xj_safe,yj_safe,zj_safe,
13316 & xj_temp,yj_temp,zj_temp,dist_temp
13320 dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13325 xj=xj_safe+xshift*boxxsize
13326 yj=yj_safe+yshift*boxysize
13327 zj=zj_safe+zshift*boxzsize
13328 dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13329 if(dist_temp.lt.dist_init) then
13330 dist_init=dist_temp
13339 if (subchap.eq.1) then
13350 c--------------------------------------------------------------------------
13351 subroutine to_box(xi,yi,zi)
13353 include 'DIMENSIONS'
13354 include 'COMMON.CHAIN'
13355 double precision xi,yi,zi
13356 xi=dmod(xi,boxxsize)
13357 if (xi.lt.0.0d0) xi=xi+boxxsize
13358 yi=dmod(yi,boxysize)
13359 if (yi.lt.0.0d0) yi=yi+boxysize
13360 zi=dmod(zi,boxzsize)
13361 if (zi.lt.0.0d0) zi=zi+boxzsize
13364 c--------------------------------------------------------------------------
13365 subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13367 include 'DIMENSIONS'
13368 include 'COMMON.IOUNITS'
13369 include 'COMMON.CHAIN'
13370 double precision xi,yi,zi,sslipi,ssgradlipi
13371 double precision fracinbuf
13372 double precision sscalelip,sscagradlip
13374 write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
13375 write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
13376 write (iout,*) "xi yi zi",xi,yi,zi
13378 if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
13379 C the energy transfer exist
13380 if (zi.lt.buflipbot) then
13381 C what fraction I am in
13382 fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
13383 C lipbufthick is thickenes of lipid buffore
13384 sslipi=sscalelip(fracinbuf)
13385 ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13386 elseif (zi.gt.bufliptop) then
13387 fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13388 sslipi=sscalelip(fracinbuf)
13389 ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13399 write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi